Subclassing without crashing - (Testers required.)

[Jaafar Tribak]

Hi dear excellers,

I have put together this project which subclasses userforms (can be extended to other windows) and I would like to know if it works as expected for trapping window messages. I am particularly interested to know if the project is stable enough. Meaning: It dosen't shuts down the entire excel application if an unhandled error occurs while the form(s) is (are) subclassed or when pressing the Break, Reset or the Design Mode buttons in the VBE ... Subclassing is notoriously limited in vba if not outright inoperational. Hopefully, with this technique, the crashings will be overcome.

Clicking the 'Raise Error' button on the first form or right-clicking its titlebar should cause an intentional error to help the testings.

Basically, the project makes use of two dlls that I have written and compiled in TwinBasic (one dll is for x32bit excel and the other one is for x64bit) ... I have embedded the dlls binary data in two modules as base64 strings, just like reources for portability reasons ... The code automatically takes care of everything from decoding the base64 strings to extracting the dll bytes and saving them to the temp directory as dll files.

Please, try resizing, moving the forms as well as right-clicking the form's titlebar to see the action.

Thanks.


File for download:
SubclassDll_ VBA_x32_x64.xlsm



Here is the event handler for the first form :

Private Sub oSubclass_MessageReceived( _
    hwnd As LongPtr, _
    uMsg As Long, _
    wParam As LongPtr, _
    lParam As LongPtr, _
    dwRefData As LongPtr, _
    bDiscardMessage As Boolean, _
    lReturnValue As LongPtr _
)
    Const WM_SETCURSOR = &H20, WM_GETMINMAXINFO = &H24, WM_CONTEXTMENU = &H7B
    Select Case uMsg
        Case WM_SETCURSOR      'Hover the mouse over the form.
            Debug.Print Me.Name, Format(Now, "hh:mm:ss")
        Case WM_GETMINMAXINFO  'Resize the form.
            Call CheckMinMaxInfo(lParam, bDiscardMessage)
        Case WM_CONTEXTMENU    'Right-click the form titlebar to raise error..
            Debug.Print 1 / 0  'Raising an error shows that excel doesn't crash (doesn't shut down) !!
    End Select
   
End Sub

For the second form :

Private Sub oSubclass_MessageReceived( _
    hwnd As LongPtr, _
    uMsg As Long, _
    wParam As LongPtr, _
    lParam As LongPtr, _
    dwRefData As LongPtr, _
    bDiscardMessage As Boolean, _
    lReturnValue As LongPtr _
)
   
    Const WM_SYSCOMMAND = &H112, SC_MOVE = &HF012&, WM_NCLBUTTONUP = &HA2
    Const WM_SETCURSOR = &H20, WM_NCMOUSELEAVE = &H2A2
    Select Case uMsg
        Case WM_SYSCOMMAND             'Move the form
            If wParam = SC_MOVE Then
                Label1 = "Sorry, this form is unmovable."
                bDiscardMessage = True 'abort message.
            End If
        Case WM_NCLBUTTONUP            'move the form
            Label1 = ""
        Case WM_SETCURSOR
            If GetAsyncKeyState(VBA.vbKeyLButton) = 0& Then
                Label1 = ""
            End If
         Case WM_NCMOUSELEAVE
            If GetParent(WndFromPoint(hwnd)) <> hwnd Then
               Label1 = "": Call MonitorMouse
            End If
    End Select
   
End Sub

 

[Jaafar Tribak]

5- IEvent Interface Class Module:

Option Explicit

'EventRaiser Interface.

#Const IsNotVBA7 = (VBA7 = 0)
#If IsNotVBA7 Then
    Private Enum LongPtr
        [_]
    End Enum
#End If

Event EventReceived( _
    hwnd As LongPtr, _
    uMsg As Long, _
    wParam As LongPtr, _
    lParam As LongPtr, _
    dwRefData As LongPtr, _
    bDiscardMessage As Boolean _
)

Public Function WndProc( _
    hwnd As LongPtr, _
    uMsg As Long, _
    wParam As LongPtr, _
    lParam As LongPtr, _
    dwRefData As LongPtr, _
    bDiscardMessage As Boolean _
) As LongPtr
    '
End Function

 

[Jaafar Tribak]

6- UserForm1 Module (first example):

Option Explicit

#If VBA7 Then
    #If Win64 Then
        Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As Long
        Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As Long
    #Else
        Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
        Private Declare PtrSafe Function GetWindowLong Lib "USER32.DLL" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
    #End If
    Private Declare PtrSafe Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hwnd As LongPtr) As Long
    Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
    Private Declare PtrSafe Function DrawMenuBar Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
    Private Declare PtrSafe Function IsWindowVisible Lib "user32" (ByVal hwnd As LongPtr) As Long
#Else
    Private Enum LongPtr
        [_]
    End Enum
    Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
    Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
    Private Declare Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hwnd As LongPtr) As Long
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
    Private Declare Function DrawMenuBar Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
    Private Declare Function IsWindowVisible Lib "user32" (ByVal hwnd As LongPtr) As Long
#End If

Private Enum WND_EDGE
    WMSZ_LEFT = 1
    WMSZ_RIGHT = 2
    WMSZ_TOP = 3
    WMSZ_TOPLEFT = 4
    WMSZ_TOPRIGHT = 5
    WMSZ_BOTTOM = 6
    WMSZ_BOTTOMLEFT = 7
    WMSZ_BOTTOMRIGHT = 8
End Enum

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Private Type TrackSize
    MinWidth As Long
    MinHeight As Long
    MaxWidth As Long
    MaxHeight As Long
End Type

Private Type POINTAPI
    x As Long
    y As Long
End Type

Private Type WINDOWPOS
    hwnd As Long
    hwndInsertAfter As Long
    x As Long
    y As Long
    cx As Long
    cy As Long
    flags As Long
End Type

Private Type MinMaxInfo
    ptReserved As POINTAPI
    ptMaxSize As POINTAPI
    ptMaxPosition As POINTAPI
    ptMinMaxTrackSize As TrackSize
End Type

Private WithEvents oSubclass As CSubclasser

Private uTrackSz As TrackSize


Private Sub UserForm_Initialize()
    Me.Caption = "Resizable form"
    Label3 = Width & " pt": Label4 = Height & " pt"
    Call MakeFormResizable(Me)
    Set oSubclass = New CSubclasser
    oSubclass.SubclassWnd fHwnd, ObjPtr(Me)
    CheckBox1 = True: CheckBox2 = True
End Sub

Private Sub CommandButton1_Click()
    UserForm2.Show
End Sub

Private Sub CommandButton2_Click()
    'Raise an error to show that excel doesn't crash (doesn't shut down) even when subclassed !!
    Err.Raise 91
End Sub

Private Sub CheckBox1_Change()
    With oSubclass
        If CheckBox1 Then
            If Not .IsWndSubclassed(fHwnd) Then
                .SubclassWnd fHwnd, ObjPtr(Me)
            End If
        Else
            If .IsWndSubclassed(fHwnd) Then
                .UnSubclassWnd fHwnd, ObjPtr(Me)
            End If
        End If
    End With
End Sub

Private Function CheckMinMaxInfo(ByVal lParam As LongPtr) As TrackSize
    Dim MMI As MinMaxInfo
    CopyMemory MMI, ByVal lParam, LenB(MMI)
    With MMI
        .ptMinMaxTrackSize.MinWidth = 200
        .ptMinMaxTrackSize.MinHeight = 200
        .ptMinMaxTrackSize.MaxWidth = 400
        .ptMinMaxTrackSize.MaxHeight = 400
        CheckMinMaxInfo = MMI.ptMinMaxTrackSize
    End With
    CopyMemory ByVal lParam, MMI, LenB(MMI)
    Label3 = Width & " pt": Label4 = Height & " pt"
End Function

Private Property Get fHwnd() As LongPtr
    Call IUnknown_GetWindow(Me, VarPtr(fHwnd))
End Property

Private Function MakeFormResizable( _
    UF As MSForms.UserForm, _
    Optional bSizable As Boolean = True _
) As Boolean

    Const WS_MAXIMIZEBOX = &H10000, WS_MINIMIZEBOX = &H20000
    Const GWL_STYLE = (-16), WS_THICKFRAME = &H40000
    Dim lStyle As Long, ret As Long
    
    lStyle = GetWindowLong(fHwnd, GWL_STYLE)
    If bSizable Then
        lStyle = lStyle Or WS_THICKFRAME Or WS_MAXIMIZEBOX Or WS_MAXIMIZEBOX
    Else
        lStyle = lStyle And (Not (WS_THICKFRAME Or WS_MAXIMIZEBOX Or WS_MAXIMIZEBOX))
    End If
    ret = SetWindowLong(fHwnd, GWL_STYLE, lStyle)
    Call DrawMenuBar(fHwnd)
    MakeFormResizable = (ret <> 0&)

End Function

Private Function MinMaxPrompt(hwnd As LongPtr, lParam As LongPtr, eWndEdge As WND_EDGE) As String
    Const SWP_NOSIZE = &H1
    Dim uWndPos As WINDOWPOS, uWndRct As RECT, sMsg As String
    Dim lWidth As Long, lHeight As Long
    
    CopyMemory uWndPos, ByVal lParam, LenB(uWndPos)
    GetWindowRect hwnd, uWndRct
    With uWndRct
        lWidth = .Right - .Left:  lHeight = .Bottom - .Top
    End With
    If Not (uWndPos.flags Or SWP_NOSIZE) = uWndPos.flags Then
        With uTrackSz
            If lWidth >= .MaxWidth Or lWidth <= .MinWidth Or lHeight >= .MaxHeight Or lHeight <= .MinHeight Then
                Select Case True
                    Case (lWidth >= .MaxWidth) And (eWndEdge = WMSZ_LEFT Or eWndEdge = WMSZ_RIGHT)
                        sMsg = "max width!"
                    Case (lWidth <= .MinWidth) And (eWndEdge = WMSZ_LEFT Or eWndEdge = WMSZ_RIGHT)
                        sMsg = "min width!"
                    Case (lHeight >= .MaxHeight) And (eWndEdge = WMSZ_TOP Or eWndEdge = WMSZ_BOTTOM)
                        sMsg = "max height!"
                    Case (lHeight <= .MinHeight) And (eWndEdge = WMSZ_TOP Or eWndEdge = WMSZ_BOTTOM)
                        sMsg = "min height!"
                End Select
                If Len(sMsg) Then
                    sMsg = "You reached the " & sMsg
                    MinMaxPrompt = sMsg
                End If
            End If
        End With
    End If
    CopyMemory ByVal lParam, uWndPos, LenB(uWndPos)
End Function


' __________________________________________ EVENT HANDLER ____________________________________________

Private Sub oSubclass_MessageReceived( _
    hwnd As LongPtr, _
    uMsg As Long, _
    wParam As LongPtr, _
    lParam As LongPtr, _
    dwRefData As LongPtr, _
    bDiscardMessage As Boolean, _
    lReturnValue As LongPtr _
)
    Const WM_SETCURSOR = &H20, WM_GETMINMAXINFO = &H24, WM_CONTEXTMENU = &H7B
    Const WM_WINDOWPOSCHANGED = &H47, WM_SIZING = &H214, WM_ACTIVATE = &H6
    Const WM_SYSCOMMAND = &H112, SC_MOVE = &HF012&
    Static eWndEdge As WND_EDGE
    Static bActivated As Boolean
    Dim sMsg As String
    
    Select Case uMsg
        Case WM_ACTIVATE
            bActivated = IIf(wParam <> 0, True, False)
        Case WM_SYSCOMMAND
            bActivated = IIf(wParam <> SC_MOVE, True, False)
        Case WM_SIZING
            eWndEdge = CLng(wParam)  'Save the garbbed edge.
        Case WM_WINDOWPOSCHANGED
            sMsg = MinMaxPrompt(hwnd, lParam, eWndEdge)
            If Len(sMsg) And CheckBox2 Then
                If IsWindowVisible(hwnd) And bActivated Then
                    MsgBox sMsg
                End If
            End If
        Case WM_SETCURSOR      'Hover the mouse pointer over the form.
            Debug.Print Me.Name, Format(Now, "hh:mm:ss")
        Case WM_GETMINMAXINFO  'Resize the form.
            uTrackSz = CheckMinMaxInfo(lParam)
        Case WM_CONTEXTMENU    'Right-click the form titlebar to raise error..
            Debug.Print 1 / 0  'Raising an error shows that excel doesn't crash (doesn't shut down) !!
    End Select
End Sub

 

[Jaafar Tribak]

7- UserForm2 Module (second example):

Option Explicit

Private Type POINTAPI
    x As Long
    y As Long
End Type

#If VBA7 Then
    #If Win64 Then
        Private Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal Point As LongPtr) As LongPtr
    #Else
        Private Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As LongPtr
    #End If
    Private Declare PtrSafe Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hwnd As LongPtr) As Long
    Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare PtrSafe Function GetParent Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
    Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
#Else
    Private Enum LongPtr
        [_]
    End Enum
    Private Declare Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hwnd As LongPtr) As Long
    Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
    Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare Function GetParent Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
#End If

Private WithEvents oSubclass As CSubclasser


Private Sub UserForm_Initialize()
    Me.Caption = "Unmovable form"
    Set oSubclass = New CSubclasser
    oSubclass.SubclassWnd fHwnd, ObjPtr(Me)
End Sub

Private Property Get fHwnd() As LongPtr
    Call IUnknown_GetWindow(Me, VarPtr(fHwnd))
End Property

Private Sub MonitorMouse()
    Do While GetAsyncKeyState(VBA.vbKeyLButton)
        Label1 = ""
    Loop
End Sub
Private Function WndFromPoint() As LongPtr
    Dim tPt As POINTAPI
    Call GetCursorPos(tPt)
    #If Win64 Then
        Dim Ptr As LongLong
        Call CopyMemory(Ptr, tPt, LenB(tPt))
        WndFromPoint = WindowFromPoint(Ptr)
    #Else
        WndFromPoint = WindowFromPoint(tPt.x, tPt.y)
    #End If
End Function


' __________________________________________ EVENT HANDLER ____________________________________________

Private Sub oSubclass_MessageReceived( _
    hwnd As LongPtr, _
    uMsg As Long, _
    wParam As LongPtr, _
    lParam As LongPtr, _
    dwRefData As LongPtr, _
    bDiscardMessage As Boolean, _
    lReturnValue As LongPtr _
)
  
    Const WM_SYSCOMMAND = &H112, SC_MOVE = &HF012&, WM_NCLBUTTONUP = &HA2
    Const WM_SETCURSOR = &H20, WM_NCMOUSELEAVE = &H2A2, WM_NCRBUTTONDOWN = &HA4
  
    Select Case uMsg
        Case WM_SYSCOMMAND             'Move the form
            If wParam = SC_MOVE Then
                Label1 = "Sorry, this form is unmovable."
                bDiscardMessage = True 'abort message.
            End If
        Case WM_SETCURSOR
            If GetAsyncKeyState(VBA.vbKeyLButton) = 0& Then
                Label1 = ""
            End If
        Case WM_NCRBUTTONDOWN
            Label1 = "Sorry, this form is unmovable."
            bDiscardMessage = True
        Case WM_NCLBUTTONUP            'move the form
            Label1 = ""
         Case WM_NCMOUSELEAVE
            If GetParent(WndFromPoint) <> hwnd Then
               Label1 = "": Call MonitorMouse
            End If
    End Select
  
End Sub

END OF VBA PROJECT