GenCodeHook, Version 1.4 (alt)

{
  fmain.pas

  This file is part of the GenCodeHook.pas sample application.
  Info at http://flocke.vssd.de/prog/code/pascal/codehook/

  Copyright (C) 2005 Volker Siebert <flocke@vssd.de>
  All rights reserved.
}

unit fmain;

interface

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

type
  TForm1 = class(TForm)
    Shape1: TShape;
    Shape2: TShape;
    Label1: TLabel;
    Edit1: TEdit;
    Button1: TButton;
    Label2: TLabel;
    Edit2: TEdit;
    Button2: TButton;
    Bevel1: TBevel;
    Button3: TButton;
    OpenDialog1: TOpenDialog;
    SaveDialog1: TSaveDialog;
    Label3: TLabel;
    Label4: TLabel;
    Timer1: TTimer;
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure Timer1Timer(Sender: TObject);
    procedure FormHide(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure Button3Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Button1Click(Sender: TObject);
  private
    { Private-Deklarationen }
  public
    { Public-Deklarationen }
    FFlashPoint: array [0 .. 1] of cardinal;
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

{----------------------------------------------------------------------}

uses
  GenCodeHook, CodeMemOpt;

const
  CFlashDurance = 5;

type
  TFnReadFile = function(hFile: THandle; var Buffer; nNumberOfBytesToRead: DWORD;
    var lpNumberOfBytesRead: DWORD; lpOverlapped: POverlapped): BOOL; stdcall;
  TFnWriteFile = function(hFile: THandle; const Buffer; nNumberOfBytesToWrite: DWORD;
    var lpNumberOfBytesWritten: DWORD; lpOverlapped: POverlapped): BOOL; stdcall;

var
  OldReadFile: TFnReadFile;
  OldWriteFile: TFnWriteFile;

function NewReadFile(hFile: THandle; var Buffer; nNumberOfBytesToRead: DWORD;
  var lpNumberOfBytesRead: DWORD; lpOverlapped: POverlapped): BOOL; stdcall;
begin
  if GetCurrentThreadID = MainThreadID then
  begin
    Form1.FFlashPoint[0] := GetTickCount + CFlashDurance;

    if Form1.Shape1.Brush.Color <> clGreen then
    begin
      Form1.Shape1.Brush.Color := clGreen;
      Form1.Shape1.Repaint;
    end;
  end;

  Result := OldReadFile(hFile, Buffer, nNumberOfBytesToRead, lpNumberOfBytesRead, lpOverlapped);

  if GetCurrentThreadID = MainThreadID then
    Application.ProcessMessages;
end;

function NewWriteFile(hFile: THandle; const Buffer; nNumberOfBytesToWrite: DWORD;
  var lpNumberOfBytesWritten: DWORD; lpOverlapped: POverlapped): BOOL; stdcall;
begin
  if GetCurrentThreadID = MainThreadID then
  begin
    Form1.FFlashPoint[1] := GetTickCount + CFlashDurance;

    if Form1.Shape2.Brush.Color <> clRed then
    begin
      Form1.Shape2.Brush.Color := clRed;
      Form1.Shape2.Repaint;
    end;
  end;

  Result := OldWriteFile(hFile, Buffer, nNumberOfBytesToWrite, lpNumberOfBytesWritten, lpOverlapped);

  if GetCurrentThreadID = MainThreadID then
    Application.ProcessMessages;
end;

function InstallPatch: boolean;
var
  Module: HMODULE;
  ok: boolean;
begin
  Module := GetModuleHandle('kernel32.dll');
  ok := CreateGenericCodeHook(GetProcAddress(Module, 'ReadFile'),
          @NewReadFile, @OldReadFile);
  if ok then
  begin
    ok := CreateGenericCodeHook(GetProcAddress(Module, 'WriteFile'),
            @NewWriteFile, @OldWriteFile);
    if not ok then
      RemoveGenericCodeHook(@OldReadFile);
  end;

  if not ok then
    MessageDlg('CreateGenericCodeHook did not work!', mtError, [mbOk], 0);

  Result := ok;
end;

procedure UninstallPatch;
begin
  RemoveGenericCodeHook(@OldReadFile);
  RemoveGenericCodeHook(@OldWriteFile);
end;

{----------------------------------------------------------------------}

procedure TForm1.FormShow(Sender: TObject);
begin
  FFlashPoint[0] := 0;
  FFlashPoint[1] := 0;

  if not InstallPatch then
    Close;
end;

procedure TForm1.FormHide(Sender: TObject);
begin
  UninstallPatch;
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  UninstallPatch;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  OpenDialog1.FileName := Edit1.Text;
  if OpenDialog1.Execute then
    Edit1.Text := OpenDialog1.FileName;
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  SaveDialog1.FileName := Edit2.Text;
  if SaveDialog1.Execute then
    Edit2.Text := SaveDialog1.FileName;
end;

procedure TForm1.Button3Click(Sender: TObject);
begin
  CopyFile(PChar(Edit1.Text), PChar(Edit2.Text), false);
  MessageBeep(MB_ICONINFORMATION);
end;

procedure TForm1.Timer1Timer(Sender: TObject);
var
  k: cardinal;
begin
  k := GetTickCount;

  if (FFlashPoint[0] <> 0) and (k > FFlashPoint[0]) then
  begin
    FFlashPoint[0] := 0;
    Shape1.Brush.Color := clWhite;
    Shape1.Repaint;
  end;

  if (FFlashPoint[1] <> 0) and (k > FFlashPoint[1]) then
  begin
    FFlashPoint[1] := 0;
    Shape2.Brush.Color := clWhite;
    Shape2.Repaint;
  end;
end;

end.