VBA使用API_03：创建窗体

Public Declare Function RegisterClass Lib "user32" Alias "RegisterClassA" (Class As WndClass) As Long
Public Declare Function UnregisterClass Lib "user32" Alias "UnregisterClassA" (ByVal lpClassName As String, ByVal hInstance As Long) As Long
Public Declare Function DefWindowProc Lib "user32" Alias "DefWindowProcA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Public Declare Function GetMessage Lib "user32" Alias "GetMessageA" (lpMsg As msg, ByVal hWnd As Long, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long) As Long
Public Declare Function TranslateMessage Lib "user32" (lpMsg As msg) As Long
Public Declare Function DispatchMessage Lib "user32" Alias "DispatchMessageA" (lpMsg As msg) As Long
Public Declare Function ShowWindow Lib "user32" (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long
Public Declare Function LoadCursor Lib "user32" Alias "LoadCursorA" (ByVal hInstance As Long, ByVal lpCursorName As Any) As Long
Public Declare Function LoadIcon Lib "user32" Alias "LoadIconA" (ByVal hInstance As Long, ByVal lpIconName As String) As Long
Public Declare Function CreateWindowEx Lib "user32.dll" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, lpParam As Any) As Long

Public Declare Sub PostQuitMessage Lib "user32" (ByVal nExitCode As Long)
Public Declare Function DestroyWindow Lib "user32" (ByVal hWnd As Long) As Long

Public Type WndClass
    Style As Long
    lpfnWndProc As Long
    cbClsExtra As Long
    cbWndExtra2 As Long
    hInstance As Long
    hIcon As Long
    hCursor As Long
    hbrBackground As Long
    lpszMenuName As String
    lpszClassName As String
End Type

Public Type POINTAPI
    x As Long
    y As Long
End Type
Public Type msg
    hWnd As Long
    message As Long
    wParam As Long
    lParam As Long
    time As Long
    pt As POINTAPI
End Type

Public Const CS_VREDRAW = &H1
Public Const CS_HREDRAW = &H2
Public Const IDC_ARROW = 32512&
Public Const IDI_APPLICATION = 32512&
Public Const COLOR_WINDOW = 5

Public Const WS_OVERLAPPED = &H0&
Public Const WS_SYSMENU = &H80000
Public Const WS_THICKFRAME = &H40000
Public Const WS_MINIMIZEBOX = &H20000
Public Const WS_MAXIMIZEBOX = &H10000
Public Const WS_OVERLAPPEDWINDOW = (WS_OVERLAPPED Or WS_SYSMENU Or WS_THICKFRAME Or WS_MINIMIZEBOX Or WS_MAXIMIZEBOX)

Public Const CW_USEDEFAULT = &H80000000

Public Const SW_SHOWNORMAL = 1
Public Const WM_DESTROY = &H2
Public Const WM_LBUTTONDOWN = &H201

Sub VBAMain()
    '初始化注册窗口类所需要的数据
    Dim wc As WndClass
    wc.Style = CS_HREDRAW Or CS_VREDRAW
    '回调函数
    wc.lpfnWndProc = GetAddress(AddressOf WndProc)
    wc.hInstance = Application.hInstance
    wc.hIcon = LoadIcon(0&, IDI_APPLICATION)
    wc.hCursor = LoadCursor(0&, IDC_ARROW)
    wc.hbrBackground = COLOR_WINDOW
    wc.lpszClassName = "myForm"
    
    Dim hWnd As Long
    Dim uMsg As msg
    '注册窗体类
    If RegisterClass(wc) <> 0 Then
        '创建窗体
        hWnd = CreateWindowEx(0, "myForm", "myForm", WS_OVERLAPPEDWINDOW, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, 0, 0, Application.hInstance, ByVal 0)
        
        If hWnd Then
            '显示窗体
            ShowWindow hWnd, SW_SHOWNORMAL
            '循环读取消息
            Do While GetMessage(uMsg, 0, 0, 0)
                '处理消息
                TranslateMessage uMsg
                DispatchMessage uMsg
            Loop
            '反注册窗体类
            UnregisterClass "myForm", Application.hInstance
        
        Else
            MsgBox "CreateWindowEx Error"
        End If
    Else
        MsgBox "RegisterClass Error"
    End If
End Sub

'回调函数
Public Function WndProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    '仅处理WM_DESTROY销毁窗体
    Select Case uMsg
    Case WM_DESTROY:
        DestroyWindow hWnd
        PostQuitMessage 0
        
    Case WM_LBUTTONDOWN:
        Cells(Cells.Rows.Count, 1).End(xlUp).Offset(1, 0).Value = "鼠标左键按下了"
    End Select
    
    '默认的回调函数
    WndProc = DefWindowProc(hWnd&, uMsg, wParam, lParam)
End Function

Public Function GetAddress(ByVal pfunc As Long) As Long
    GetAddress = pfunc
End Function