Other
开启自动换行复制
Option Explicit
               
Declare Function LoadIconW Lib "user32.dll" _
        (ByVal a As Long, ByVal b As Long) As Long
Declare Function LoadCursorW Lib "user32.dll" _
        (ByVal a As Long, ByVal b As Long) As Long
Declare Function GetStockObject Lib "gdi32.dll" _
        (ByVal a As Long) As Long
Declare Function RegisterClassW Lib "user32.dll" (ByVal a As Long) As Long
Declare Function CreateWindowExW Lib "user32.dll" _
        (ByVal a As Long, ByVal b As Long, ByVal c As Long, ByVal d As Long, _
        ByVal e As Long, ByVal f As Long, ByVal g As Long, ByVal h As Long, _
        ByVal i As Long, ByVal j As Long, ByVal k As Long, ByVal l As Long) _
        As Long
Declare Function ShowWindow Lib "user32.dll" _
        (ByVal a As Long, ByVal b As Long) As Long
Declare Function UpdateWindow Lib "user32.dll" (ByVal a As Long) As Long
Declare Function GetMessageW Lib "user32.dll" _
        (ByVal a As Long, ByVal b As Long, ByVal c As Long, ByVal d As Long) _
        As Long
Declare Function TranslateMessage Lib "user32.dll" (ByVal a As Long) As Long
Declare Function DispatchMessageW Lib "user32.dll" (ByVal a As Long) As Long
Declare Function PostQuitMessage Lib "user32.dll" (ByVal a As Long) As Long
Declare Function DefWindowProcW Lib "user32.dll" _
        (ByVal a As Long, ByVal b As Long, ByVal c As Long, ByVal d As Long) _
        As Long
Declare Function MoveWindow Lib "user32.dll" _
        (ByVal a As Long, ByVal b As Long, ByVal c As Long, _
        ByVal d As Long, ByVal e As Long, ByVal f As Long) As Long
Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" _
        (ByVal dst As Long, ByVal src As Long, ByVal length As Long)
               
Type WNDCLASSW
    style As Long
    lpfnWndProc As Long
    cbClsExtra As Long
    cbWndExtra As Long
    hInstance As Long
    hIcon As Long
    hCursor As Long
    hbrBackground As Long
    lpszMenuName As Long
    lpszClassName As Long
End Type
               
Type MSG
    hwnd As Long
    message As Long
    wParam As Long
    lParam As Long
    time As Long
    pt_x As Long
    pt_y As Long
End Type
               
Type POINTS
    x As Integer
    y As Integer
End Type
               
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Program starts here
               
Function GetAddr(ByVal a As Long) As Long
    GetAddr = a
End Function
               
Function MakePOINTS(ByVal l As Long) As POINTS
    CopyMemory VarPtr(MakePOINTS), VarPtr(l), 4
End Function
               
Public Function WndProc(ByVal hwnd As Long, ByVal message As Long, _
                        ByVal wParam As Long, ByVal lParam As Long) As Long
    Static hEdit As Long
    Select Case message
    Case 1 ' WM_CREATE
        ' edit, ID = 1
        ' &H200 = WS_EX_CLIENTEDGE
        ' &H50200004 = WS_CHILD|WS_VISIBLE|WS_VSCROLL|ES_MULTILINE
        hEdit = CreateWindowExW(&H200, StrPtr("edit"), _
                0, &H50200004, _
                10, 10, 200, 100, _
                hwnd, 1, 0, 0)
        WndProc = 0
    Case 5 ' WM_SIZE
        Dim ps As POINTS
        ps = MakePOINTS(lParam)
        MoveWindow hEdit, 10, 10, ps.x - 20, ps.y - 20, 1
        WndProc = 0
    Case 2 ' WM_DESTROY
        PostQuitMessage 0
        WndProc = 0
    Case Else
        WndProc = DefWindowProcW(hwnd, message, wParam, lParam)
    End Select
End Function
               
Sub Main()
    Dim wc As WNDCLASSW
    wc.style = 3 ' CS_HREDRAW | CS_VREDRAW
    wc.lpfnWndProc = GetAddr(AddressOf WndProc)
    wc.hIcon = LoadIconW(0, 32512) 'IDI_APPLICATION
    wc.hCursor = LoadCursorW(0, 32512) ' IDC_ARROW
    wc.hbrBackground = GetStockObject(0) ' WHITE_BRUSH
    wc.lpszClassName = StrPtr("MyVbClass")
    RegisterClassW VarPtr(wc)
                   
    Dim hwnd As Long
    ' &HCF0000 = WS_OVERLAPPEDWINDOW
    ' &H80000000 = CW_USEDEFAULT
    hwnd = CreateWindowExW(0, StrPtr("MyVbClass"), StrPtr("Title"), &HCF0000, _
            &H80000000, &H80000000, &H80000000, &H80000000, _
            0, 0, 0, 0)
    ShowWindow hwnd, 5 ' SW_SHOW
    UpdateWindow hwnd
                   
    Dim mymsg As MSG
    Do While GetMessageW(VarPtr(mymsg), 0, 0, 0)
        TranslateMessage VarPtr(mymsg)
        DispatchMessageW VarPtr(mymsg)
    Loop
End Sub