Option Explicit
Public Event MouseMove(ByVal Target As Range)
Private Type POINTAPI
x As Long
y As Long
End Type
Private Declare Function GetProp Lib "user32" _
Alias "GetPropA" _
(ByVal hwnd As Long, _
ByVal lpString As String) As Long
Private Declare Function SetProp Lib "user32" _
Alias "SetPropA" _
(ByVal hwnd As Long, _
ByVal lpString As String, _
ByVal hData As Long) As Long
Private Declare Function RemoveProp Lib "user32" _
Alias "RemovePropA" _
(ByVal hwnd As Long, _
ByVal lpString As String) As Long
Private Declare Function GetDesktopWindow Lib _
"user32.dll" () As Long
Private Declare Function GetCursorPos Lib "user32.dll" _
(ByRef lpPoint As POINTAPI) As Long
Private Declare Function OpenProcess Lib "Kernel32.dll" _
(ByVal dwDesiredAccessas As Long, _
ByVal bInheritHandle As Long, _
ByVal dwProcId As Long) As Long
Private Declare Function TerminateProcess Lib "kernel32" _
(ByVal hProcess As Long, _
ByVal uExitCode As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" _
(ByVal hObject As Long) As Long
Private Const PROCESS_TERMINATE As Long = &H1
Private Const MOUSE_WATCHER_VBS As String _
= "C:\MouseWatcher.vbs"
Private Sub Workbook_Open()
Call StartMouseWatcher(Sheets(1))
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Call StopMouseWatcher
End Sub
Private Sub StartMouseWatcher(ByVal Sh As Worksheet)
Dim tPt As POINTAPI
Dim oTargetRange As Range
'don't run the VBSript more than once.
If GetProp(GetDesktopWindow, "lProcID") = 0 Then
Call SetUpVBSFile
End If
'hook the target sheet.
CallByName Sh, "Worksheet", VbSet, ThisWorkbook
'get the current cursor pos.
GetCursorPos tPt
'store the range under the mouse pointer.
On Error Resume Next
Set oTargetRange = ActiveWindow.RangeFromPoint(tPt.x, tPt.y)
On Error GoTo 0
'ignore non range objects and other sheets.
If TypeName(oTargetRange) <> "Range" Or _
Not ActiveSheet Is Sh Then Exit Sub
'pass the range to the MouseMove event.
RaiseEvent MouseMove(ByVal oTargetRange)
End Sub
Private Sub StopMouseWatcher()
Dim hProcHandle As Long
Dim oTragetRange As Range
'kill the VBScript exe.
hProcHandle = OpenProcess(PROCESS_TERMINATE, 0, _
GetProp(GetDesktopWindow, "lProcID"))
TerminateProcess hProcHandle, 1
CloseHandle hProcHandle
'cleanup.
RemoveProp GetDesktopWindow, "lProcID"
'delete the temp vbs file.
On Error Resume Next
Kill MOUSE_WATCHER_VBS
On Error GoTo 0
End Sub
Private Sub SetUpVBSFile()
Dim lProcID As Long
'create a background vbs file on the fly.
Open MOUSE_WATCHER_VBS For Output As #1
Print #1, "On Error Resume Next"
Print #1, "set wb=Getobject(" & Chr(34) & Me.FullName & Chr(34) & ")"
Print #1, "Do"
Print #1, "wb.Watch"
Print #1, "Loop"
Print #1, "Set wb=Nothing"
Close #1
Do
DoEvents
Loop Until Len(Dir(MOUSE_WATCHER_VBS)) <> 0
'execute the background vbs file.
lProcID = Shell("WScript.exe " & MOUSE_WATCHER_VBS)
'store the exe PID in a window to persist
'even when the project is reset.
'will be needed to terminate the process later.
SetProp GetDesktopWindow, "lProcID", lProcID
End Sub
'Only Public Method accessed by the VBScript.
'============================================
Public Sub Watch()
Call StartMouseWatcher(ByVal Sheets(1))
End Sub
For a funny example:
