uses
  IBSQLMonitor;

type
  TMyMonitorHook = class
  strict private
    type
      TTranProc = procedure (tr: TIBTransaction) of object;
      TErrProc = procedure (AMsg: string) of object;
    class var
      FTransactions: TThreadedDictionary<TIBTransaction, string>;
      FOldMethods: TList<TPair<Integer, Pointer>>;
  strict private
    class constructor Create;
    class destructor Destroy;
  strict private
    class function WriteAddr(const AHook: IIBSQLMonitorHook;
      AMethodIdx: Integer; const ANewMethod: TTranProc): Pointer; overload;
    class function WriteAddr(const AHook: IIBSQLMonitorHook;
      AMethodIdx: Integer; ANewMethod: Pointer): Pointer; overload;
  strict private
    class procedure TRStart(tr: TIBTransaction);
    class procedure TRCommit(tr: TIBTransaction);
    class procedure TRRollback(tr: TIBTransaction);
    class procedure SendError(AMsg : String);
  public
    class procedure Init;
  end;

{ TMyMonitorHook }

class constructor TMyMonitorHook.Create;
begin
  FTransactions := TThreadedDictionary<TIBTransaction, string>.Create;
  FOldMethods := TList<TPair<Integer, Pointer>>.Create;
end;

class destructor TMyMonitorHook.Destroy;
var
  LHook: IIBSQLMonitorHook;
  LPair: TPair<Integer, Pointer>;
begin
  if FOldMethods.Count > 0 then begin
    LHook := MonitorHook;
    for LPair in FOldMethods do
      WriteAddr(LHook, LPair.Key, LPair.Value);
  end;
  FTransactions.Free;
end;

class function TMyMonitorHook.WriteAddr(const AHook: IIBSQLMonitorHook;
  AMethodIdx: Integer; const ANewMethod: TTranProc): Pointer;
begin
  Result := WriteAddr(AHook, AMethodIdx, TMethod(ANewMethod).Code);
end;

class function TMyMonitorHook.WriteAddr(const AHook: IIBSQLMonitorHook;
  AMethodIdx: Integer; ANewMethod: Pointer): Pointer;
var
  LOffset: Cardinal;
  LMethodAddr: PPointer;
  LOldProt: Cardinal;
begin
  LOffset := (AMethodIdx + 3) * SizeOf(Pointer);  // 3 - count of methods IUnknown
  LMethodAddr := OffsetPtr(PPointer(AHook)^, LOffset);
  Win32Check(VirtualProtect(LMethodAddr, SizeOf(LMethodAddr^), PAGE_READWRITE, LOldProt));
  Result := LMethodAddr^;
  LMethodAddr^ := ANewMethod;
  Win32Check(VirtualProtect(LMethodAddr, SizeOf(LMethodAddr^), LOldProt, LOldProt));
end;

class procedure TMyMonitorHook.TRStart(tr: TIBTransaction);
var
  LStr: string;
begin
  if FTransactions.TryGetValue(tr, LStr) then
    Msg(LStr)
  else
    FTransactions.Add(tr, Format(#13#10'Thread: %u', [GetCurrentThreadId]) + GetStackInfo());
end;

class procedure TMyMonitorHook.TRCommit(tr: TIBTransaction);
begin
  FTransactions.Remove(tr);
end;

class procedure TMyMonitorHook.TRRollback(tr: TIBTransaction);
begin
  FTransactions.Remove(tr);
end;

class procedure TMyMonitorHook.SendError(AMsg: String);
var
  LMsg: string;
  LTrans: TDictionary<TIBTransaction, string>;
  LPair: TPair<TIBTransaction, string>;
begin
  LMsg := Format('Thread: %u'#13#10, [GetCurrentThreadId]);
  LTrans := FTransactions.BeginRead;
  try
    for LPair in LTrans do begin
      LMsg := LMsg + LPair.Key.Name + LPair.Value + sLineBreak;
    end;
  finally
    FTransactions.EndRead;
  end;
  ShowMessage(LMsg);
end;

class procedure TMyMonitorHook.Init;
var
  LHook: IIBSQLMonitorHook;
  LPair: TPair<Integer, Pointer>;
  LErr: TErrProc;
begin
  LHook := MonitorHook;
  LPair.Key := 8;
  LPair.Value := WriteAddr(LHook, LPair.Key, TRStart);
  FOldMethods.Add(LPair);

  LPair.Key := 9;
  LPair.Value := WriteAddr(LHook, LPair.Key, TRCommit);
  FOldMethods.Add(LPair);

  LPair.Key := 11;
  LPair.Value := WriteAddr(LHook, LPair.Key, TRRollback);
  FOldMethods.Add(LPair);

  LErr := SendError;
  LPair.Key := 19;
  LPair.Value := WriteAddr(LHook, LPair.Key, TMethod(LErr).Code);
  FOldMethods.Add(LPair);
end;