Option Explicit
Declare 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
Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Dim lpPrevWndProc As Long
Public Const WM_KEYDOWN = &H100
Public Const WM_MBUTTONDOWN = &H207
Public Const WM_LBUTTONUP = &H202
Public Const WM_RBUTTONDOWN = &H204
Public Const WM_MOUSEMOVE = &H200
Public Const GWL_WNDPROC = -4
Private Type POINTAPI
x As Long
y As Long
End Type
Dim frm As Form
Public Function Hook(ByVal f As Form)
Set frm = f
'This function hooks the window that you would like to subclass
lpPrevWndProc = SetWindowLong(f.hwnd, GWL_WNDPROC, AddressOf WindowProc)
End Function
Public Sub UnHook(ByVal hwnd As Long)
'This unhooks the window. We must do this or else
'an error is thrown when the program unloads.
Call SetWindowLong(hwnd, GWL_WNDPROC, lpPrevWndProc)
End Sub
'This is the function that receives all messages sent to our form.
Function WindowProc(ByVal hw As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Select Case uMsg
Case WM_KEYDOWN
Unload frm
'Detect if the "enter" button on a mouse was clicked
Case WM_MBUTTONDOWN
Unload frm
'Detects the leftmouse click
Case WM_LBUTTONUP
Unload frm
'Detects the rightmouse click
Case WM_RBUTTONDOWN
Unload frm
Case WM_MOUSEMOVE
CheckCursor
End Select
'let the msg get through to the form
WindowProc = CallWindowProc(lpPrevWndProc, hw, uMsg, wParam, lParam)
End Function
Private Sub CheckCursor()
Static xx As Integer
Static yy As Integer
Dim Point As POINTAPI
GetCursorPos Point
If xx = 0 And yy = 0 Then
xx = Point.x
yy = Point.y
Else
If Abs(xx - Point.x) > 5 Or Abs(yy - Point.y) > 5 Then
Unload frm
Else
xx = Point.x
yy = Point.y
End If
End If
End Sub