在自己的程序中使用過WebBrowser控件的朋友都知道，WebBrowser控件定義了諸如BeforeNavigate、DownloadComplete 等事件，我們可以通過編寫事件處理代碼實現對WebBrowser控件的操作。那麼如何實現對IE的事件響應和處理呢？同建立IE面板一樣。我們需要建立一個實現IObjectWithSite接口的COM組件，不同的是，我們還需要實現IDispatch接口，在IObjectWithSite接口的SetSite方法中獲得IE的WebBrowser接口並建立自身與WebBrowser的連接，然後如果在IE的Webbrowser對象中發生什麼事件的話，那麼IE就會回調連接的IDispatch接口的Invoke方法。我們通過在Invoke方法中編寫代碼就可以獲得IE事件了。這個利用的是COM編程的回調接口原理。
下面我們首先來實現代碼。點擊Delphi菜單 File | New 。在 ActiveX 頁面中選擇Active Library ，然後點擊 OK 按鈕。然後用同樣的方法建立一個COM Object。在COM Object Wizard 窗口中，將復選框 Included type library 去掉。然後在Class Name中輸入IEHelper，在Implemented Interface 中輸入：IDispatch；IObjectwithSite 。然後點擊 OK 按鈕建立一個COM組件。
保存工程，將工程保存為IEHelper.dpr，將Unit1保存為IEHelperUnit.pas。下面是IEHelperUnit.pas的具體代碼：
unit iehelperunit;
interface
uses
WIndows, Comobj, ActiveX, SHDOCVW, MSHTML,Dialogs;
type
TIEHelperFactory = class(TComObjectFactory)
private
procedure AddKeys;
procedure RemoveKeys;
public
procedure UpdateRegistry(Register: Boolean); override;
end;
TIEHelper = class(TComObject, IDispatch, IObjectWithSite)
public
function GetTypeInfoCount(out Count: Integer): HResult; stdcall;
function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; stdcall;
function GetIDsOfNames(const IID: TGUID; Names: Pointer;
NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; stdcall;
function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; stdcall;
function SetSite(const pUnkSite: IUnknown): HResult; stdcall;
function GetSite(const riid: TIID; out site: IUnknown): HResult; stdcall;
private
IE: IWebbrowser2;
Cookie: Integer;
end;
const
Class_IEHelper: TGUID = {3D898C55-74CC-4B7C-B5F1-45913F368388};
implementation
uses ComServ, Registry, SysUtils;
procedure DoStatusTextChange(const Text: WideString);
begin
end;
procedure DoProgressChange(Progress: Integer; ProgressMax: Integer);
begin
end;
procedure DoCommandStateChange(Command: Integer; Enable: WordBool);
begin
end;
procedure DoDownloadBegin;
begin
end;
procedure DoDownloadComplete;
begin
end;
procedure DoTitleChange(const Text: WideString);
begin
end;
procedure DoPropertyChange(const szProperty: WideString);
begin
end;
procedure DoBeforeNavigate2(const pDisp: IDispatch; var URL: OleVariant; var Flags: OleVariant; var TargetFrameName: OleVariant; var PostData: OleVariant; var Headers: OleVariant; var Cancel: WordBool);
begin
if URL<>http://www.applevb.com/then begin
Showmessage(你不可以浏覽其它站點);
Cancel:=True;
URL:=http://www.applevb.com;
(pDisp as IWebbrowser2).Navigate2(URL,Flags,TargetFrameName,PostData,Headers);
end;
end;
procedure DoNewWindow2(var ppDisp: IDispatch; var Cancel: WordBool);
begin
end;
procedure DoNavigateComplete2(const pDisp: IDispatch; var URL: OleVariant);
begin
end;
procedure DoDocumentComplete(const pDisp: IDispatch; var URL: OleVariant);
begin
end;
procedure DoOnQuit;
begin
end;
procedure DoOnVisible(Visible: WordBool);
begin
end;
procedure DoOnToolBar(ToolBar: WordBool);
begin
end;
procedure DoOnMenuBar(MenuBar: WordBool);
begin
end;
procedure DoOnStatusBar(StatusBar: WordBool);
begin
end;
procedure DoOnFullScreen(FullScreen: WordBool);
begin
end;
procedure DoOnTheaterMode(TheaterMode: WordBool);
begin
end;
procedure BuildPositionalDispIds(pDispIds: PDispIdList; const dps: TDispParams);
var
i: integer;
begin
Assert(pDispIds <> nil);
for i := 0 to dps.cArgs - 1 do
pDispIds^[i] := dps.cArgs - 1 - i;
if (dps.cNamedArgs <= 0) then Exit;
for i := 0 to dps.cNamedArgs - 1 do
pDispIds^[dps.rgdispidNamedArgs^[i]] := i;
end;
function TIEHelper.Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult;
