[susu8988]

{ Important note about DLL memory management: ShareMem must be the
first unit in your library's USES clause AND your project's (select
Project-View Source) USES clause if your DLL exports any procedures or
functions that pass strings as parameters or function results. This
applies to all strings passed to and from your DLL--even those that
are nested in records and classes. ShareMem is the interface unit to
the BORLNDMM.DLL shared memory manager, which must be deployed along
with your DLL. To avoid using BORLNDMM.DLL, pass string information
using PChar or ShortString parameters. }

uses
SysUtils,
Windows,
Classes,
HookAPI in 'HookAPI.pas',
Main in 'Main.pas';

var
Hook:HHOOK;

function GetMsgProc(nCode:Integer;wParam:wParam;lParam:lParam):LRESULT;stdcall;
begin
Result := 0;
end;

procedure SetHook;
begin
Hook := SetWindowsHookEx(WH_GETMESSAGE,GetMsgProc,hInstance,0);
end;

procedure RemoveHook;
begin
UnHookWindowsHookEx(Hook);
end;

{$R *.RES}

exports
SetHook, RemoveHook;

begin
API_Hookup;
end.






unit Main;

interface
uses
SysUtils,
Windows,
ShellAPI,
Dialogs,
Classes;

procedure API_Hookup; stdcall;
procedure API_HookDown; stdcall;

type
TCreateProcess = function(lpApplicationName: PChar; lpCommandLine: PChar;
lpProcessAttributes, lpThreadAttributes: PSecurityAttributes;
bInheritHandles: BOOL; dwCreationFlags: DWORD; lpEnvironment: Pointer;
lpCurrentDirectory: PChar; const lpStartupInfo: TStartupInfo;
var lpProcessInformation: TProcessInformation): BOOL; stdcall;
TCreateProcessA = function(lpApplicationName: PAnsiChar; lpCommandLine: PAnsiChar;
lpProcessAttributes, lpThreadAttributes: PSecurityAttributes;
bInheritHandles: BOOL; dwCreationFlags: DWORD; lpEnvironment: Pointer;
lpCurrentDirectory: PAnsiChar; const lpStartupInfo: TStartupInfo;
var lpProcessInformation: TProcessInformation): BOOL; stdcall;
TCreateProcessW = function(lpApplicationName: PWideChar; lpCommandLine: PWideChar;
lpProcessAttributes, lpThreadAttributes: PSecurityAttributes;
bInheritHandles: BOOL; dwCreationFlags: DWORD; lpEnvironment: Pointer;
lpCurrentDirectory: PWideChar; const lpStartupInfo: TStartupInfo;
var lpProcessInformation: TProcessInformation): BOOL; stdcall;

var
OldCreateProcess: TCreateProcess;
OldCreateProcessA: TCreateProcessA;
OldCreateProcessW: TCreateProcessW;

implementation

uses HookAPI;

function MyCreateProcess(lpApplicationName: PChar; lpCommandLine: PChar;
lpProcessAttributes, lpThreadAttributes: PSecurityAttributes;
bInheritHandles: BOOL; dwCreationFlags: DWORD; lpEnvironment: Pointer;
lpCurrentDirectory: PChar; const lpStartupInfo: TStartupInfo;
var lpProcessInformation: TProcessInformation): BOOL; stdcall;
begin
ShowMessage('MyCreateProcess');
end;

function MyCreateProcessA(lpApplicationName: PAnsiChar; lpCommandLine: PAnsiChar;
lpProcessAttributes, lpThreadAttributes: PSecurityAttributes;
bInheritHandles: BOOL; dwCreationFlags: DWORD; lpEnvironment: Pointer;
lpCurrentDirectory: PAnsiChar; const lpStartupInfo: TStartupInfo;
var lpProcessInformation: TProcessInformation): BOOL; stdcall;
begin
ShowMessage('MyCreateProcessA');
end;

function MyCreateProcessW(lpApplicationName: PWideChar; lpCommandLine: PWideChar;
lpProcessAttributes, lpThreadAttributes: PSecurityAttributes;
bInheritHandles: BOOL; dwCreationFlags: DWORD; lpEnvironment: Pointer;
lpCurrentDirectory: PWideChar; const lpStartupInfo: TStartupInfo;
var lpProcessInformation: TProcessInformation): BOOL; stdcall;
begin
ShowMessage('MyCreateProcessW');
end;

procedure API_Hookup; stdcall;
begin
if @OldCreateProcess = nil then
@OldCreateProcess := LocateFunctionAddress(@CreateProcess);
if @OldCreateProcessA = nil then
@OldCreateProcessA := LocateFunctionAddress(@CreateProcessA);
if @OldCreateProcessW = nil then
@OldCreateProcessW := LocateFunctionAddress(@CreateProcessW);

RepointFunction(@OldCreateProcess, @MyCreateProcess);
RepointFunction(@OldCreateProcessA, @MyCreateProcessA);
RepointFunction(@OldCreateProcessW, @MyCreateProcessW);

end;

procedure API_HookDown; stdcall;
begin
if @OldCreateProcess <> nil then
RepointFunction(@MyCreateProcess, @OldCreateProcess);
if @OldCreateProcess <> nil then
RepointFunction(@MyCreateProcessA, @OldCreateProcessA);
if @OldCreateProcess <> nil then
RepointFunction(@MyCreateProcessW, @OldCreateProcessW);
end;

initialization

finalization
API_HookDown;

end.







unit HookAPI;

interface

uses
Windows, Classes;
function LocateFunctionAddress(Code: Pointer): Pointer;
function RepointFunction(OldFunc, NewFunc: Pointer): Integer;

type //ｶｨﾒ袵ｻｸ ・ﾚｽ盪ｹ
PImage_Import_Entry = ^Image_Import_Entry;
Image_Import_Entry = record
Characteristics: DWORD;
TimeDateStamp: DWORD;
MajorVersion: Word;
MinorVersion: Word;
Name: DWORD;
LookupTable: DWORD;
end;

type
TImportCode = packed record
JumpInstruction: Word;
AddressOfPointerToFunction: ^Pointer;
end;
PImportCode = ^TImportCode;
implementation

function LocateFunctionAddress(Code: Pointer): Pointer;
var
func: PImportCode;
begin
Result := Code;
if Code = nil then exit;
try
func := code;
if (func.JumpInstruction = $25FF) then
begin
Result := func.AddressOfPointerToFunction^;
end;
except
Result := nil;
end;
end;

function RepointFunction(OldFunc, NewFunc: Pointer): Integer;
var
IsDone: TList;
function RepointAddrInModule(hModule: THandle; OldFunc, NewFunc: Pointer): Integer;
var
Dos: PImageDosHeader;
NT: PImageNTHeaders;
ImportDesc: PImage_Import_Entry;
RVA: DWORD;
Func: ^Pointer;
DLL: string;
f: Pointer;
written: DWORD;
begin
Result := 0;
Dos := Pointer(hModule);
if IsDone.IndexOf(Dos) >= 0 then exit;
IsDone.Add(Dos);

OldFunc := LocateFunctionAddress(OldFunc);

if IsBadReadPtr(Dos, SizeOf(TImageDosHeader)) then exit;
if Dos.e_magic <> IMAGE_DOS_SIGNATURE then exit;
NT := Pointer(Integer(Dos) + dos._lfanew);

RVA := NT^.OptionalHeader.DataDirectory[IMAGE_DIRECTORY_ENTRY_IMPORT]
.VirtualAddress;

if RVA = 0 then exit;
ImportDesc := pointer(integer(Dos) + RVA);
while (ImportDesc^.Name <> 0) do
begin
DLL := PChar(Integer(Dos) + ImportDesc^.Name);
RepointAddrInModule(GetModuleHandle(PChar(DLL)), OldFunc, NewFunc);
Func := Pointer(Integer(DOS) + ImportDesc.LookupTable);
while Func^ <> nil do
begin
f := LocateFunctionAddress(Func^);
if f = OldFunc then
begin
WriteProcessMemory(GetCurrentProcess, Func, @NewFunc, 4, written);
if Written > 0 then Inc(Result);
end;
Inc(Func);
end;
Inc(ImportDesc);
end;
end;

begin
IsDone := TList.Create;
try
Result := RepointAddrInModule(GetModuleHandle(nil), OldFunc, NewFunc);
finally
IsDone.Free;
end;
end;

end.