////////////////////////////////////////////////////////////////////////////////
//
//  Демонстрационная программа перехвата вызова API функций
//  Автор: Джеффри РИХТЕР
//  Адаптация для Delphi: Александр (Rouse_) Багель
//

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls;

type

  TMessageBox = function(hWnd: HWND; lpText, lpCaption:
    PChar; uType: UINT): Integer; stdcall;

  PFARPROC = ^FARPROC;

  TIIDUnion = record
    case Integer of
      0: (Characteristics: DWORD);
      1: (OriginalFirstThunk: DWORD);
  end;

  PImageImportDescriptor = ^TImageImportDescriptor;
  TImageImportDescriptor = record
    Union: TIIDUnion;
    TimeDateStamp: DWORD;
    ForwarderChain: DWORD;
    Name: DWORD;
    FirstThunk: DWORD;
  end;

  PImageThunkData = ^TImageThunkData32;
  TImageThunkData32 = packed record
    _function : PDWORD;
  end;

  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
    procedure ReplaceIATEntryInOneMod(const OldProc, NewProc: FARPROC);
    procedure SetAPIHook;
    procedure ResetAPIHook;
  end;

  {$EXTERNALSYM ImageDirectoryEntryToData}
  function ImageDirectoryEntryToData(Base: Pointer; MappedAsImage: ByteBool;
    DirectoryEntry: Word; var Size: ULONG): Pointer; stdcall; external 'imagehlp.dll';

  {$EXTERNALSYM HookMessageBox}
  function HookMessageBox(hWnd: HWND; lpText, lpCaption: PChar;
    uType: UINT): Integer; stdcall;

var
  Form1: TForm1;

var
  OldMessageBox: FARPROC = nil;
  CurrentMessageBox: FARPROC;

implementation

{$R *.dfm}

// Перехват API посредством подмены в таблице импорта
procedure TForm1.ReplaceIATEntryInOneMod(const OldProc,
  NewProc: FARPROC);
var
  Size: DWORD;
  ImportEntry: PImageImportDescriptor;
  Thunk: PImageThunkData;
  Protect, newProtect: DWORD;
  DOSHeader: PImageDosHeader;
  NTHeader: PImageNtHeaders;
begin
  if OldProc = nil then Exit;
  if NewProc = nil then Exit;

   // Можно искать вот так
  ImportEntry := ImageDirectoryEntryToData(Pointer(hInstance), BOOL(1),
    IMAGE_DIRECTORY_ENTRY_IMPORT, Size);

  // Или вот так
  {DOSHeader := PImageDosHeader(hInstance);
  if IsBadReadPtr(Pointer(hInstance), SizeOf(TImageNtHeaders)) then Exit;
  if (DOSHeader^.e_magic <> IMAGE_DOS_SIGNATURE) then Exit;
  NTHeader := PImageNtHeaders(DWORD(DOSHeader) + DWORD(DOSHeader^._lfanew));
  if NTHeader^.Signature <> IMAGE_NT_SIGNATURE then Exit;
  ImportEntry := PImageImportDescriptor(DWORD(hInstance) +
      DWORD(NTHeader^.OptionalHeader.DataDirectory[IMAGE_DIRECTORY_ENTRY_IMPORT].VirtualAddress));
  if DWORD(ImportEntry) = DWORD(NTHeader) then Exit;  }

  if ImportEntry <> nil then
  begin
    while ImportEntry^.Name <> 0 do
    begin
        Thunk := PImageThunkData(DWORD(hInstance) +
          DWORD(ImportEntry^.FirstThunk));
        while Thunk^._function <> nil do
        begin
          if (Thunk^._function = OldProc) then
          begin
            if not IsBadWritePtr(@Thunk^._function, sizeof(DWORD)) then
              Thunk^._function := NewProc
            else
            begin

              if VirtualProtect(@Thunk^._function, SizeOf(DWORD),
                PAGE_EXECUTE_READWRITE, Protect) then
              begin
                Thunk^._function := NewProc;
                newProtect := Protect;
                VirtualProtect(@Thunk^._function, SizeOf(DWORD),
                  newProtect, Protect);
              end;
            end;
            //Exit;
          end
          else
            Inc(PChar(Thunk), SizeOf(TImageThunkData32));
        end;
      ImportEntry := Pointer(Integer(ImportEntry) + SizeOf(TImageImportDescriptor));
    end;
  end;
end;

function HookMessageBox(hWnd: HWND; lpText, lpCaption: PChar; uType: UINT): Integer; stdcall;
begin
  Result := TMessageBox(OldMessageBox)(hWnd,
    PChar(Format('Перехвачен текст: "%s"', [lpText])),
    PChar(Format('Перехвачен текст: "%s"', [lpCaption])), uType);
end;

// Снятие хука
procedure TForm1.ResetAPIHook;
begin
  ReplaceIATEntryInOneMod(CurrentMessageBox, OldMessageBox);
end;

// Установка хука
procedure TForm1.SetAPIHook;
begin
  OldMessageBox :=
    GetProcAddress(GetModuleHandle('User32.dll'), 'MessageBoxA');
  CurrentMessageBox := @HookMessageBox;
  ReplaceIATEntryInOneMod(OldMessageBox, CurrentMessageBox);
end;

////////////////////////////////////////////////////////////////////////////////

procedure TForm1.Button1Click(Sender: TObject);
begin
  MessageBox(0, 'Текст сообщения', 'Заголовок', 0);
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  SetAPIHook;
  MessageBox(0, 'Текст сообщения', 'Заголовок', 0);
  ResetAPIHook;
end;

end.
