CPF2014
CPF2014
采纳率50%
2019-12-01 21:51 阅读 403

excel2016 64bit的vba中使用API函数RegisterClass注册窗体类就Excel就崩溃

excel2016 64bit的vba中使用API函数RegisterClass注册窗体类就Excel就崩溃!请问是怎么回事?

Option Explicit

Public Declare PtrSafe Function RegisterClass Lib "user32" Alias "RegisterClassA" (Class As WNDCLASS) As Long
Public Declare PtrSafe Function UnregisterClass Lib "user32" Alias "UnregisterClassA" (ByVal lpClassName As String, ByVal hInstance As Long) As Long
Public Declare PtrSafe 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 PtrSafe 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 PtrSafe Function TranslateMessage Lib "user32" (lpMsg As Msg) As Long
Public Declare PtrSafe Function DispatchMessage Lib "user32" Alias "DispatchMessageA" (lpMsg As Msg) As Long
Public Declare PtrSafe Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Public Declare PtrSafe Function LoadCursor Lib "user32" Alias "LoadCursorA" (ByVal hInstance As Long, ByVal lpCursorName As Any) As Long
Public Declare PtrSafe Function LoadIcon Lib "user32" Alias "LoadIconA" (ByVal hInstance As Long, ByVal lpIconName As String) As Long
Public Declare PtrSafe Function CreateWindowEx Lib "user32" 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 PtrSafe Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Public Declare PtrSafe Function SetWindowLongPtr Lib "user32" Alias "SetWindowLongPtrA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Public Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Public Declare PtrSafe Function MessageBox Lib "user32" Alias "MessageBoxA" (ByVal hwnd As Long, ByVal lpText As String, ByVal lpCaption As String, ByVal wType As Long) As Long
Public Declare PtrSafe Function PostQuitMessage Lib "user32" (ByVal nExitCode As Long)
Public Declare PtrSafe Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOPENFILENAME As OPENFILENAME) As Long
Public Declare PtrSafe Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (pOPENFILENAME As OPENFILENAME) As Long
Public Declare PtrSafe Function GetLastError Lib "kernel32" () As Long

Public Type OPENFILENAME
    lStructSize As Long
    hwndOwner As Long
    hInstance As Long
    lpstrFilter As String
    lpstrCustomFilter As String
    nMaxCustFilter As Long
    nFilterIndex As Long
    lpstrFile As String
    nMaxFile As Long
    lpstrFileTitle As String
    nMaxFileTitle As Long
    lpstrInitialDir As String
    lpstrTitle As String
    flags As Long
    nFileOffset As Integer
    nFileExtension As Integer
    lpstrDefExt As String
    lCustData As Long
    lpfnHook As Long
    lpTemplateName As String
End Type
 Public Const OFN_OVERWRITEPROMPT = &H2
 Public Const OFN_HIDEREADONLY = &H4
 Public Const OFN_PATHMUSTEXIST = &H800
 Public Const OFN_FILEMUSTEXIST = &H1000
Public Type WNDCLASS
    style As Long
    lpfnwndproc As LongPtr
    cbClsextra As Long
    cbWndExtra2 As Long
    hInstance As LongPtr
    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 CW_USEDEFAULT = &H80000000
Public Const ES_MULTILINE = &H4&
Public Const WS_BORDER = &H800000
Public Const WS_CHILD = &H40000000
Public Const WS_OVERLAPPED = &H0&
Public Const WS_CAPTION = &HC00000 ' WS_BORDER Or WS_DLGFRAME
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_CAPTION Or WS_SYSMENU Or WS_THICKFRAME Or WS_MINIMIZEBOX Or WS_MAXIMIZEBOX)
Public Const WS_EX_CLIENTEDGE = &H200&
Public Const COLOR_WINDOW = 5
Public Const WM_DESTROY = &H2
Public Const WM_LBUTTONDOWN = &H201
Public Const WM_LBUTTONUP = &H202
Public Const IDC_ARROW = 32512&
Public Const IDI_APPLICATION = 32512&
Public Const GWL_WNDPROC = (-4)
Public Const SW_SHOWNORMAL = 1
Public Const MB_OK = &H0&
Public Const MB_ICONEXCLAMATION = &H30&

Public Const gClassName = "MyClassName"
Public Const gAppName = "My Window Caption"
Public gButOldProc As Long
Public gHwnd As Long, gButtonHwnd As Long, gEditHwnd As Long

Public Sub Main()
    Dim wMsg As Msg
    ''Call procedure to register window classname. If false, then exit.
    If RegisterWindowClass = False Then Exit Sub

    ''Create window
    If CreateWindows Then
        ''Loop will exit when WM_QUIT is sent to the window.
        Do While GetMessage(wMsg, 0&, 0&, 0&)
            ''TranslateMessage takes keyboard messages and converts
            ''them to WM_CHAR for easier processing.
            Call TranslateMessage(wMsg)
            ''Dispatchmessage calls the default window procedure
            ''to process the window message. (WndProc)
            Call DispatchMessage(wMsg)
        Loop
    End If
    Call UnregisterClass(gClassName$, Application.hInstance)

End Sub
Public Function RegisterWindowClass() As Boolean
    Dim wc As WNDCLASS
    Dim a As Variant

    wc.style = CS_HREDRAW Or CS_VREDRAW
    wc.lpfnwndproc = GetAddress(AddressOf WndProc) ''Address in memory of default window procedure.
    wc.hInstance = Application.HinstancePtr
    wc.hIcon = LoadIcon(0&, IDI_APPLICATION) ''Default application icon
    wc.hCursor = LoadCursor(0&, IDC_ARROW) ''Default arrow
    wc.hbrBackground = COLOR_WINDOW ''Default a color for window.
    wc.lpszClassName = gClassName$
    RegisterWindowClass = RegisterClass(wc)
     a = GetLastError
     Debug.Print RegisterWindowClass & "ERR"
     Debug.Print CStr(GetLastError())
End Function
Public Function CreateWindows() As Boolean

    ''开始创建窗体
    gHwnd& = CreateWindowEx(0&, gClassName$, gAppName$, WS_OVERLAPPEDWINDOW, CW_USEDEFAULT, CW_USEDEFAULT, 208, 150, 0&, 0&, App.hInstance, ByVal 0&)
    ''创建一个按钮
    gButtonHwnd& = CreateWindowEx(0&, "Button", "Click Here", WS_CHILD, 58, 90, 85, 25, gHwnd&, 0&, App.hInstance, 0&)
    ''创建一个(WS_EX_CLIENTEDGE、ES_MULTILINE风格的TextBox
    gEditHwnd& = CreateWindowEx(WS_EX_CLIENTEDGE, "Edit", "This is the edit control." & vbCrLf & "As you can see, it's multiline.", WS_CHILD Or ES_MULTILINE, 0&, 0&, 200, 80, gHwnd&, 0&, App.hInstance, 0&)

    Call ShowWindow(gHwnd&, SW_SHOWNORMAL)
    Call ShowWindow(gButtonHwnd&, SW_SHOWNORMAL)
    Call ShowWindow(gEditHwnd&, SW_SHOWNORMAL)
    gButOldProc& = GetWindowLong(gButtonHwnd&, GWL_WNDPROC)


    ''Set default window procedure of button to ButtonWndProc. Different
    ''settings of windows is listed in the MSDN Library. We are using GWL_WNDPROC
    ''to set the address of the window procedure.
    Call SetWindowLongPtr(gButtonHwnd&, GWL_WNDPROC, GetAddress(AddressOf ButtonWndProc))
    CreateWindows = (gHwnd& <> 0)

End Function
'窗体运行的主函数,在注册这个窗体时已经指定的
Public Function WndProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Dim strTemp As String
    Select Case uMsg&
    Case WM_DESTROY:
        ''Since DefWindowProc doesn't automatically call
        ''PostQuitMessage (WM_QUIT). We need to do it ourselves.
        ''You can use DestroyWindow to get rid of the window manually.
        Call PostQuitMessage(0&)
    End Select

    ''Let windows call the default window procedure since we're done.
    WndProc = DefWindowProc(hwnd&, uMsg&, wParam&, lParam&)
End Function
Public Function ButtonWndProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Select Case uMsg&
    Case WM_LBUTTONUP:
        Call MessageBox(gHwnd&, "You clicked the button!", App.Title, MB_OK Or MB_ICONEXCLAMATION)
    End Select

    ButtonWndProc = CallWindowProc(gButOldProc&, hwnd&, uMsg&, wParam&, lParam&)

End Function

Public Function GetAddress(ByVal lngAddr As LongPtr) As LongPtr
    GetAddress = lngAddr
End Function
  • 点赞
  • 写回答
  • 关注问题
  • 收藏
  • 复制链接分享

1条回答 默认 最新

相关推荐