Question

如何在Delphi中正确挂钩COM接口？下面的代码应该可以工作，但是当我尝试调用原始函数时它会崩溃。

725E1C46的首次机会异常。异常类$ C0000005，消息＆＃39;访问冲突位于0x725e1c46：写入地址0x725de532＆＃39;。处理Project.exe（6524）

unit ComHook;

interface

uses
    Winapi.Windows,
    Winapi.WinInet,
    ComObj,
    ComServ,
    ActiveX,
    UrlMon,
    MSHTML,
    SHDocVw,
    DDetours;

const
    CLSID_HttpProtocol: TGUID = '{79EAC9E2-BAF9-11CE-8C82-00AA004BA90B}';

type
  TInternetProtocol = record
    class function Read(pv: Pointer; cb: ULONG; out cbRead: ULONG): HResult;  static;
    class function Seek(dlibMove: LARGE_INTEGER; dwOrigin: DWORD; out libNewPosition: ULARGE_INTEGER): HResult; static;
    class function LockRequest(dwOptions: DWORD): HResult;  static;
    class function UnlockRequest: HResult; static;
  end;

var
    FInternetProtocol: IInternetProtocol;
    FRead: function(pv: Pointer; cb: ULONG; out cbRead: ULONG): HResult;
    FSeek: function(dlibMove: LARGE_INTEGER; dwOrigin: DWORD; out libNewPosition: ULARGE_INTEGER): HResult;
    FLockRequest: function(dwOptions: DWORD): HResult;
    FUnlockRequest: function: HResult;

implementation

{ TInternetProtocol }

class function TInternetProtocol.Read(pv: Pointer; cb: ULONG; out cbRead: ULONG): HResult;
begin
  Result := FRead(pv, cb, cbRead);
end;

class function TInternetProtocol.Seek(dlibMove: LARGE_INTEGER; dwOrigin: DWORD; out libNewPosition: ULARGE_INTEGER): HResult;
begin
  Result := FSeek(dlibMove, dwOrigin, libNewPosition);
end;

class function TInternetProtocol.LockRequest(dwOptions: DWORD): HResult;
begin
  Result := FLockRequest(dwOptions); // Crash!
end;

class function TInternetProtocol.UnlockRequest: HResult;
begin
  Result := FUnlockRequest;
end;

initialization
  CoCreateInstance(CLSID_HttpProtocol, nil, CLSCTX_INPROC_SERVER, IID_IInternetProtocol, FInternetProtocol);
  @FRead := InterceptCreate(FInternetProtocol, 7, @TInternetProtocol.Read);
  @FSeek := InterceptCreate(FInternetProtocol, 8, @TInternetProtocol.Seek);
  @FLockRequest := InterceptCreate(FInternetProtocol, 9, @TInternetProtocol.LockRequest);
  @FUnlockRequest := InterceptCreate(FInternetProtocol, 10, @TInternetProtocol.UnlockRequest);
end.


...

procedure TForm2.Button1Click(Sender: TObject);
begin
  WebBrowser1.Navigate('www.stackoverflow.com');
end;

Answer 1

我可以看到三个错误：

你错过了召唤大会。这些方法都应该是stdcall。
您需要将实例指针包含为每个方法的第一个参数。
你的指数错了。您需要从零开始计算并考虑IInterface。

更改后，您的代码应如下所示：

type
  TInternetProtocol = record
    class function Read(inst: Pointer; pv: Pointer; cb: ULONG; out cbRead: ULONG): HResult; stdcall; static;
    class function Seek(inst: Pointer; dlibMove: LARGE_INTEGER; dwOrigin: DWORD; out libNewPosition: ULARGE_INTEGER): HResult; stdcall; static;
    class function LockRequest(inst: Pointer; dwOptions: DWORD): HResult; stdcall; static;
    class function UnlockRequest(inst: Pointer): HResult; stdcall; static;
  end;

var
    FInternetProtocol: IInternetProtocol;
    FRead: function(inst: Pointer; pv: Pointer; cb: ULONG; out cbRead: ULONG): HResult; stdcall;
    FSeek: function(inst: Pointer; dlibMove: LARGE_INTEGER; dwOrigin: DWORD; out libNewPosition: ULARGE_INTEGER): HResult; stdcall;
    FLockRequest: function(inst: Pointer; dwOptions: DWORD): HResult; stdcall;
    FUnlockRequest: function(inst: Pointer): HResult; stdcall;

....

@FRead := InterceptCreate(FInternetProtocol, 9, @TInternetProtocol.Read);
@FSeek := InterceptCreate(FInternetProtocol, 10, @TInternetProtocol.Seek);
@FLockRequest := InterceptCreate(FInternetProtocol, 11, @TInternetProtocol.LockRequest);
@FUnlockRequest := InterceptCreate(FInternetProtocol, 12, @TInternetProtocol.UnlockRequest);

FWIW，Delphi Detours库的最新版本允许您按名称挂钩界面方法，这会让生活变得更简单。

如何挂钩COM接口？

1 个答案: