Option Explicit
Public Event MouseMove _
(ByVal Target As Object, ByVal X As Single, ByVal Y As Single)
Private Type POINTAPI
X As Long
Y As Long
End Type
Private Type MSG
hwnd As Long
message As Long
wParam As Long
lParam As Long
time As Long
pt As POINTAPI
End Type
Private Declare Function FindWindow Lib "user32.dll" _
Alias "FindWindowA" _
(ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Private Declare Function FindWindowEx Lib "user32.dll" _
Alias "FindWindowExA" _
(ByVal hWnd1 As Long, _
ByVal hWnd2 As Long, _
ByVal lpsz1 As String, _
ByVal lpsz2 As String) As Long
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 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
Private Declare Function GetCursorPos Lib "user32.dll" _
(ByRef lpPoint As POINTAPI) As Long
Private Declare Function GetMessage Lib "user32.dll" _
Alias "GetMessageA" _
(ByRef lpMsg As MSG, _
ByVal hwnd As Long, _
ByVal wMsgFilterMin As Long, _
ByVal wMsgFilterMax As Long) As Long
Private Declare Function TranslateMessage Lib "user32.dll" _
(ByRef lpMsg As MSG) As Long
Private Declare Function PostMessage Lib "user32.dll" _
Alias "PostMessageA" _
(ByVal hwnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long
'========================================
'System Constantes.
Private Const GWL_WNDPROC As Long = -4
Private Const WM_SETCURSOR As Long = &H20
Private Const WM_MOUSEMOVE As Long = &H200
'=====================================
'Module variables.
Private hXLDesk As Long
Private lPrevWnd As Long
Private bXitLoop As Boolean
'==============================
Public Sub InstallHook()
If lPrevWnd = 0 Then
'subclass the xldesk window.
hXLDesk = FindWindowEx(FindWindow("XLMAIN", Application.Caption) _
, 0, "XLDESK", vbNullString)
lPrevWnd = SetWindowLong _
(hXLDesk, GWL_WNDPROC, AddressOf TransitionalProc)
' Msg pump for safe subclassing !!!!
Call MessageLoop
End If
End Sub
Public Sub ClearHook()
'cleanUp.
bXitLoop = True
SetWindowLong hXLDesk, GWL_WNDPROC, lPrevWnd
lPrevWnd = 0
hXLDesk = 0
End Sub
Public Function CallBackProc _
(ByVal hwnd As Long, ByVal MSG As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long
Dim loword As Long, hiword As Long
Dim tPt As POINTAPI
On Error Resume Next
'intercept the WM_SETCURSOR msg.
Select Case MSG
Case WM_SETCURSOR
'check the lparam hiword for mouse moves.
GetHiLoword lParam, loword, hiword
If hiword = WM_MOUSEMOVE Then
GetCursorPos tPt
RaiseEvent MouseMove _
(Application.ActiveWindow.RangeFromPoint _
(tPt.X, tPt.Y) _
, tPt.X, tPt.Y)
End If
End Select
'process other msgs.
CallBackProc = CallWindowProc _
(lPrevWnd, hwnd, MSG, wParam, ByVal lParam)
End Function
Private Sub MessageLoop()
Dim aMsg As MSG
bXitLoop = False
On Error Resume Next
'ensure all Msgs are posted during the subclassing.
Do While GetMessage(aMsg, 0, 0, 0) And bXitLoop = False
DoEvents
PostMessage 0, aMsg.message, aMsg.wParam, aMsg.lParam
Loop
End Sub
Private Sub GetHiLoword _
(lParam As Long, ByRef loword As Long, ByRef hiword As Long)
' this is the LOWORD of the lParam:
loword = lParam And &HFFFF&
' LOWORD now equals 65,535 or &HFFFF
' this is the HIWORD of the lParam:
hiword = lParam \ &H10000 And &HFFFF&
' HIWORD now equals 30,583 or &H7777
End Sub
