我们首先要建立一个ActiveX Library。将其保存为MailIEBand.Dpr；然后建立一个COM Object，将其保存为BandUnit.pas；然后建立一个Form，这个窗口将作为子窗口显示在IE工具栏中，将窗口的BorderStyle属性改为bsNone，添加一个TButton组件和一个TComboBox组件，将TButton的Caption属性改为获取全部，然后将窗口文件其保存为IEForm.pas。

在BandUnit中，需要建立一个实现上面提到的接口的TComObject对象。如下：

TGetMailBand = class(TComObject, IDeskBand, IObjectWithSite, IPersistStreamInit)

另外由于需要在COM服务器注册时添加一些注册表信息，所以还需要建立一个继承自TComObjectFactory类的对象，在对象的UpdateRegistry事件中编写代码添加附加的注册表信息。

下面的程序清单1-6到1-8是实现COM服务器的全部程序代码：

程序清单1-6 MailIEBand.dpr

library MailIEBand;

uses

 ComServ,

 BandUnit in 'BandUnit.pas',

 IEForm in 'IEForm.pas' {Form1},

 MailIEBand_TLB in 'MailIEBand_TLB.pas';

exports

 DllGetClassObject,

 DllCanUnloadNow,

 DllRegisterServer,

 DllUnregisterServer;

{$R *.TLB}

{$R *.RES}

begin

end.

程序清单1-7 BandUnit.pas

unit BandUnit;

interface

uses

 Windows, Sysutils, Messages, Registry, Shellapi, ActiveX, Classes, ComObj,

  Shlobj, Dialogs, Commctrl,ShDocVW,IEForm;

type

 TGetMailBand = class(TComObject, IDeskBand, IObjectWithSite, IPersistStreamInit)

 private

   frmIE:TForm1;

   m_pSite:IInputObjectSite;

  m_hwndParent:HWND;

  m_hWnd:HWND;

  m_dwViewMode:Integer;

   m_dwBandID:Integer;

  protected

  public

  {Declare IDeskBand methods here}

   function GetBandInfo(dwBandID, dwViewMode: DWORD; var pdbi: TDeskBandInfo):

     HResult; stdcall;

   function ShowDW(fShow: BOOL): HResult; stdcall;

   function CloseDW(dwReserved: DWORD): HResult; stdcall;

   function ResizeBorderDW(var prcBorder: TRect; punkToolbarSite: IUnknown;

     fReserved: BOOL): HResult; stdcall;

   function GetWindow(out wnd: HWnd): HResult; stdcall;

   function ContextSensitiveHelp(fEnterMode: BOOL): HResult; stdcall;

   {Declare IObjectWithSite methods here}

   function SetSite(const pUnkSite: IUnknown ):HResult; stdcall;

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

   {Declare IPersistStream methods here}

   function GetClassID(out classID: TCLSID): HResult; stdcall;

   function IsDirty: HResult; stdcall;

   function InitNew: HResult; stdcall;

   function Load(const stm: IStream): HResult; stdcall;

   function Save(const stm: IStream; fClearDirty: BOOL): HResult; stdcall;

   function GetSizeMax(out cbSize: Largeint): HResult; stdcall;

 end;

const

 Class_GetMailBand: TGUID = '{954F618B-0DEC-4D1A-9317-E0FC96F87865}';

 //以下是系统接口的IID

 IID_IUnknown: TGUID = (

   D1:$00000000;D2:$0000;D3:$0000;D4:($C0,$00,$00,$00,$00,$00,$00,$46));

 IID_IOleObject: TGUID = (

   D1:$00000112;D2:$0000;D3:$0000;D4:($C0,$00,$00,$00,$00,$00,$00,$46));

 IID_IOleWindow: TGUID = (

   D1:$00000114;D2:$0000;D3:$0000;D4:($C0,$00,$00,$00,$00,$00,$00,$46));

 IID_IInputObjectSite : TGUID = (

   D1:$f1db8392;D2:$7331;D3:$11d0;D4:($8C,$99,$00,$A0,$C9,$2D,$BF,$E8));

 sSID_SInternetExplorer : TGUID = '{0002DF05-0000-0000-C000-000000000046}';

 sIID_IWebBrowserApp : TGUID= '{0002DF05-0000-0000-C000-000000000046}';

 //面板所允许的最小宽度和高度。

 MIN_SIZE_X = 54;

 MIN_SIZE_Y = 22;

 EB_CLASS_NAME = 'GetMailAddress';

implementation

uses ComServ;

function TGetMailBand.GetWindow(out wnd: HWnd): HResult; stdcall;

begin

  wnd:=m_hWnd;

  Result:=S_OK;

end;

function TGetMailBand.ContextSensitiveHelp(fEnterMode: BOOL): HResult; stdcall;

begin

  Result:=E_NOTIMPL;

end;

function TGetMailBand.ShowDW(fShow: BOOL): HResult; stdcall;

begin

  if m_hWnd<>0 then

   if fShow then

     ShowWindow(m_hWnd,SW_SHOW)

   else

     ShowWindow(m_hWnd,SW_HIDE);

  Result:=S_OK;

end;

function TGetMailBand.CloseDW(dwReserved: DWORD): HResult; stdcall;

begin

  if frmIE<>nil then

   frmIE.Destroy;

  Result:= S_OK;

end;

function TGetMailBand.ResizeBorderDW(var prcBorder: TRect;

   punkToolbarSite: IUnknown;fReserved: BOOL): HResult; stdcall;

begin

  Result:=E_NOTIMPL;

end;

function TGetMailBand.SetSite(const pUnkSite: IUnknown):HResult;stdcall;

var

  pOleWindow:IOleWindow;

  pOLEcmd:IOleCommandTarget;

  pSP:IServiceProvider;

  rc:TRect;

begin

  if Assigned(pUnkSite) then begin

   m_hwndParent := 0;

   m_pSite:=pUnkSite as IInputObjectSite;

   pOleWindow := PunkSIte as IOleWindow;

   //获得父窗口IE面板窗口的句柄

   pOleWindow.GetWindow(m_hwndParent);

   if(m_hwndParent=0)then begin

     Result := E_FAIL;

     exit;

   end;

   //获得父窗口区域

   GetClientRect(m_hwndParent, rc);

   if not Assigned(frmIE) then begin

     //建立TIEForm窗口，父窗口为m_hwndParent

     frmIE:=TForm1.CreateParented(m_hwndParent);

     m_Hwnd:=frmIE.Handle;

     SetWindowLong(frmIE.Handle, GWL_STYLE, GetWindowLong(frmIE.Handle,

      GWL_STYLE) Or WS_CHILD);

     //根据父窗口区域设置窗口位置

     with frmIE do begin

      Left :=rc.Left ;

      Top:=rc.top;

      Width:=rc.Right - rc.Left;

      Height:=rc.Bottom - rc.Top;

     end;

     frmIE.Visible := True;

     //获得与浏览器相关联的Webbrowser对象。

     pOLEcmd:=pUnkSite as IOleCommandTarget;

     pSP:=pOLEcmd as IServiceProvider;

     if Assigned(pSP)then begin

      pSP.QueryService(IWebbrowserApp, IWebbrowser2,frmIE.IEThis);

     end;

   end;

  end;

  Result := S_OK;

end;

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

begin

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

  else

   Result:= E_FAIL;

end;

function TGetMailBand.GetBandInfo(dwBandID, dwViewMode: DWORD; var pdbi: TDeskBandInfo):

   HResult; stdcall;

begin

  Result:=E_INVALIDARG;

  if not Assigned(frmIE) then frmIE:=TForm1.CreateParented(m_hwndParent);

  if(@pdbi<>nil)then begin

   m_dwBandID := dwBandID;

   m_dwViewMode := dwViewMode;

   if(pdbi.dwMask and DBIM_MINSIZE)<>0 then begin

     pdbi.ptMinSize.x := MIN_SIZE_X;

     pdbi.ptMinSize.y := MIN_SIZE_Y;

   end;

   if(pdbi.dwMask and DBIM_MAXSIZE)<>0 then begin

     pdbi.ptMaxSize.x := -1;

     pdbi.ptMaxSize.y := -1;

   end;

   if(pdbi.dwMask and DBIM_INTEGRAL)<>0 then begin

     pdbi.ptIntegral.x := 1;

     pdbi.ptIntegral.y := 1;

   end;

   if(pdbi.dwMask and DBIM_ACTUAL)<>0 then begin

     pdbi.ptActual.x := 0;

     pdbi.ptActual.y := 0;

   end;

   if(pdbi.dwMask and DBIM_MODEFLAGS)<>0 then

     pdbi.dwModeFlags := DBIMF_VARIABLEHEIGHT;

   if(pdbi.dwMask and DBIM_BKCOLOR)<>0 then

     pdbi.dwMask := pdbi.dwMask and (not DBIM_BKCOLOR);

  end;

end;

function TGetMailBand.GetClassID(out classID: TCLSID): HResult; stdcall;

begin

  classID:= Class_GetMailBand;

  Result:=S_OK;

end;

function TGetMailBand.IsDirty: HResult; stdcall;

begin

  Result:=S_FALSE;

end;

function TGetMailBand.InitNew: HResult;

begin

 Result := E_NOTIMPL;

end;

function TGetMailBand.Load(const stm: IStream): HResult; stdcall;

begin

  Result:=S_OK;

end;

function TGetMailBand.Save(const stm: IStream; fClearDirty: BOOL): HResult; stdcall;

begin

  Result:=S_OK;

end;

function TGetMailBand.GetSizeMax(out cbSize: Largeint): HResult; stdcall;

begin

  Result:=E_NOTIMPL;

end;

//TIEClassFac类实现COM组件的注册

type

  TIEClassFac=class(TComObjectFactory) //

  public

   procedure UpdateRegistry(Register: Boolean); override;

  end;

procedure TIEClassFac.UpdateRegistry(Register: Boolean);

var

 ClassID: string;

 a:Integer;

begin

  inherited UpdateRegistry(Register);

  if Register then begin

   ClassID:=GUIDToString(Class_GetMailBand);

   with TRegistry.Create do

    try

     //添加附加的注册表项

     RootKey:=HKEY_LOCAL_MACHINE;

     OpenKey('\SOFTWARE\Microsoft\Internet Explorer\Toolbar',False);

     a:=0;

     WriteBinaryData(GUIDToString(Class_GetMailBand),a,0);

     OpenKey('\SOFTWARE\Microsoft\Windows\CurrentVersion\Shell Extensions\Approved',True);

     WriteString (GUIDToString(Class_GetMailBand),EB_CLASS_NAME);

     RootKey:=HKEY_CLASSES_ROOT;

     OpenKey('\CLSID\'+GUIDToString(Class_GetMailBand),False);

     WriteString('',EB_CLASS_NAME);

    finally

     Free;

    end;

  end

  else begin

   with TRegistry.Create do

   try

     RootKey:=HKEY_LOCAL_MACHINE;

     OpenKey('\SOFTWARE\Microsoft\Internet Explorer\Toolbar',False);

     DeleteValue(GUIDToString(Class_GetMailBand));

     OpenKey('\Software\Microsoft\Windows\CurrentVersion\Shell Extensions\Approved',False);

     DeleteValue(GUIDToString(Class_GetMailBand));

   finally

     Free;

   end;

  end;

end;

initialization

  TIEClassFac.Create(ComServer, TGetMailBand, Class_GetMailBand,

   'GetMailAddress', '', ciMultiInstance, tmApartment);

end.

程序清单1-8 IEForm.pas

unit IEForm;

interface

uses

 Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

 SHDocVw,MSHTML, StdCtrls;

type

 TForm1 = class(TForm)

  Button1: TButton;

  ComboBox1: TComboBox;

  procedure FormResize(Sender: TObject);

  procedure Button1Click(Sender: TObject);

 private

  { Private declarations }

 public

  IEThis:IWebbrowser2;

  { Public declarations }

 end;

var

 Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormResize(Sender: TObject);

begin

 With Button1 do begin

  Left := 0;

  Top := 0;

  Height:=Self.ClientHeight;

 end;

 With ComboBox1 do begin

  Left := Button1.Width +3;

  Top := 0;

  Height:=Self.ClientHeight;

  Width:=Self.ClientWidth - Left;

 end;

end;

procedure TForm1.Button1Click(Sender: TObject);

var

 doc:IHTMLDocument2;

 all:IHTMLElementCollection;

 len,i,flag:integer;

 item:IHTMLElement;

 vAttri:Variant;

begin

 if Assigned(IEThis)then begin

  ComboBox1.Clear;

  //获得Webbrowser对象中的文档对象

  doc:=IEThis.Document as IHTMLDocument2;

  //获得文档中所有的HTML元素集合

  all:=doc.Get_all;

  len:=all.Get_length;

  //访问HTML元素集合中的每一个元素

  for i:=0 to len-1 do begin

   item:=all.item(i,varempty) as IHTMLElement;

   //如果该元素是一个链接

   if item.Get_tagName = 'A'then begin

    flag:=0;

    vAttri:=item.getAttribute('protocol',flag);   //获得链接属性

    //如果是mailto链接则将链接的目标地址添加到ComboBox1

    if vAttri = 'mailto:'then begin

     vAttri:=item.getAttribute('href',flag);

     ComboBox1.Items.Add(vAttri);

    end;

   end;

  end;

 end;

end;

end.

编译工程，关闭所有的IE窗口，然后点击Delphi菜单的Run | Register ActiveX Server 项注册服务器。然后打开IE，点击菜单 察看 | 工具栏 项，可以看到子菜单中多了一个GetMailAddress项，选中改项，工具栏就出现在IE工具栏中