0

So, my main goal is to be able to move / resize the main access window along with a popup form, that is, when the main form is moved/resized, i want the main window to follow. So, with the help of some online code and chatgpt i've narrowed it down to the following code (i have to use this approach since any other doesn't help - if i start with the main window hidden, the popup menus and the non popup forms don't show - obviously since the window is hidden)

  1. PUBLIC MODULE (mdl_MouseHook) Option Compare Database Option Explicit

     Public Type MSLLHOOKSTRUCT
         PT As POINTAPI
         MouseData As Long
         Flags As Long
         time As Long
         dwExtraInfo As LongPtr
     End Type
    
     Public Declare PtrSafe Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As LongPtr, ByVal hmod As LongPtr, ByVal dwThreadId As Long) As LongPtr
     Public Declare PtrSafe Function CallNextHookEx Lib "user32" (ByVal hhk As LongPtr, ByVal nCode As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
     Public Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" (ByVal hhk As LongPtr) As Long
     Public Declare PtrSafe Function GetForegroundWindow Lib "user32" () As LongPtr
     Public Declare PtrSafe Function GetWindowTextA Lib "user32" (ByVal hwnd As LongPtr, ByVal lpString As String, ByVal cch As Long) As Long
     Public Declare PtrSafe Function GetWindowTextLengthA Lib "user32" (ByVal hwnd As LongPtr) As Long
    
    
     Public Const WH_MOUSE_LL = 14
     Public Const HC_ACTION = 0
     Public Const WM_MOUSEMOVE = &H200
     Public Const WM_LBUTTONDOWN = &H201
     Public Const WM_RBUTTONDOWN = &H204
     Public Const WM_MOUSEWHEEL = &H20A
     Public Const WM_LBUTTONUP = &H202
     Public Const WM_RBUTTONUP = &H205
    
     Public cHook As clsMouseHook
     Public hHook As LongPtr
     Public lHook As Object
    
     Public isMouseDown As Boolean
     Public isMouseMoved As Boolean
    
     ' Put your own hook processing here:
     Public Function LowLevelMouseProc(ByVal nCode As Long, ByVal wParam As Long, lParam As MSLLHOOKSTRUCT) As LongPtr
     Const CPN = "mdl_MouseHook\LowLevelMouseProc"
    
     On Error GoTo Eroare
    
     Dim currentHwnd As LongPtr
    
     If (nCode = HC_ACTION) Then
         If cHook Is Nothing Then
             LowLevelMouseProc = CallNextHookEx(0, nCode, wParam, lParam)
    
         ElseIf cHook.HookedForms.Count = 0 Then
             LowLevelMouseProc = CallNextHookEx(0, nCode, wParam, lParam)
    
         Else
             currentHwnd = GetForegroundWindow
    
             Select Case wParam
                 Case WM_LBUTTONDOWN
                     isMouseDown = True
                     cHook.MouseDown currentHwnd, 1, lParam.PT.X, lParam.PT.Y
    
                 Case WM_LBUTTONUP
                     If isMouseDown And isMouseMoved Then
                         cHook.MouseUp currentHwnd, 1, lParam.PT.X, lParam.PT.Y, True
    
                     ElseIf isMouseDown And Not isMouseMoved Then
                         cHook.MouseUp currentHwnd, 1, lParam.PT.X, lParam.PT.Y, False
    
                     End If
    
                     isMouseDown = False
                     isMouseMoved = False
    
                 Case WM_RBUTTONDOWN
                     cHook.MouseDown currentHwnd, 2, lParam.PT.X, lParam.PT.Y
                 Case WM_RBUTTONUP
                     cHook.MouseUp currentHwnd, 2, lParam.PT.X, lParam.PT.Y, False
                 Case WM_MOUSEWHEEL
                     cHook.MouseWheel currentHwnd, 0, lParam.PT.X, lParam.PT.Y, lParam.MouseData
                 Case Else
                     If isMouseDown And Not isMouseMoved Then
                         isMouseMoved = True
                         cHook.MouseMove currentHwnd, 0, lParam.PT.X, lParam.PT.Y, True
    
                     ElseIf isMouseDown And isMouseMoved Then
                         cHook.MouseDrag currentHwnd, lParam.PT.X, lParam.PT.Y
    
                     Else
                         cHook.MouseMove currentHwnd, 0, lParam.PT.X, lParam.PT.Y, False
    
                     End If
             End Select
    
             LowLevelMouseProc = CallNextHookEx(0, nCode, wParam, lParam)
    
         End If
     End If
    
    
     Exit Function
    
     Eroare:
     UnhookWindowsHookEx hHook
     LowLevelMouseProc = CallNextHookEx(0, nCode, wParam, lParam)
     End Function
    
  2. The form subclass (clsIHook): Option Compare Database Option Explicit

         Private FRM As Access.Form
    
         Public Parent As clsMouseHook
         Private frmHwnd As LongPtr
    
         Public Property Get HookedForm() As Access.Form
         Set HookedForm = FRM
    
         End Property
    
         Public Property Set HookedForm(accForm As Access.Form)
         Set FRM = accForm
    
         frmHwnd = FRM.hwnd
    
         End Property
    
  3. The wrapper class (clsMouseHook): Option Compare Database Option Explicit

     Private colHooks As Collection
     Private hasLog As Boolean
     Private curHwnd As LongPtr
    
     Public hHook As LongPtr
    
     Private blnIshooked As Boolean
    
     Public Event FormMouseUp(hwnd As LongPtr, Button As Long, X As Long, Y As Long, WasDragged As Boolean)
     Public Event FormMouseDown(hwnd As LongPtr, Button As Long, X As Long, Y As Long)
     Public Event FormMouseMove(hwnd As LongPtr, Button As Long, X As Long, Y As Long, IsDragging As Boolean)
     Public Event FormMouseDrag(hwnd As LongPtr, X As Long, Y As Long)
    
     Private Sub Class_Initialize()
     Set colHooks = New Collection
     hasLog = Init_lHook
    
     End Sub
    
     Public Property Get HookedForms() As Collection
     Set HookedForms = colHooks
     End Property
    
     Public Property Get IsHooked() As Boolean
     IsHooked = blnIshooked
    
     End Property
    
     Public Sub RegisterForm(FRM As Access.Form)
     Dim iHook As New clsIHook
    
     Set iHook.HookedForm = FRM
    
     colHooks.Add iHook
    
     End Sub
    
     Public Sub UnregisterForm(FRM As Access.Form)
     Dim i As Integer
    
     For i = 1 To colHooks.Count
         If colHooks(i).Parent Is FRM Then
             colHooks.Remove i
             Exit For
         End If
     Next
    
     End Sub
    
     Public Sub Hook()
     Const CPN = "mdl_MouseHook\SetHook"
    
     On Error GoTo Eroare
    
     hHook = SetWindowsHookEx(WH_MOUSE_LL, AddressOf LowLevelMouseProc, 0, 0)
    
     If hHook = 0 Then
         Err.Raise 5, , "An error creating the hook"
     Else
         blnIshooked = True
    
     End If
    
     IESIRE:
     Exit Sub
    
     Eroare:
         If hasLog Then lHook.WriteLine Now() & " " & Err.Description, CPN, Erl
         Resume IESIRE
    
     End Sub
    
     Public Sub Unhook(Optional WithError As Boolean = False)
     Const CPN = "mdl_MouseHook\UnhookHandler"
    
     On Error GoTo Eroare
    
     UnhookWindowsHookEx hHook
     Set colHooks = Nothing
    
     lHook.WriteLine Now() & " Mouse hook removed " & hHook & IIf(WithError, " with error!", "")
    
     hHook = 0
    
     Exit Sub
    
     Eroare:
         lHook.WriteLine Now() & " " & Err.Description & " " & CPN
     End Sub
    
     Private Function Init_lHook() As Boolean
     Const CPN = "mdl_MouseHook\Init_lHook"
     ADD_TRACE CPN
    
     On Error GoTo Eroare
    
     If glFSO Is Nothing Then Set glFSO = CreateObject("Scripting.FilesystemObject")
     With glFSO
         If Not .FolderExists(CurrentProject.Path & "\LOGS") Then .CreateFolder CurrentProject.Path & "\LOGS"
    
         If Not .FileExists(CurrentProject.Path & "\LOGS\" & "MHK_log-" & Format(Date, "yyyy-mm-dd") & ".txt") Then
             Set lHook = .CreateTextFile(CurrentProject.Path & "\LOGS\" & "MHK_log-" & Format(Date, "yyyy-mm-dd") & ".txt", False, True)
    
         ElseIf lHook Is Nothing Then
     '        .Close 'CurrentProject.Path & "\LOGS\" & "log-" & Format(Date, "yyyy-mm-dd") & ".txt"
             Set lHook = .OpenTextFile(CurrentProject.Path & "\LOGS\" & "MHK_log-" & Format(Date, "yyyy-mm-dd") & ".txt", 8, False, -1)
    
         Else
             lHook.Close
             Set lHook = .OpenTextFile(CurrentProject.Path & "\LOGS\" & "MHK_log-" & Format(Date, "yyyy-mm-dd") & ".txt", 8, False, -1)
    
         End If
     End With
    
     Init_lHook = True
    
     IESIRE:
     REM_TRACE CPN
     Exit Function
    
     Eroare:
         MsgBox Err.Description, vbOKOnly + vbCritical, GET_TRACE
         Resume IESIRE
    
     End Function
    
     Private Function GetWindowTitle(hwnd As LongPtr) As String
         Dim length As Long
         Dim title As String
    
         length = GetWindowTextLengthA(hwnd) + 1
         title = Space$(length)
    
         Call GetWindowTextA(hwnd, title, length)
    
         GetWindowTitle = Left$(title, length - 1)
     End Function
    
     Public Sub MouseUp(hwnd As LongPtr, Button As Long, X As Long, Y As Long, WasDragged As Boolean)
     RaiseEvent FormMouseUp(hwnd, Button, X, Y, WasDragged)
    
     End Sub
    
     Public Sub MouseDown(hwnd As LongPtr, Button As Long, X As Long, Y As Long)
     RaiseEvent FormMouseDown(hwnd, Button, X, Y)
    
     End Sub
    
     Public Sub MouseMove(hwnd As LongPtr, Button As Long, X As Long, Y As Long, IsDragging As Boolean)
     RaiseEvent FormMouseMove(hwnd, Button, X, Y, IsDragging)
    
     End Sub
    
     Public Sub MouseDrag(hwnd As LongPtr, X As Long, Y As Long)
     RaiseEvent FormMouseDrag(hwnd, X, Y)
    
     End Sub
    
     Public Sub MouseWheel(hwnd As LongPtr, Button As Long, X As Long, Y As Long, MouseData As Long)
    
     End Sub
    
  4. Called like so in the deisred form: Private WithEvents frmHook As clsMouseHook Private TitleBarWasPressed As Boolean Private FormIsResized As Boolean

     Private Sub Form_Close()
     cHook.UnregisterForm Me
     cHook.Unhook
     Set cHook = Nothing
     Set frmHook = Nothing
    
     End Sub
    
     Private Sub Form_Load()
     Set cHook = New clsMouseHook
     Set frmHook = cHook
         cHook.RegisterForm Me
         cHook.Hook
     End Sub
    
    
     Private Sub frmHook_FormMouseDown(hwnd As LongPtr, Button As Long, X As Long, Y As Long)
     Dim rc As RECT
    
     GetWindowRect Me.hwnd, rc
    
     If hwnd = Me.hwnd Then
         If Y > rc.Y1 And Y < rc.Y1 + 30 Then
             Debug.Print "Title bar is pressed "
             TitleBarWasPressed = True
         ElseIf X > rc.X2 - 10 And X < rc.X2 Then
             Debug.Print "Left edge was pressed"
             FormIsResized = True
         Else
             Debug.Print "MOUSE: " & X & "," & Y & "; FORM: " & rc.X2 & "," & rc.Y2
         End If
    
     End If
    
     End Sub
    
     Private Sub frmHook_FormMouseDrag(hwnd As LongPtr, X As Long, Y As Long)
     If TitleBarWasPressed Then
         Debug.Print "Titlebar is dragging"
    
     ElseIf FormIsResized Then
         Debug.Print "Form width is resizing"
    
     End If
    
     End Sub
    
     Private Sub frmHook_FormMouseUp(hwnd As LongLong, Button As Long, X As Long, Y As Long, WasDragged As Boolean)
     If WasDragged Then
         If TitleBarWasPressed Then
             TitleBarWasPressed = False
             Debug.Print "Form was moved @" & X & "," & Y
    
         ElseIf FormIsResized Then
             FormIsResized = False
             Debug.Print "Form was resized @" & X & "," & Y
         End If
    
     End If
    
     End Sub
    

The problem with it is that sometimes it crashes randomly. Do you have any idea why and what i can do about it?

Thank you :)

  • Can you add breakpoints to see where it crashes ? Maybe create a log table to see what the values where at the moment of the crash, the current methode etc. Also you can add error handling in your code. Example : Private Sub cmdDeleteRecord_Click() On Error GoTo HandleError DoCmd.RunCommand acCmdDeleteRecord HandleExit: Exit Sub HandleError: MsgBox Err.Description Resume HandleExit End Sub Source : https://www.codevba.com/help/error_handling.htm – Mathias Z Jun 07 '23 at 11:15
  • Thanks for the ideas, but: breakpoint and hooks don't go together (not in vba, at least), i have a log exactly for that which logs the critical parts of the procedures, i have error control where it's needed (not everywhere), so the problem i'm thinking, is from the interaction with other windows hooks, but i just don't know how to get to those :( – Adelina Andreea trandafir Jun 07 '23 at 13:19
  • can you add the error handling to every procedure ? If you wan't you can send me the access file via we transfer and i can take a look on my pc. My email is on my profile. – Mathias Z Jun 07 '23 at 14:41
  • I will try to add error handler everywhere and keep you posted. I don't want to bother you with the code, but I'll try the suggestion – Adelina Andreea trandafir Jun 08 '23 at 08:24

0 Answers0