在自己的程序中使用过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^ := dps.cArgs - 1 - i;

  if (dps.cNamedArgs <= 0) then Exit;

  for i := 0 to dps.cNamedArgs - 1 do

    pDispIds^[dps.rgdispidNamedArgs^] := i;

end;


function TIEHelper.Invoke(DispID: Integer; const IID: TGUID; LocaleID:
Integer;

  Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult;

type

  POleVariant = ^OleVariant;

var

  dps: TDispParams absolute Params;

  bHasParams: boolean;

  pDispIds: PDispIdList;

  iDispIdsSize: integer;

begin

  Result := DISP_E_MEMBERNOTFOUND;

  pDispIds := nil;

  iDispIdsSize := 0;

  bHasParams := (dps.cArgs > 0);

  if (bHasParams) then

  begin

    iDispIdsSize := dps.cArgs * SizeOf(TDispId);

    GetMem(pDispIds, iDispIdsSize);

  end;

  try

    if (bHasParams) then BuildPositionalDispIds(pDispIds, dps);

    case DispId of

      102:

        begin

         
DoStatusTextChange(dps.rgvarg^[pDispIds^[0]].bstrval);

          Result := S_OK;

        end;

      108:

        begin

         
DoProgressChange(dps.rgvarg^[pDispIds^[0]].lval, dps.rgvarg^[pDispIds^[1]].lval);

          Result := S_OK;

        end;

      105:

        begin

         
DoCommandStateChange(dps.rgvarg^[pDispIds^[0]].lval, dps.rgvarg^[pDispIds^[1]].vbool);

          Result := S_OK;

        end;

      106:

        begin

          DoDownloadBegin();

          Result := S_OK;

        end;

      104:

        begin

          DoDownloadComplete();

          Result := S_OK;

        end;

      113:

        begin

          DoTitleChange(dps.rgvarg^[pDispIds^[0]].bstrval);

          Result := S_OK;

        end;

      112:

        begin

         
DoPropertyChange(dps.rgvarg^[pDispIds^[0]].bstrval);

          Result := S_OK;

        end;

      250:

        begin

         
DoBeforeNavigate2(IDispatch(dps.rgvarg^[pDispIds^[0]].dispval),
POleVariant(dps.rgvarg^[pDispIds^[1]].pvarval)^, POleVariant(dps.rgvarg^[pDispIds^[2]].pvarval)^,
POleVariant(dps.rgvarg^[pDispIds^[3]].pvarval)^, POleVariant(dps.rgvarg^[pDispIds^[4]].pvarval)^,
POleVariant(dps.rgvarg^[pDispIds^[5]].pvarval)^, dps.rgvarg^[pDispIds^[6]].pbool^);

          Result := S_OK;

        end;

      251:

        begin

         
DoNewWindow2(IDispatch(dps.rgvarg^[pDispIds^[0]].pdispval^), dps.rgvarg^[pDispIds^[1]].pbool^);

          Result := S_OK;

        end;

      252:

        begin

         
DoNavigateComplete2(IDispatch(dps.rgvarg^[pDispIds^[0]].dispval),
POleVariant(dps.rgvarg^[pDispIds^[1]].pvarval)^);

          Result := S_OK;

        end;

      259:

        begin

         
DoDocumentComplete(IDispatch(dps.rgvarg^[pDispIds^[0]].dispval),
POleVariant(dps.rgvarg^[pDispIds^[1]].pvarval)^);

          Result := S_OK;

        end;

      253:

        begin

          DoOnQuit();

          Result := S_OK;

        end;

      254:

        begin

          DoOnVisible(dps.rgvarg^[pDispIds^[0]].vbool);

          Result := S_OK;

        end;

      255:

        begin

          DoOnToolBar(dps.rgvarg^[pDispIds^[0]].vbool);

          Result := S_OK;

        end;

      256:

        begin

          DoOnMenuBar(dps.rgvarg^[pDispIds^[0]].vbool);

          Result := S_OK;

        end;

      257:

        begin

          DoOnStatusBar(dps.rgvarg^[pDispIds^[0]].vbool);

          Result := S_OK;

        end;

      258:

        begin

          DoOnFullScreen(dps.rgvarg^[pDispIds^[0]].vbool);

          Result := S_OK;

        end;

      260:

        begin

         
DoOnTheaterMode(dps.rgvarg^[pDispIds^[0]].vbool);

          Result := S_OK;

        end;

    end;

  finally

    if (bHasParams) then FreeMem(pDispIds, iDispIdsSize);

  end;

end;




function TIEHelper.GetIDsOfNames(const IID: TGUID; Names: Pointer;

  NameCount, LocaleID: Integer; DispIDs: Pointer): HResult;

begin

  Result := E_NOTIMPL;

end;


function TIEHelper.GetTypeInfo(Index, LocaleID: Integer;

  out TypeInfo): HResult;

begin

  Result := E_NOTIMPL;

  pointer(TypeInfo) := nil;

end;


function TIEHelper.GetTypeInfoCount(out Count: Integer): HResult;

begin

  Result := E_NOTIMPL;

  Count := 0;

end;




function TIEHelper.GetSite(const riid: TIID; out site: IUnknown): HResult;

begin

//  Result := S_OK;

  if Assigned(IE) then result:=IE.QueryInterface(riid, site)

   else

     Result:= E_FAIL;

end;


function TIEHelper.SetSite(const pUnkSite: IUnknown): HResult;

var

  cmdTarget: IOleCommandTarget;

  Sp: IServiceProvider;

  CPC: IConnectionPointContainer;

  CP: ICOnnectionPoint;

begin

  if Assigned(pUnkSite) then begin

    cmdTarget := pUnkSite as IOleCommandTarget;

    Sp := CmdTarget as IServiceProvider;


      if Assigned(Sp)then

        Sp.QueryService(IWebbrowserApp,
IWebbrowser2, IE);

      if Assigned(IE) then begin

       
IE.QueryInterface(IConnectionPointContainer, CPC);

       
CPC.FindConnectionPoint(DWEBbrowserEvents2, CP);

        CP.Advise(Self, Cookie)

      end;

  end;

  Result := S_OK;

end;




procedure TIEHelperFactory.AddKeys;

var S: string;

begin

  S := GUIDToString(CLASS_IEHelper);

  with TRegistry.Create do

  try

    RootKey := HKEY_LOCAL_MACHINE;

    if OpenKey('Software\Microsoft\Windows\CurrentVersion\explorer\Browser
Helper Objects\' + S, TRUE)

      then CloseKey;

  finally

    free;

  end;

end;


procedure TIEHelperFactory.RemoveKeys;

var S: string;

begin

  S := GUIDToString(CLASS_IEHelper);

  with TRegistry.Create do

  try

    RootKey := HKEY_LOCAL_MACHINE;

    DeleteKey('Software\Microsoft\Windows\CurrentVersion\explorer\Browser
Helper Objects\' + S);

  finally

    free;

  end;

end;


procedure TIEHelperFactory.UpdateRegistry(Register: Boolean);

begin

  inherited UpdateRegistry(Register);

  if Register then AddKeys else RemoveKeys;

end;


initialization

  TIEHelperFactory.Create(ComServer, TIEHelper, Class_IEHelper,

    'IEHelper', '', ciMultiInstance, tmApartment);

end.


    代码很长，但是关键的是TIEHelper.SetSite方法以及TIEHelper.Invoke方法。在TIEHelper.SetSite方法中注意以下语句：

      if Assigned(Sp)then

        Sp.QueryService(IWebbrowserApp,
IWebbrowser2, IE);

      if Assigned(IE) then begin

       
IE.QueryInterface(IConnectionPointContainer, CPC);

       
CPC.FindConnectionPoint(DWEBbrowserEvents2, CP);

        CP.Advise(Self, Cookie)


    上面的语句作用是，首先获得IE的Webbrowser接口，然后寻找到连接点。并通过Advise方法建立COM自身与连接点的连接。

    当连接建立成功后，IE在有事件引发后，会调用连接到自身的IDispatch接口对象的Invoke方法。不同的事件对应不同的DispID编码，我们可以在程序中判断DispID并做相应的处理。在上面的程序中，我们只处理了BeforeNavigate2
事件，处理函数是DoBeforeNavigate2，在该函数中，如果浏览的站点不是'http://www.applevb.com/'的话，程序会提示：'你不可以浏览其它站点'并强行转到http://www.applevb.com。

    很多的软件，象“护花使者”以及“3721”一类的中文网址”都是利用上面的原理来实现对IE浏览器事件响应的，例如3721，当用户输入一个中文词并浏览时，COM组件可以在BeforeNavigate2
事件中编写代码访问服务器并转到正确的站点上去。

    以上程序在Win2K、Delphi 5下编写 Win98、Win2K下编辑通过，如果大家需要源程序或者对于COM编程需要有什么的指教的话，欢迎到我的主页
http://www.applevb.com
访问，我愿意同大家一起探讨。


转自：  编程联盟