COM基础（一）

在本章中，将学习一些COM的基础知识和概念。例如COM对象、接口、COM服务器、COM服务器线程、GUID等等。然后还会介绍两个COM实例。
简单的说，COM（Component Object Model）是一项通过边界透明地传递封装数据的技术。不论这种边界是独立的模块、线程、进程甚至机器。COM对象是独立于语言和操作平台的，也就是说，如果我们使用Delphi编写的COM对象可以在在Windows9X、WinNT等等平台上发布（有消息说Microsoft将把COM技术扩展到Unix平台上，但是现在COM/DCOM/COM+技术只能应用于Windows平台）。而且该组件可以使用VC、VB、VFoxpro等编程语言实例化。建立COM对象同Delphi中的类有一些相似并密切相关，但是也有很大的区别。在后面我们要接触的ActiveX、DCOM、MTS、MIDAS等技术都与COM有关，现在几乎所有的Microsoft的软件都是基于COM技术的。所以在掌握Windows下的分布式程序开发前需要首先掌握COM的一些基本知识。

1.1 COM与Object Pascal
接口(Interface)
一个COM对象是实现一个或者若干个接口的对象，或者说COM对象借助接口来输出它所提供的服务。接口可以使调用COM对象的程序和COM对象的功能之间进行通信。下面是一个接口的定义：

type IDSort = interface Function fSort:Integer; End;

了解接口的比较简单的方法是它多少等同与Object Pascal中的抽象类。接口被声明为interface类型，一般的惯例是：接口的名称从字母I开始。一个接口实例是不能够被直接创造的，例如：

var mID: IDSort; begin mID:=IDSort.Create; end;

但是接口并不是一个类，而是一个预先定义的协议。直接创建接口是非法的，接口中定义的方法必须在类对象中被实现。例如：

type TMySort=class(TInterfacedObject,IDSort) Function fSort:Integer; end;

上面的代码从TInterfacedObject派生一个实现IDSort的类TMySort。然后在程序的implementation部分实现TMySort的fSort方法，例如：

function TMySort.fSort:Integer; begin Result:=1; end;

最后再通过Create建立TMySort类:

Var FIn: TMySort Begin FIn:=TMySort.Create; FIn.fSort; FIn.Free;   End;

使用接口要了解到以下四点：
l  接口不是类   通过类可以生成对象，而接口不能实例化，因为没有实现方法，类实现接口定义。这个类必须要实例化才能成为提供接口的对象。
l  接口不是对象  接口只是对象与调用者之间的协议。客户端访问对象时，只有一个接口指针用于访问接口中的内容。指针是不透明的，通过指针你无法看到任何对象的内部细节，例如对象的状态信息。客户端只能调用接口函数，但这并不是一个限制，因为这个特性使得COM对象提供了地址透明性以及有效的二进制标准。
l  接口是唯一的  每一个接口都有自己的GUID，保证不会与其它接口发生冲突
l  接口是不可变的  接口没有版本，接口添加、删除或者修改了功能之后成为了全新的接口，并指定新的接口标识符，因此，新接口和旧接口并不产生冲突。如果需要 增强功能，可以通过派生的方法来实现新接口。

IUnknown接口
所有的COM接口都从IUnknown直接或者间接继承。IUnknown接口在System.pas单元中声明，声明代码如下：

IUnknown = interface ['{00000000-0000-0000-C000-000000000046}'] function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall; function _AddRef: Integer; stdcall; function _Release: Integer; stdcall; end;

下面来了解一下IUnknown接口，在接口中定义了三个函数：QueryInterface、_AddRef和_Release。
1、  QueryInterface
QueryInterface是请求指向一个接口指针的函数。如果接口是由Obj对象实现的，返回Obj参数中的接口并且返回值为S_OK。如果不是，则返回Microsoft定义的常量：E_NOINTERFACE。这些值在Delphi中有定义。
2、_AddRef和_Release
这两个函数分别用于增加和减少引用计数器的值。当客户需要使用接口时调用_AddRef函数。不再使用接口时调用_Release。不过很幸运的一点是，Delphi提供了实现IUnknown接口的类从而使我们在编程时不太需要考虑增加和减少引用计数器的问题（这在VC++中都没有实现，而需要自己编写引用记数的代码）。在下面的章节中我们将看到这一点。

GUID
从声明中你可能注意到了第二行的一长串数字。这就是IUnknown接口的全局统一标示符(Globally Unique Identifier)。缩写为GUID。所有的COM接口需要一个唯一的GUID才能运行。
GUID是一个16字节的数字。创建GUID的算法十分复杂。如果你的计算机中安装了网卡的话，算法会根据你网卡MAC地址作为生成种子之一从而生成一个唯一的、不会在其它机器上出现的GUID。即使没有，由于GUID的位数之大，基本上不可能产生重复的GUID。如果GUID用在接口中的话，也称作IID。
在Delphi中，GUID数据通过TGUID纪录来表示，该纪录在System单元中定义如下：

PGUID = ^TGUID; TGUID = packed record D1: LongWord; D2: Word; D3: Word; D4: array[0..7] of Byte; end;

在Dephi中如果要生成一个GUID，只需要把光标定位在要插入GUID的地方，并按下Ctrl+Shift+G键就可以了。而且在Delphi中建立通过COM Object Wizard生成一个COM对象时，Delphi会自动生成GUID。

技巧与提示
  GUID命名规则
  代表COM对象的GUID称为CLSID(Class ID)。除了CLSID以外，由于一个COM对象还拥有接口，因此在COM组件模型中也适用 GUID来表示接口，称为IID(Interface ID)。除此以外，在COM组件模型中还有其它的GUID：
  CLSID(Class ID) 标示一个COM对象
  IID(Interface ID) 标示一个COM对象的接口，对于COM对象中的多个接口，每一个接口都有一个IID。
  APPID(Application Identifier) 应用程序ID。
  CATID(Categoy Identifier) COM组件实现的组件类型。
  LIBID(Library Identifier) COM对象实现的Type Library代表的ID。


  虽然说只要实现了IUnknown接口便可以称为是COM对象，但是我们之所以要编写COM对象便是需要它提供特定的服务以便让其它的应用程序可以调用，以使用该组件提供的服务。因此一个COM对象通常会提供其它的客户化接口以便提供特定的服务，并且在组件中实现这些接口所定义的方法、属性以及事件等。如下图所示：

图 1-1 COM通过接口来提供服务

1.2COM对象的实现实例
再前面讲到过，COM是实现一个或者几个接口的对象。一个COM对象位于EXE文件或者DLL文件中，位于DLL中的COM对象称为进程内服务器；位于EXE中的称为进程外服务器。后面将简要的讨论进程外服务器和进程内服务器。在本章中主要接触进程内服务器。
如果要编写可以与任何语言兼容的COM对象，则必须从TComObject中派生类。TComObject的声明在comobj.pas中。该结构的定义很复杂，但是绝大多数的我们不需要处理，因为Delphi已经为我们提供了实现，我们所要做的只是从TComObject类中派生COM对象。

类工厂
COM对象不是由应用程序直接建立实例的。相反，COM使用类工厂来创建对象。类工厂是一个用于创建其它对象的对象。每一个COM对象都有一个相关的类工厂对象。在通过COM Object Wizard建立COM对象时，Delphi自动生成代码在COM服务器初始化时来创建类工厂并通过类工厂创建COM对象，在Delphi中注册TCOMObject类的类工厂类是TComObjectFactory类。该类在comobj.pas中有定义：

TComObjectFactory = class(TObject, IUnknown, IClassFactory, IClassFactory2)

TComObjectFactory类从TObject中继承并实现IUknown、IClassFactory、和IClassFactory2接口。

COM对象建立实例
下面我们首先来建立一个简单的进程内的COM服务器。这个服务器只包含一个TMySort类的COM组件，该类从TComObject类中继承并且实现预先定义的IMySort接口。然后将程序编译并注册。然后再建立一个客户程序访问服务器中的COM对象。
首先打开Delphi，选择菜单中的File | New 项，在New Items(在Delphi中的正式称呼为Object Repository，在本文中使用窗口标题来称呼)选择窗口中选择ActiveX页面。选择其中的ActiveX Library后按确定按钮。这样就建立了一个进程内服务器的工程文件框架，将工程文件保存为SortServ.dpr。文件代码如下：

library SortServ; uses ComServ; exports DllGetClassObject, DllCanUnloadNow, DllRegisterServer, DllUnregisterServer; {$R *.RES} begin end.

在上面代码中Delphi生成了4个输出函数，它们的缺省实现已经由Delphi中的comserv.pas实现了。在这里介绍一下它们的用途。
DllRegisterServer：在COM对象被注册时调用，这个调用可能来自IDE中的Register ActiveX Server菜单项，也可能来自Windows命令行应用程序Regsvr32.Exe。无论通过何种方式调用，DllRegisterServer都将通过修改Windows注册表来注册COM对象。
DllUnregisterServer：DllRegisterServer过程的逆过程，它将DllRegisterServer过程在注册表中建立的项删除。
DllGetClassObject：DllGetClassObject负责提供给COM一个类工厂，该类工厂用于创建一个COM对象。每个COM服务器将实现它输出的每个COM对象的一个类工厂。
DllCanUnloadNow：COM负责调用DllCanUnloadNow来看是否可以从内存中卸载COM服务器。如果在此服务器中任何应用程序都有针对每个COM对象的引用，DllCanUnloadNow返回S_FALSE。如果此服务器中对于任何COM对象都没有打开的引用，那么DllCanUnloadNow返回S_TRUE，并从内存中移走COM服务器。

1.2.1 建立COM服务器
下面建立COM服务器对象，点击菜单 File | New 项，在New Items窗口中选择ActiveX页面，选择其中的COM Object项后点OK键启动COM Object Wizard。Wizrad窗口如下图所示：

图1-2  COM Object Wizard图示

其中Class Name指定新建立的类的名称。在这里我们添入MySort。Instancing指定COM对象的实例类型。它的选择以及定义如下：

Internal  只能建立内在的对象实例。外部程序不能够直接建立对象的实例。
Single Instance  每一个应用程序只能够建立一个COM对象。如果要建立多个COM对象实例必须执行多个应用程序。
Multiple Instance  该定义可以让多个应用程序同时与COM对象建立连接。缺省的实例类型是Multiple Instance。

Threading Model 指定COM对象使用的线程支持模式，这个选择对于组件的性能有比较重要的影响。线程支持只支持进程内服务器，不支持进程外服务器。进程内服务器可以附在几个线程模式中的一个。进程内服务器的线程模式保存在Windows注册表中。可支持的线程模式有：

现在的应用支持的几乎都是Apartment模式。在这里我们也选择Apartment模式。

下一步将COM Object Wizard中Options框中的两个Include Type Library和Makeinterface OleAutomation两个复选框中的选中标记都去掉后按OK按钮。这样Delphi就建立了一个新的Unit，代码如下：

unit Unit1; interface uses Windows, ActiveX, Classes, ComObj; type TMySort = class(TComObject) protected end; const Class_MySort: TGUID = '{DC29E6B7-F51D-4BB7-A5DC-02F291266C9E}'; implementation uses ComServ; initialization //初始化时通过类工厂建立COM对象实例 TComObjectFactory.Create(ComServer, TMySort, Class_MySort, 'MySort', '', ciMultiInstance, tmApartment); end.

将文件以Unit1.pas保存。我们可以看到其中包括一个新的类TMySort。这是通过向导产生的，Class_MySort是本COM服务器的GUID。在单元的初始化部分是一个建立类工厂TComObjectFactory类的Create方法。TObjectFactory的Create方法定义如下：

constructor Create(ComServer: TComServerObject; ComClass: TComClass; const ClassID: TGUID; const ClassName, Description: string; Instancing: TClassInstancing; ThreadingModel: TThreadingModel = tmSingle);

其中参数ComServer定义COM服务器对象，在程序总一般都要设定为ComServer，参数ComClass指定要建立的类，在上面的程序中我们指定为TMySort，参数ClassID 指定类的GUID，在程序中我们指定为类TMySort的GUID Class_MySort，参数ClassName指定类的名称，参数Description指定对类的描述信息，参数Instancing指定实例类型，在程序中我们指定为ciMultiInstance，参数ThreadingModel指定线程模型，在定义中缺省是tmSingle，单线程，在程序中我们指定为tmApartment。


下面的程序清单1-1到1-3是SortServ的全部源程序

程序清单1-1  SortServ.dpr library SortServ; uses ComServ, Unit1 in 'Unit1.pas', SortInterface in 'SortInterface.pas', SortServ_TLB in 'SortServ_TLB.pas'; exports DllGetClassObject, DllCanUnloadNow, DllRegisterServer, DllUnregisterServer; {$R *.TLB} {$R *.RES} begin end.

上面程序段中的引用文件SortServ_TLB.pas是Delphi自动建立的。其中包含COM服务器SortServ的相关信息。

程序清单1-2  Unit1.Pas unit Unit1; interface uses Windows, ActiveX, Classes, ComObj,SortInterface; type TMySort = class(TComObject,IMySort) protected FItems:array[0..19]of integer; FPoint:Integer; Public constructor Create; procedure SetValue(iVal:Integer); function GetSize:Integer; function GetVal(iInd:Integer):Integer; procedure BeginSort; procedure ClearStack; end; implementation uses ComServ; constructor TMySort.Create; begin //建立类时将FPoint设置为0 FPoint:=0; end; procedure TMySort.ClearStack; begin FPoint:=0; end; procedure TMySort.SetValue(iVal:Integer); begin //将新数值添加到数组中 if FPoint<20 then begin FItems[FPoint]:=iVal; FPoint:=FPoint+1; end; end; function TMySort.GetSize:Integer; begin //返回数组中数值的个数 Result:=FPoint; end; function TMySort.GetVal(iInd:Integer):Integer; begin //返回数组中各个数值 if ((iInd>=0) and (iInd<=FPoint)) then Result:=FItems[iInd] else Result:=0; end; procedure TMySort.BeginSort; var i,j,Temp:Integer; begin //利用简单的冒泡法对数组进行排序 for i:=0 to FPoint do for j:=FPoint downto i+1 do begin if FItems[j]<FItems[j-1] then begin Temp:=FItems[j]; FItems[j]:=FItems[j-1]; FItems[j-1]:=Temp; end; end; end; initialization TComObjectFactory.Create(ComServer, TMySort, Class_IMySort, 'MySort', '', ciMultiInstance, tmApartment); end.

程序清单1-3  SortInterface.pas unit SortInterface; interface type IMySort=interface ['{BB99371A-A959-40EB-ACA2-5734F3F5B471}'] procedure SetValue(iVal:Integer); function GetSize:Integer; function GetVal(iInd:Integer):Integer; procedure BeginSort; procedure ClearStack; end; const Class_IMySort:TGUID='{BB99371A-A959-40EB-ACA2-5734F3F5B471}'; implementation end.

将IMySort接口的定义和GUID放到一个单独的、名称为SortInterface.pas的文件中使它们更容易在客户代码中引用。

提示
SortInterface.pas中的GUID是作者生成的，不要直接抄到你的代码中而要通过Delphi快捷键Ctrl+Shif+G生成一个新的。而且不要直接从其它代码中拷贝GUID而要自己生成，这是一个好习惯。

下面来简单的讨论一下代码，主要是Unit1.pas中TMySort实现IMySort的部分。在TMySort中包含两个protected定义：

FItems:array[0..19]of integer; FPoint:Integer;

其中前者用于保存数组，后者用于指示当前数组中放入的数的数量。在类的Create方法中程序将FPoint设置为0。客户程序可以调用TMySort.SetValue(iVal:Integer)来向COM对象的FItems数组中放置数字。通过TMySort.BeginSort来对COM对象中的数组中的数字进行排序。通过TMySort.GetVal(iInd:Integer):Integer来获得数组中的某个位置上的数字。
点击菜单 Project | Build SortServ 编译工程生成COM服务器SortServ.dll。再点击菜单项 Run | Register ActiveX Server 注册服务器。如果注册成功，会弹出如下的对话框提示注册成功。

图1-3  注册成功的图示

当类注册成功后，系统会在注册表的HKEY_CLASSES_ROOT/CLSID/{类GUID}下建立注册项。我们可以运行RegEdit打开注册表看一下，打开注册表的HKEY_CLASSES_ROOT/CLSID/{BB99371A-A959-40EB-ACA2-5734F3F5B471}项我们可以看到COM服务器在注册表中的纪录:

图 1-4  注册表中的注册项

  其中的 默认 项中的内容指定类所在的DLL文件位置。参数ThreadingModel指定类的线程类型，客户端的调用将通过该项获得类的线程类型。

1.2.2 建立客户端程序
下面是建立客户端程序，首先在SortServ工程文件目录下生成一个名称为Client的子目录，点击Delphi菜单项的File | New Application 项建立一个应用程序。在Form1中添加3个TButton组件、一个TListBox组件和一个TLabel组件，将工程保存在Client目录下，将工程文件保存为ClientPrj.dpr，将Unit1保存为Client.Pas。在ClientPrj和Client中都加入对前面建立的SortInterface.pas的引用。ClientPrj和Client的代码清单如下：

程序清单1-4  ClientPrj.dpr program ClientPrj; uses Forms, Client in 'Client.pas' {Form1}, SortInterface in '../SortInterface.pas'; {$R *.RES} begin Application.Initialize; Application.CreateForm(TForm1, Form1); Application.Run; end.

程序清单1-5  Client.Pas unit Client; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, SortInterface, ComObj,ComCtrls,StdCtrls; type TForm1 = class(TForm) btnAdd: TButton; btSort: TButton; ListBox1: TListBox; btnClear: TButton; Label1: TLabel; procedure btnAddClick(Sender: TObject); procedure FormCreate(Sender: TObject); procedure btnClearClick(Sender: TObject); procedure btSortClick(Sender: TObject); private FSort:IMySort; { Private declarations } public { Public declarations } end; var Form1: TForm1; implementation {$R *.DFM} procedure TForm1.btnAddClick(Sender: TObject); var xc:Integer; begin Randomize; xc:=Random(1000); FSort.SetValue(xc); ListBox1.Items.Add(IntToStr(xc)); Label1.Caption:=IntToStr(FSort.GetSize); end; procedure TForm1.FormCreate(Sender: TObject); begin FSort:=CreateComObject(Class_IMySort) as IMySort; end; procedure TForm1.btnClearClick(Sender: TObject); begin FSort.ClearStack; ListBox1.Clear; end; procedure TForm1.btSortClick(Sender: TObject); var i:Integer; begin FSort.BeginSort; ListBox1.Clear; for i:=0 to FSort.GetSize -1 do ListBox1.Items.Add(IntToStr(FSort.GetVal(i))); end; end.

运行程序，点击添加按钮就可以向COM对象数组添加一个数字，点击排序按钮执行COM对象的排序方法。程序运行如下图所示：

图 1-5 运行中的客户程序

分析上面的程序，单元SortInterface定义了接口IMySort。单元Unit1中的类TMySort是一个从TComObject继承的类并实现了IMySort接口。
在COM对象编译并注册后，在客户端引用接口定义单元SortInterface。定义一个IMySort接口对象FSort并在程序启动时利用CreateComObject函数将接口实例化。然后就可以调用IMySort接口提供的方法。客户端就是通过接口来实现获得COM服务器提供的功能的。
CreateComObject函数根据参数指定的GUID值返回该COM对象的IUnknown指针。然后在程序中我们使用 As 函数将返回的接口强制转换为IMySort接口，CreateComObject函数在comobj.pas中的定义如下：

function CreateComObject(const ClassID: TGUID): IUnknown; begin OleCheck(CoCreateInstance(ClassID, nil, CLSCTX_INPROC_SERVER or CLSCTX_LOCAL_SERVER, IUnknown, Result)); end;

从上面的定义我们可以看到，实际上CreateComObject是调用了CoCreateInstance函数来将对象实例化的。上面已经提到，COM对象不能被直接建立而必须通过类工厂来建立，实际上CoCreateInstance函数内部调用了IClassFactory接口的方法，该接口定义如下：

IClassFactory = interface(IUnknown) ['{00000001-0000-0000-C000-000000000046}'] function CreateInstance(const unkOuter: IUnknown; const iid: TIID; out obj): HResult; stdcall; function LockServer(fLock: BOOL): HResult; stdcall; end;

其中真正将对象实例化的是CreateInstance方法，LockServer方法使COM服务器保持在内存中。
除了通过CreateComObject方法将对象实例化的方法以外，我们还可以使用直接分配的方法来建立对象，在上面的程序，我们可以将FSort定义为TMySort类型的对象变量：

private FSort:TMySort;

然后在Form1建立时通过TMySor类的Create方法建立对象：

procedure TForm1.FormCreate(Sender: TObject); begin FSort:=TMySort.Create; end;

在Form1退出时释放FSort:

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction); begin if Assigned(FSort)then FSort.Free; end;

除此以外，在程序中访问FSort的语句不用改变。这个方法建立FSort同我们在使用Delphi建立一个组件对象，例如TForm、TButton的方法是一样的，同样，在不需要对象的时候，需要使用Free方法来释放对象。而在前面将FSort定义为IMySort再通过CreateComObject将对象实例化的方式不需要释放对象的语句，在前面我们说了，当接口被引用时，将引用计数器加1，当不再需要接口时将引用计数器减1，当引用计数器为0时，接口被释放。而Delphi在幕后对于对象的引用做了大量的工作，使我们不需要手工的通过_AddRef或者_ReleaseRef方法来操作引用计数器。如果你需要强迫销毁一个接口，只需要将接口变量赋值为nil，例如：

FSort:=nil;

通过上面的介绍和范例，我们对COM对象是如何实现以及如何工作的已经有了一定的了解。通过上面的范例还可以看到，了解了COM的工作原理后，建立一个COM服务器其实是比较容易的事情。Delphi5能够替我们完成绝大部分的框架的和幕后的工作。一般情况下我们只要编写接口实现的部分就可以了。事实上，在以后的文章中我们可以看到，利用Delphi实现COM比使用微软的开发工具，如VC、VB来的要方便和灵活的多。Delphi可以自动为我们需要的组件建立框架，我们只需要填写实现代码就可以了，而且这些框架代码我们也是可以根据需要通过手工来更改的。
下面是编写COM服务器的扩展应用，利用Delphi编写COM服务器实现IE扩展功能。

1．3通过COM编程实现IE扩展
通过上面的介绍和范例，我们已经了解了实现并使用进程内COM服务器。在这一部分里，我们将通过一个实例来编写COM服务器实现IE扩展。
我们知道一些Internet软件能将自身功能集成在IE中，象网络蚂蚁。当设置了浏览器点击整合以后。如果用户点击IE页面中的指向.Exe、.Zip文件的连接后，蚂蚁会自动启动，下载连接指向地址的文件。这就是利用了IE扩展的功能实现的。
实现IE扩展的基本方法如下：建立一个COM服务器，编写代码使COM对象实现系统规定的若干接口（这些接口在Delphi的库中已经定义好了）。然后注册服务器并将COM对象的信息写入系统注册表中规定的位置。IE在运行时会通过注册表信息调用相应的COM对象中的方法从而实现IE扩展。
在下面的实例中，将建立一个IE工具栏(Explorer Bars)。在工具栏中放置一个按钮和一个下拉框，当用户点击按钮后，程序会自动获取IE页面中的所有电子邮件地址连接并将它添加到下拉列表框中。在这个范例内可以学习到如何在一个COM服务器中建立多个COM对象、在COM对象中实现多接口以及一些InternetExplorer对象的编程方法。

需要实现的接口
实现添加工具栏功能的COM对象需要实现以下的接口：

IDeskBand IObjectWithSite IPersistStream

IDeskBand接口用于处理工具栏，例如工具栏大小的改变，用户选择显示或隐藏工具栏等。接口在ShlObj.pas下有定义。
IObjectWithSite接口用于处理包含工具栏的对象， 在ActiveX.pas下有定义。
IPersistStream接口用于处理附加的信息。该接口并不需要，所以所有的方法都返回E_NOTIMPL，接口在ActiveX.pas下有定义。
这些接口的详细信息在微软的MSDN中都有详细的描述以及范例。

提示
MSDN(Microsoft Develop Network)是微软提供的Windows开发手册，也是最完整和翔实的Windows开发手册，包含了开发微软各个系统的帮助，Bug列表，范例等等。对于Windows下的程序员，无论是否使用微软的开发工具，都应该在自己的机器中安装MSDN。
    
IE扩展的实现
同上面建立COM服务器一样，我们首先要建立一个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工具栏中，如图：

图1-6  IE工具栏

点击 获取地址 按钮，就可以将当前页面中的Mail地址统统添加到ComboBox1中。
注意上面的IEForm.pas引用到了MSHTML，微软IE的整个结构如下图所示：

图1-7  IE基本架构

其中MSHTML是位于SHDOCVW和HTML页面之间的对象。SHDOCVW对象用于处理页面的显示，而MSHTML用于处理页面的语法分析。它可以将页面中的标记（例如<P></P>、< A href></A>）转换为元素，同时它MSHTML又是一个COM服务器，允许客户端访问。所以上面TForm1.Button1Click部分的代码：

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;

就是通过MSHTML定义的接口访问页面中的元素并获得链接元素中的地址。