Jaafar Tribak
Well-known Member
- Joined
- Dec 5, 2002
- Messages
- 9,604
- Office Version
- 2016
- Platform
- Windows
Hi all,
This is for having some fun with XL but I guess it can also be taken advantage of and be very useful in some scenarios.It was a nightmare putting the code together.(i had endless crashes)
As the title implies, this is similar to the Macro recorder but obviously not as effective as all it does is record the mouse & keyboard input.
Another bonus is that the recorded actions can be saved to disk and be retrieved later after closing excel. In fact it works system wide not just within XL.
Anyway, have some fun and tell me what you think.
workbook example:
http://www.savefile.com/files/2039238
Code in a Standard Module :
Please be careful when testing/editing the code as it has a potential for crashing XL.
Regards.
This is for having some fun with XL but I guess it can also be taken advantage of and be very useful in some scenarios.It was a nightmare putting the code together.(i had endless crashes)
As the title implies, this is similar to the Macro recorder but obviously not as effective as all it does is record the mouse & keyboard input.
Another bonus is that the recorded actions can be saved to disk and be retrieved later after closing excel. In fact it works system wide not just within XL.
Anyway, have some fun and tell me what you think.
workbook example:
http://www.savefile.com/files/2039238
Code in a Standard Module :
Code:
Option Base 0
Option Explicit
Private Type EVENTMSG
message As Long
paramL As Long
paramH As Long
time As Long
hwnd As Long
End Type
Private Type Msg
uCode As Long
message As Long
paramL As Long
paramH As Long
time As Long
hwnd As Long
End Type
Private Declare Function GetWindowLong Lib _
"user32" Alias "GetWindowLongA" _
(ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowsHookEx Lib _
"user32" Alias "SetWindowsHookExA" _
(ByVal idHook As Long, ByVal lpfn As Long, _
ByVal hmod As Long, ByVal dwThreadId As Long) As Long
Private Declare Function UnhookWindowsHookEx Lib "user32" _
(ByVal hHook As Long) As Long
Private Declare Function CallNextHookEx Lib "user32" _
(ByVal hHook As Long, ByVal ncode As Long, _
ByVal wParam As Long, lParam As Any) As Long
Private Declare Function GetTickCount Lib "kernel32" () As Long
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Const WH_JOURNALPLAYBACK = 1
Private Const WH_JOURNALRECORD = 0
Private Const HC_ACTION = 0
Private Const HC_GETNEXT = 1
Private Const HC_SKIP = 2
Private Const HC_NOREMOVE = 3
Private Const HC_NOREM = HC_NOREMOVE
Private Const HC_SYSMODALOFF = 5
Private Const HC_SYSMODALON = 4
Private Const VK_CANCEL = &H3
Private Const WM_KEYDOWN = &H100
Private Const WM_MOUSEMOVE = &H200
Private Const GWL_HINSTANCE = (-6)
Private Const LogPath As String = "C:\Test\"
Private Const LogFile As String = "LogFile.DAT"
Private hRecordHook As Long
Private hPlaybackHook As Long
Private MsgArray() As Long
Private StartTime As Long
Private CurrMSG As Long
Private bSlowSpeed As Boolean
Private bIsHooked As Boolean
Private IsPBHooked As Boolean
Private bDone As Boolean
Private Sub SetJournalHook()
If bIsHooked Then
MsgBox "The recorder is already activated.", vbInformation
Else
StartTime = GetTickCount
hRecordHook = SetWindowsHookEx _
(WH_JOURNALRECORD, AddressOf JournalProc, GetAppInstance, 0)
bIsHooked = True
End If
End Sub
Private Sub RemoveJournalHook()
Dim lRetVal As Long
lRetVal = UnhookWindowsHookEx(hRecordHook)
bIsHooked = False
MsgBox "Key & Mouse recorder stopped.", vbInformation
End Sub
Private Function JournalProc _
(ByVal uCode As Long, ByVal wParam As Long, lParam As EVENTMSG) As Long
If uCode = HC_ACTION Then
If lParam.message = WM_KEYDOWN And _
GetLowByte(lParam.paramL) = VK_CANCEL Then
Call RemoveJournalHook
End If
MsgArray(0, UBound(MsgArray, 2)) = uCode
MsgArray(1, UBound(MsgArray, 2)) = lParam.message
MsgArray(2, UBound(MsgArray, 2)) = lParam.hwnd
MsgArray(3, UBound(MsgArray, 2)) = lParam.paramH
MsgArray(4, UBound(MsgArray, 2)) = lParam.paramL
MsgArray(5, UBound(MsgArray, 2)) = (lParam.time - StartTime)
ReDim Preserve MsgArray(6, (UBound(MsgArray, 2) + 1)) As Long
ElseIf uCode = HC_SYSMODALON Then
ElseIf uCode = HC_SYSMODALOFF Then
End If
JournalProc = CallNextHookEx(hRecordHook, uCode, wParam, lParam)
End Function
Private Sub SetPlaybackHook()
If Sheets(1).Shapes("Opt1").ControlFormat.Value = 1 Then
bSlowSpeed = True
Else
bSlowSpeed = False
End If
If IsPBHooked Then
MsgBox "Playback is already active", vbInformation
Else
StartTime = GetTickCount
CurrMSG = 1
hPlaybackHook = SetWindowsHookEx(WH_JOURNALPLAYBACK, _
AddressOf JournalPlaybackProc, GetAppInstance, 0)
IsPBHooked = True
Application.StatusBar = "Playing Back..."
End If
End Sub
Private Sub RemovePlaybackHook()
Dim lRetVal As Long
lRetVal = UnhookWindowsHookEx(hPlaybackHook)
IsPBHooked = False
Application.StatusBar = False
MsgBox "Key & Mouse PlayBack finished.", vbInformation
End Sub
Public Function JournalPlaybackProc _
(ByVal uCode As Long, ByVal wParam As Long, lParam As EVENTMSG) As Long
If uCode = HC_GETNEXT Then
If bSlowSpeed Then Sleep 1
If CurrMSG >= UBound(MsgArray, 2) Then
bDone = True
Call RemovePlaybackHook
Else
lParam.message = MsgArray(1, CurrMSG)
lParam.hwnd = MsgArray(2, CurrMSG)
lParam.paramH = MsgArray(3, CurrMSG)
lParam.paramL = MsgArray(4, CurrMSG)
lParam.time = MsgArray(5, CurrMSG) - MsgArray(5, CurrMSG - 1)
JournalPlaybackProc = MsgArray(5, CurrMSG) - MsgArray(5, CurrMSG - 1)
End If
ElseIf uCode = HC_SKIP Then
If CurrMSG >= UBound(MsgArray, 2) Then
Call RemovePlaybackHook
bDone = True
End If
CurrMSG = CurrMSG + 1
ElseIf uCode = HC_NOREMOVE Then
ElseIf uCode = HC_SYSMODALON Then
ElseIf uCode = HC_SYSMODALOFF Then
End If
JournalPlaybackProc = CallNextHookEx(hPlaybackHook, uCode, wParam, lParam)
End Function
Private Sub StartRecording()
ReDim MsgArray(6, 1) As Long
Call SetJournalHook
Application.StatusBar = "Recording..."
End Sub
Private Sub StopRecording()
Call RemoveJournalHook
Application.StatusBar = False
End Sub
Private Sub SaveTheEvents()
On Error Resume Next
Kill LogFile
RmDir LogPath
MkDir LogPath
On Error GoTo 0
Call SaveEvents(LogPath & LogFile, MsgArray)
End Sub
Private Sub SaveEvents _
(ByVal sFilename As String, ByRef MsgArray() As Long)
Dim iFile As Integer
Dim lIndex As Long
Dim i As Long
Dim tTemp() As Msg
iFile = FreeFile
ReDim tTemp(UBound(MsgArray, 2))
Open sFilename For Random Access Write As iFile
For lIndex = LBound(MsgArray, 2) To UBound(MsgArray, 2)
tTemp(lIndex).uCode = MsgArray(0, lIndex)
tTemp(lIndex).message = MsgArray(1, lIndex)
tTemp(lIndex).hwnd = MsgArray(2, lIndex)
tTemp(lIndex).paramH = MsgArray(3, lIndex)
tTemp(lIndex).paramL = MsgArray(4, lIndex)
tTemp(lIndex).time = MsgArray(5, lIndex)
Put #iFile, , tTemp(lIndex)
Next
Close iFile
End Sub
Private Sub LoadTheEvents()
Call LoadEvents(LogPath & LogFile)
bDone = False
Call SetPlaybackHook
While Not bDone
DoEvents
Wend
End Sub
Private Sub LoadEvents(ByVal sFilename As String)
Dim iFile As Integer
Dim lIndex As Long
Dim tTemp() As Msg
If Len(Dir(sFilename)) = 0 Then Exit Sub
iFile = FreeFile
Open sFilename For Random Access Read As iFile
ReDim MsgArray(6, 1) As Long
While Not EOF(iFile)
ReDim Preserve tTemp(lIndex)
Get #iFile, , tTemp(lIndex)
MsgArray(0, lIndex) = tTemp(lIndex).uCode
MsgArray(1, lIndex) = tTemp(lIndex).message
MsgArray(2, lIndex) = tTemp(lIndex).hwnd
MsgArray(3, lIndex) = tTemp(lIndex).paramH
MsgArray(4, lIndex) = tTemp(lIndex).paramL
MsgArray(5, lIndex) = tTemp(lIndex).time
ReDim Preserve MsgArray(6, (UBound(MsgArray, 2) + 1)) As Long
lIndex = lIndex + 1
Wend
Close iFile
End Sub
Private Function GetLowByte(ByRef lValue As Long) As Long
GetLowByte = (lValue And &HFF&)
End Function
Private Function GetAppInstance() As Long
GetAppInstance = GetWindowLong(Application.hwnd, GWL_HINSTANCE)
End Function
Public Sub SafeExit()
If bIsHooked Or IsPBHooked Then
Call RemoveJournalHook
Call RemovePlaybackHook
End If
End SubPlease be careful when testing/editing the code as it has a potential for crashing XL.
Regards.
Last edited:
