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)
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
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
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
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 :)