-
Notifications
You must be signed in to change notification settings - Fork 4
/
HooksMadeEasy.Journal.pas
361 lines (331 loc) · 11.5 KB
/
HooksMadeEasy.Journal.pas
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
{**********************************************************************************************
MIT License
Copyright (c) 2019 Fred Schetterer ([email protected])
Permission is hereby granted, free of charge, to any person obtaining a copy
of this software and associated documentation files (the "Software"), to deal
in the Software without restriction, including without limitation the rights
to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
copies of the Software, and to permit persons to whom the Software is
furnished to do so, subject to the following conditions:
The above copyright notice and this permission notice shall be included in all
copies or substantial portions of the Software.
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
SOFTWARE.
**********************************************************************************************}
/// <summary>
/// <para>
/// Allows Macros recording and playback
/// </para>
/// <para>
/// Written using only Win API and System methods
/// </para>
/// </summary>
/// <remarks>
/// For it to work as expected the App must have:
/// <list type="bullet">
/// <item>
/// Set the Manifest options "UAC Execution Level" to "requireAdministrator
/// </item>
/// <item>
/// Set "UAC Bypass UI Protection" to "Yes (/uiAccess='true')".
/// </item>
/// <item>
/// Application must be Signed
/// </item>
/// <item>
/// "UAC Bypass UI Protection" requires the App to be under %ProgramFiles%
/// </item>
/// </list>
/// In Berlin you need to use a custom manifest: "UAC.requireAdministrator.uiAccess.manifest"
/// </remarks>
/// <seealso href="https://edn.embarcadero.com/print/10323">
/// Working Demo
/// </seealso>
unit HooksMadeEasy.Journal;
interface
uses
Winapi.Windows, Winapi.Messages, Winapi.MMSystem,
System.SysUtils, System.Classes,
HooksMadeEasy.Common;
type
/// <summary>
/// Wrapper around Winapi.MMSystem.TimeGetTime
/// </summary>
/// <seealso href="https://www.thedelphigeek.com/2007/10/calculating-accurate.html">
/// Started with: Calculating accurate 'Now'
/// </seealso>
TTicks = record
{$REGION 'History'}
// 13-Oct-2019 - This is a class helper in Berlin but works as a record in XE2
// 18-Oct-2019 - Back to using TimeGetTime for accuracy
{$ENDREGION}
class constructor Create;
private
FTicks: Uint64;
class var FNowHigh32, FNowLastLow32 : Cardinal;
/// <summary>
/// Increments FNowHigh32 for each wrap around, 49.71 days uptime
/// </summary>
class function Now64: Uint64; static;
public
function ElapsedMS: Cardinal;
function RemainingMS(const ATimeOutMS: Cardinal): Cardinal;
procedure StartNew;
end;
/// <summary>
/// Works both with and without a DLL
/// </summary>
/// <remarks>
/// Traps WM_CANCELJOURNAL internally
/// </remarks>
TJournalHook = record
class constructor Create;
private
const cFileName = 'journal.dat';
class var
FHook, FMsgHook : HHook;
FEventMsg: TEventMsg;
FFile : TFileStream;
FFileName: string;
FDelayMS: Cardinal;
FTicks : TTicks;
FActive, FSysModalOn, FInstantPlayback: Boolean;
class procedure ClearVars; static;
class function GetMsgProc(iCode: integer; wParam: WPARAM; lParam: LPARAM): LRESULT; static; stdcall;
class function JournalPlaybackProc(iCode: integer; wParam: wParam; lParam: lParam): LRESULT; static; stdcall;
class function JournalRecordProc(iCode: integer; wParam: wParam; lParam: lParam): LRESULT; static; stdcall;
class function SetHooks(const AFileMode: Word; const AHookID: Integer; const AHookProc: TFNHookProc): Boolean; static; inline;
public
/// <summary>
/// Records
/// </summary>
/// <returns>
/// If False use GetLastError
/// </returns>
/// <remarks>
/// Traps CTRL+Break to stop Recording
/// </remarks>
class function Rec: Boolean; static;
/// <summary>
/// Playback
/// </summary>
/// <param name="InstantPlayback">
/// Sets Time delay to Zero for all events
/// </param>
/// <returns>
/// If False use GetLastError
/// </returns>
class function Play(const InstantPlayback: Boolean = False): Boolean; static;
/// <summary>
/// Stop either hook, CTRL+ESC or CTRL+ALT+DEL are trapped with a GetMsg hook
/// </summary>
/// <returns>
/// If False use GetLastError
/// </returns>
class function Stop: boolean; static;
/// <summary>
/// True if a Hook is Active
/// </summary>
class property Active: boolean read FActive;
/// <summary>
/// File which stores the Journal, defaults to 'journal.dat'
/// </summary>
class property FileName: string read FFileName write FFileName;
end;
implementation
class constructor TJournalHook.Create;
begin
ClearVars;
FFileName := cFileName;
FActive := False;
end;
class function TJournalHook.JournalPlaybackProc(iCode: integer; wParam: wParam; lParam: lParam): LRESULT;
var
lpEventMsg : PEventMsg absolute lParam;
LTicks: Cardinal;
begin
Result := 0;
case iCode of
HC_GETNEXT: begin
if FSysModalOn or not FActive then Exit;
/// <remarks>
/// If code is HC_GETNEXT and the return value is greater than zero, the system sleeps
/// for the number of milliseconds specified by the return value. When the system continues,
/// it calls the hook procedure again with code set to HC_GETNEXT to retrieve the same message.
/// The return value from this new call to JournalPlaybackProc should be zero;
/// otherwise, the system will go back to sleep for the number of milliseconds specified by the return value,
/// call JournalPlaybackProc again, and so on. The system will appear to be not responding.
/// </remarks>
/// <findings: 09-Oct-2019>
/// That doesn't work, but resetting the sleep time (FDelayMS) seems to work..
/// </findings>
LTicks := FTicks.RemainingMS(FDelayMS);
if (LTicks > 0) then Exit(LTicks);
lpEventMsg^ := FEventMsg; // Result Zero
end;
HC_SKIP: begin
if not FActive then Exit;
If (FFile.Position = FFile.Size) then begin
Stop;
Exit;
end;
LTicks := FEventMsg.time; // record Zeroed in ClearVars
FFile.Read(FEventMsg, SizeOf(FEventMsg));
// save Next Delay for calls to HC_GETNEXT, which can be more than one per message
if (FInstantPlayback or (LTicks = 0)) then FDelayMS := 0
else FDelayMS := (FEventMsg.time - LTicks); // wait time is diff between last and this msg
FTicks.StartNew; // Reset the Countdown Timer
end;
HC_SYSMODALON: begin
FSysModalOn := True;
CallNextHookEx(0, iCode, wParam, lParam); // Result Zero
end;
HC_SYSMODALOFF: begin
FSysModalOn := False;
CallNextHookEx(0, iCode, wParam, lParam); // Result Zero
end;
// Return chained call results if iCode is less than Zero
else if (iCode < 0) then Exit(CallNextHookEx(0, iCode, wParam, lParam));
end;
end;
class function TJournalHook.JournalRecordProc(iCode: integer; wParam: wParam; lParam: lParam): LRESULT;
{* IsCTRLBreak: Stops the Hook if True *}
function IsCTRLBreak(AMsg : PEventMsg): Boolean; inline;
begin
Result := (AMsg.message = WM_KEYDOWN) and (Lo(AMsg.ParamL) = VK_CANCEL);
Result := Result and (GetKeyState(VK_CONTROL) < 0);
if Result then Stop;
end;
var lpEventMsg : PEventMsg absolute lParam;
begin
Result := 0;
case iCode of
HC_ACTION: begin
if FSysModalOn or not FActive then Exit;
if IsCTRLBreak(lpEventMsg) then Exit;
FEventMsg := lpEventMsg^;
FFile.Write(FEventMsg, SizeOf(FEventMsg));
Exit;
end;
HC_SYSMODALON: begin
FSysModalOn := True;
CallNextHookEx(0, iCode, wParam, lParam); // Result Zero
end;
HC_SYSMODALOFF: begin
FSysModalOn := False;
CallNextHookEx(0, iCode, wParam, lParam); // Result Zero
end;
// Return chained call results if iCode is less than Zero
else if (iCode < 0) then Exit(CallNextHookEx(0, iCode, wParam, lParam));
end;
end;
class function TJournalHook.GetMsgProc(iCode: integer; wParam: WPARAM; lParam: LPARAM): LRESULT;
var lpMsg : PMsg absolute lParam;
begin
Result := 0;
// Return chained call results if Code is less than Zero
if (iCode < 0) then Exit(CallNextHookEx(0, iCode, wParam, lParam))
// Else allow processing by Hook chain
else CallNextHookEx(0, iCode, wParam, lParam);
if not FActive or (iCode <> HC_ACTION) then Exit;
if (lpMsg.Message = WM_CANCELJOURNAL) then Stop;
end;
class function TJournalHook.SetHooks(const AFileMode: Word; const AHookID: Integer; const AHookProc: TFNHookProc): Boolean;
{$REGION 'History'}
// 18-Oct-2019 - Added storing of Error to allow proper display in calling App
{$ENDREGION}
var Err : Cardinal;
begin
if FActive then Exit(False);
FActive := True;
ClearVars;
FMsgHook := SetWindowsHookExA(WH_GETMESSAGE, GetMsgProc, hInstance, GetCurrentThreadId);
Result := FMsgHook <> 0;
if not Result then begin
FActive := False;
Exit;
end;
/// <findings: 09-Oct-2019>
/// Changing to SetWindowsHookExA solved some weirdness
/// </findings>
FFile := TFileStream.Create(FFileName, AFileMode);
try
FHook := SetWindowsHookExA(AHookID, AHookProc, hInstance, 0);
Result := FHook <> 0;
finally
if not Result then begin
Err := GetLastError;
FActive := False;
UnhookWindowsHookEx(FMsgHook);
FreeAndNil(FFile);
SetLastError(Err);
end;
end;
end;
class function TJournalHook.Play(const InstantPlayback: Boolean = False): Boolean;
begin
FInstantPlayback := InstantPlayback;
Result := SetHooks(fmOpenRead, WH_JOURNALPLAYBACK, JournalPlaybackProc);
end;
class function TJournalHook.Rec: Boolean;
begin
Result := SetHooks(fmCreate, WH_JOURNALRECORD, JournalRecordProc);
end;
class function TJournalHook.Stop: boolean;
begin
if not FActive then Exit(False);
FActive := False;
Result := UnhookWindowsHookEx(FMsgHook) and UnhookWindowsHookEx(FHook);
FreeAndNil(FFile);
end;
class procedure TJournalHook.ClearVars;
begin
FHook := 0;
FMsgHook := 0;
FSysModalOn := False;
FDelayMS := 0;
FillChar(FEventMsg, SizeOf(FEventMsg), 0);
end;
{ TTicks }
class constructor TTicks.Create;
begin
inherited;
FNowHigh32 := 0;
FNowLastLow32 := 0;
end;
class function TTicks.Now64: Uint64;
var Rsl : Int64Rec absolute Result;
begin
Rsl.Lo := TimeGetTime;
if Rsl.Lo < FNowLastLow32 then Inc(FNowHigh32);
FNowLastLow32 := Rsl.Lo;
Rsl.Hi := FNowHigh32;
end;
function TTicks.ElapsedMS: Cardinal;
var LTicks, LValue: Uint64;
begin
LTicks := TTicks.Now64;
LValue := LTicks - FTicks;
if (LValue < 0) then Result := 0
else if (LValue > MAXDWORD) then Result := MAXDWORD
else Result := LValue;
end;
function TTicks.RemainingMS(const ATimeOutMS: Cardinal): Cardinal;
var LValue: Cardinal;
begin
if (ATimeOutMS = INFINITE) then Exit(INFINITE);
if (ATimeOutMS = 0) then Exit(0); // Can be Zero if testing a Wait State
LValue := ElapsedMS;
if (ATimeOutMS <= LValue) then Exit(0)
else Result := ATimeOutMS - LValue;
end;
procedure TTicks.StartNew;
begin
FTicks := TTicks.Now64;
end;
end.