unit uReplaceShortCutToText;
interface
uses
Classes, Windows, Messages, Menus, SysUtils;
procedure EnableReplaceShortCutToText(Value: Boolean);
type
TMyShortCutToTextEvent =
procedure(ShortCut: TShortCut;
var Result:
string)
of object;
var
OnShortCutToText : TMyShortCutToTextEvent;
implementation
type
POverwrittenData = ^TOverwrittenData;
TOverwrittenData =
record
Location: Pointer;
OldCode:
array[0..6]
of Byte;
end;
var
OldShortCutToText: TOverwrittenData;
procedure RestoreProcedure(OriginalProc: Pointer; Data: TOverwrittenData);
var
ov, ov2: Cardinal;
begin
if Data.Location <>
nil then begin
if not VirtualProtect(Data.Location, 6, PAGE_EXECUTE_READWRITE, @ov)
then
RaiseLastOSError;
Move(Data.OldCode, Data.Location^, 6);
if not VirtualProtect(Data.Location, 6, ov, @ov2)
then
RaiseLastOSError;
end;
end;
procedure OverwriteProcedure(OldProcedure, NewProcedure: Pointer; Data: POverwrittenData =
nil);
{ OverwriteProcedure originally from Igor Siticov }
{ Modified by Jacques Garcia Vazquez }
var
x: PAnsiChar;
y: integer;
ov2, ov: cardinal;
p: pointer;
begin
if OldProcedure =
nil then
begin
Data.Location :=
nil;
Exit;
end;
if Assigned(Data)
then
if (Data.Location <>
nil)
then
Exit;
{ procedure already overwritten }
// need six bytes in place of 5
x := PAnsiChar(OldProcedure);
if not VirtualProtect(Pointer(x), 6, PAGE_EXECUTE_READWRITE, @ov)
then
RaiseLastOSError;
// if a jump is present then a redirect is found
// $FF25 = jmp dword ptr [xxx]
// This redirect is normally present in bpl files, but not in exe files
p := OldProcedure;
if Word(p^) = $25FF
then
begin
Inc(Integer(p), 2);
// skip the jump
// get the jump address p^ and dereference it p^^
p := Pointer(Pointer(p^)^);
// release the memory
if not VirtualProtect(Pointer(x), 6, ov, @ov2)
then
RaiseLastOSError;
// re protect the correct one
x := PAnsiChar(p);
if not VirtualProtect(Pointer(x), 6, PAGE_EXECUTE_READWRITE, @ov)
then
RaiseLastOSError;
end;
if Assigned(Data)
then
begin
Move(x^, Data.OldCode, 6);
{ Assign Location last so that Location <> nil only if OldCode is properly initialized. }
Data.Location := x;
end;
x[0] := AnsiChar($E9);
y := integer(NewProcedure) - integer(p) - 5;
x[1] := AnsiChar(y
and 255);
x[2] := AnsiChar((y
shr 8)
and 255);
x[3] := AnsiChar((y
shr 16)
and 255);
x[4] := AnsiChar((y
shr 24)
and 255);
if not VirtualProtect(Pointer(x), 6, ov, @ov2)
then
RaiseLastOSError;
end;
function NewShortCutToText(ShortCut: TShortCut):
string;
var
Name:
string;
begin
if Assigned(OnShortCutToText)
then
OnShortCutToText(ShortCut, Result)
end;
procedure EnableReplaceShortCutToText(Value: Boolean);
begin
if Value
then
OverWriteProcedure(@ShortCutToText, @NewShortCutToText, @OldShortCutToText)
else
RestoreProcedure(@ShortCutToText, OldShortCutToText);
end;
{initialization
OverWriteProcedure(@ShortCutToText, @NewShortCutToText, @OldShortCutToText);
finalization
RestoreProcedure(@ShortCutToText, OldShortCutToText); }
end.