Open Window in 64 Bit Excel VBA 7 using Windows API

[dace18]

Hi

I've used the Windows API to open custom windows in Excel VBA all the way up to VBA 7 on 32 bit operating systems, however when I try on a Win10 64 bit system the CreateWindowEx call fails. It issues the following messages, 36, 129 and 130. So as soon as it issues the WM_NCCREATE it then issues WM_NCDESTROY. GetLastError() doesn't provide any clues. Has anyone managed to open a custom window on Win 10 64 bit?

Notes:
RegisterClassEx returns a valid handle.
STATIC window classes open fine.

Thanks

Dave

Private 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 LongPtr, ByVal hMenu As LongPtr, ByVal hInstance As LongPtr, lpParam As Any) As LongPtrPrivate Declare PtrSafe Function DestroyWindow Lib "user32" (ByVal hWnd As LongPtr) As Long
Private Declare PtrSafe Function ShowWindow Lib "user32" (ByVal lhwnd As LongPtr, ByVal nCmdShow As Long) As Long
Private Declare PtrSafe Function RegisterClassEx Lib "user32" Alias "RegisterClassExA" (pcWndClassEx As WNDCLASSEX) As Long
Private Declare PtrSafe Function UnregisterClass Lib "user32" Alias "UnregisterClassA" (ByVal lpClassName As String, ByVal hInstance As LongPtr) As Long
Private Declare PtrSafe Function DefWindowProc Lib "user32" Alias "DefWindowProcA" (ByVal lhwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As Long
Private Declare PtrSafe Function LoadIcon Lib "user32" Alias "LoadIconA" (ByVal hInstance As LongPtr, ByVal lpIconName As Any) As LongPtr
Private Declare PtrSafe Function LoadCursor Lib "user32" Alias "LoadCursorA" (ByVal hInstance As LongPtr, ByVal lpCursorName As Any) As LongPtr
Private Declare PtrSafe Function ShowCursor Lib "user32" (ByVal fShow As Long) As Long
Private Declare PtrSafe Function GetStockObject Lib "gdi32" (ByVal nIndex As Long) As LongPtr
Private Declare PtrSafe Function GetLastError Lib "kernel32" () As Long
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr


Public Declare PtrSafe Function GetMessage Lib "user32" Alias "GetMessageA" (lpMsg As MSG, ByVal lhwnd As LongPtr, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long) As Long
Private Declare PtrSafe Function TranslateMessage Lib "user32" (lpMsg As MSG) As Long
Private Declare PtrSafe Function DispatchMessage Lib "user32" Alias "DispatchMessageA" (lpMsg As MSG) As Long






Private Type WNDCLASSEX 'size=48/56 on 32 bit and 80 on 64 bit?
    cbSize As Long  '4
    style As Long   '4
    lpfnWndProc As LongPtr  '4 or 8
    cbClsExtra As Long      '4
    cbWndExtra As Long      '4
    hInstance As LongPtr    '4 or 8
    hIcon As LongPtr        '4 or 8
    hCursor As LongPtr      '4 or 8
    hbrBackground As LongPtr '4 or 8
    lpszMenuName As String   '8
    lpszClassName As String '8
    hIconSm As LongPtr      '4 or 8
End Type


Private Type POINTAPI
    x As Long
    y As Long
End Type


Public Type MSG
    lhwnd As LongPtr
    tmessage As Long
    wParam As Long
    lParam As Long
    time As Long
    pt As POINTAPI
End Type




Private Const SW_SHOWNORMAL As Long = 1
Private Const CS_HREDRAW As Long = &H2
Private Const CS_VREDRAW As Long = &H1
Private Const IDI_APPLICATION As Long = 32512&
Private Const IDC_ARROW As Long = 32512&
Private Const IDC_HAND As Long = 32649&
Private Const WHITE_BRUSH As Integer = 0
Private Const BLACK_BRUSH As Integer = 4


Private Const CLASSNAME = "Custom"
'








Sub main()
    Dim hInst As LongPtr
    Dim hWnd As LongPtr
    Dim a_hWnd As LongPtr
    hInst = Application.HinstancePtr
    
    Dim tmessage As MSG
    
    Dim wc As WNDCLASSEX
    Dim ires As Long
    Dim lres As Long
    
    wc.cbSize = LenB(wc) '80
    wc.style = CS_HREDRAW Or CS_VREDRAW
    wc.lpfnWndProc = FunctionPointer(AddressOf WndProc)
    wc.cbClsExtra = 0&
    wc.cbWndExtra = 0&
    wc.hInstance = hInst
    wc.hIcon = LoadIcon(0&, IDI_APPLICATION)
    wc.hCursor = LoadCursor(0&, IDC_ARROW)
    wc.hbrBackground = GetStockObject(BLACK_BRUSH)
    wc.lpszMenuName = ""
    wc.lpszClassName = "MyClass"
    wc.hIconSm = LoadIcon(0&, IDI_APPLICATION)
    ires = RegisterClassEx(wc)
    lres = GetLastError()
    
  '  a_hWnd = CreateWindowEx(ByVal 0&, "BUTTON", "Hello !", WS_POPUP, 0, 0, 320, 240, ByVal 0&, ByVal 0&, hInst, ByVal 0&)
    a_hWnd = CreateWindowEx(WS_EX_TOPMOST, "MyClass", "TEST", WS_POPUP, 20, 20, 324, 290, ByVal 0&, ByVal 0&, hInst, ByVal 0&)
  '  a_hWnd = CreateWindowEx(ByVal 0&, "STATIC", "TEST", WS_BORDER Or WS_CAPTION Or WS_POPUP, 20, 20, 324, 290, ByVal 0&, ByVal 0&, hInst, ByVal 0&)
    If a_hWnd = 0 Then
        lres = GetLastError()
        MsgBox "Could not open window - GetLastError reports " + Str(lres)
        GoTo nowindow
    End If
    
    ShowWindow a_hWnd, SW_SHOWNORMAL
    
    Do While 0 <> GetMessage(tmessage, 0&, 0&, 0&)      'Retrieve a message from the calling thread’s message queue
        TranslateMessage tmessage                       'Translate virtual-key messages into character messages (character messages are posted to the calling thread's message queue).
        DispatchMessage tmessage                        'Dispatch message to window procedure (WindowProc)
    Loop


    
    DestroyWindow a_hWnd
nowindow:
    lres = UnregisterClass("MyClass", hInst)
    lres = GetLastError()
End Sub


'Returns the value from the AddressOf unary operator.
Function FunctionPointer(ByVal lPtr As LongPtr) As LongPtr
    FunctionPointer = lPtr
End Function




Private Function WndProc(ByVal hWnd As LongPtr, ByVal message As Long, ByVal wParam As LongPtr, ByVal lParam As Long) As LongPtr
 
    WndProc = DefWindowProc(hWnd, message, wParam, lParam)
End Function

[dace18]

Solved it. A couple of LongPtrs missing. One on the return value of the DefWindowProc declaration and another on the lParam on the WndProc function.