如何初始化同COM交互的线程？
通常如果没有初始化线程会显示如下的错误信号："CoInitialize has not been called" (800401F0 ) 。
问题在于每个同COM交互的线程必须使自身初始化并进入一个Apartment。可以通过加入一个单线程的 Apartment (STA)获得，也可以进入一个多线程的Apartment (MTA)。
STA是基于Windows的消息队列实现系统同步的。当COM对象或线程是依赖于线程相关的对象时，比如界面元素，就应该使用STA，下面演示如何初始化一个线程进入STA：
procedure FooThreadFunc;
Begin
CoInitializeEx (NIL, COINIT_APARTMENTTHREADED);
... ...
CoUninitialize;
end;
处于MTA的对象则可以随时随地收到用户的调用，对象同界面元素无关时应该使用MTA模式，但一定要小心地控制同步，下面是演示如何初始化一个进入MTA的线程：
procedure FooThreadFunc;
begin
CoInitializeEx (NIL, COINIT_MULTITHREADED);
... ...
CoUninitialize;
end;
实现、跨越Apartment列集接口指针
在运行COM Server时经常会遇到"The application called an interface that was marshaled for a different thread" (8001010E)这类错误，它是如何产生的呢?
在Apartment之间传递接口指针的时候,如果没有执行Marshal(列集)，就会破坏COM的线程规则，引起这个错误。列集接口指针需要使用CoMarshalInterface 和CoUnmarshalInterface函数。但实际使用时，我们更多的是用更简单的CoMarshalInterThreadInterfaceInStream 和 CoGetInterfaceAndReleaseStream API。
下面的代码演示了如何在基于不同Aparment的Foo1和Foo2线程之间列集一个接口指针：
var MarshalStream : pointer;
//源线程
procedure Foo1ThreadFunc; //或者TFoo1.Execute
var Foo : IFoo;
begin
//假设Foo2Thread正处于暂停状态
CoInitializeEx (...);
Foo := CoFoo.Create;
//列集
CoMarshalInterThreadInterfaceInStream (IFoo, Foo, IStream (MarshalStream));
//告诉Foo2Thread 列集完毕
Foo2Thread.Resume;
CoUninitialize;
end;
//用户线程
procedure Foo2ThreadFunc; //或TFoo2.Execute
var Foo : IFoo;
begin
CoInitializeEx (...);
//逆列集
CoGetInterfaceAndReleaseStream (IStream (MarshalStream), IFoo, Foo);
MarshalStream := NIL;
//使用Foo
Foo.Bar;
CoUninitialize;
end;
上面的列集技术是列集一次然后逆列集一次。如果我们想列集一次然后多次逆列集的话，可以使用(NT 4 SP3) COM提供的全局接口表（Global Interface Table，GIT）。GIT允许列集一个接口指针到一个cookie，然后使用这个Cookie来多次逆列集。使用GIT的话，上面的例子要修改为：
const
CLSID_StdGlobalInterfaceTable : TGUID =
'{00000323-0000-0000-C000-000000000046}';
type
IGlobalInterfaceTable = interface(IUnknown)
['{00000146-0000-0000-C000-000000000046}']
function RegisterInterfaceInGlobal (pUnk : IUnknown; const riid: TIID;
out dwCookie : DWORD): HResult; stdcall;
function RevokeInterfaceFromGlobal (dwCookie: DWORD): HResult; stdcall;
function GetInterfaceFromGlobal (dwCookie: DWORD; const riid: TIID; out ppv): HResult; stdcall;
end;
function GIT : IGlobalInterfaceTable;
const
cGIT : IGlobalInterfaceTable = NIL;
begin
if (cGIT = NIL) then
OleCheck (CoCreateInstance (CLSID_StdGlobalInterfaceTable, NIL, CLSCTX_ALL,
IGlobalInterfaceTable, cGIT));
Result := cGIT;
end;
var MarshalCookie : dword;
//源线程
procedure Foo1ThreadFunc;
var Foo : IFoo;
begin
CoInitializeEx (...);
Foo := CoFoo.Create;
//列集
GIT.RegisterInterfaceInGlobal (Foo, IFoo, MarshalCookie)
//告诉Foo2Thread MarshalCookie已经准备好了
Foo2Thread.Resume;
CoUninitialize;
end;
//用户线程
procedure Foo2ThreadFunc;
var Foo : IFoo;
begin
CoInitializeEx (...);
//逆列集
GIT.GetInterfaceFromGlobal (MarshalCookie, IFoo, Foo)
//调用Foo
Foo.Bar;
CoUninitialize;
end;
另外当不需要列集的时候，不要忘了从GIT中删除指针：
GIT.RevokeInterfaceFromGlobal (MarshalCookie);
MarshalCookie := 0;
下面实现了一个TGIP类可以简化调用：
{ TGlobalInterfacePointer
用法：假定有一个接口指针pObject1,想使接口Iobject1全局化可以使用下面的代码
var
GIP1: TGIP;
begin
GIP1 := TGIP.Create (pObject1, IObject1);
end;
如果想使pObject1本地化，需要直接存取GIP1 对象变量：
var
pObject1: IObject1;
begin
GIP1.GetIntf (pObject1);
pObject1.DoSomething;
end;
}
下面是TGIP类的实现：
TGIP = class
protected
FCookie: DWORD;
FIID: TIID;
function IsValid: boolean;
public
constructor Create (const pUnk: IUnknown; const riid: TIID);
destructor Destroy; override;
procedure GetIntf (out pIntf);
procedure RevokeIntf;
procedure SetIntf (const pUnk: IUnknown; const riid: TIID);
property Cookie: dword read FCookie;
property IID: TGUID read FIID;
end;
{ TGIP }
function TGIP.IsValid: boolean;
begin
Result := (FCookie <> 0);
end;
constructor TGIP.Create (const pUnk: IUnknown; const riid: TIID);
begin
inherited Create;
SetIntf (pUnk, riid);
end;
destructor TGIP.Destroy;
begin
RevokeIntf;
inherited;
end;
procedure TGIP.GetIntf (out pIntf);
begin
Assert (IsValid);
OleCheck (GIT.GetInterfaceFromGlobal (FCookie, FIID, pIntf));
end;
procedure TGIP.RevokeIntf;
begin
if not (IsValid) then Exit;
OleCheck (GIT.RevokeInterfaceFromGlobal (FCookie));
FCookie := 0;
FIID := GUID_NULL;
end;
procedure TGIP.SetIntf (const pUnk: IUnknown; const riid: TIID);
begin
Assert ((pUnk <> NIL) and not (IsEqualGuid (riid, GUID_NULL)));
RevokeIntf;
OleCheck (GIT.RegisterInterfaceInGlobal (pUnk, riid, FCookie));
FIID := riid;
end;
实现正确的错误处理
在COM中,每个接口方法必须返回一个错误代码给客户端，错误代码是标准的32位数值，也就是我们所熟悉的HRESULT。HRESULT数值可以分为几部分：一位用于表示成功或失败，几位用于表示错误分类，剩下几位用于表示错误代号（COM推荐错误代码应该在0200到FFFF 范围内。
虽然HRESULT可以用来指示错误，但是它也有很大的局限性，因为除了错误代码，我们可能还想让COM服务器告诉客户端错误的详细描述、发生位置以及客户在哪儿可以得到更多的相关帮助（通过指定帮助上下文来调用帮助文件）。因此，COM引入了IErrorInfo接口，客户端可以通过这个接口来获得额外的错误信息。同时如果COM服务器支持IErrorInfo，COM同时建议服务器实现ISupportErrorInfo接口，虽然这个接口不是必须实现的，但一些客户端，比如Visual Basic将会向服务器请求这个接口。
Delphi本身已经为我们提供了安全调用处理。当在对象内部产生一个异常时，Delphi会自动俘获异常并把它转化为一个COM HRESULT，同时提供一个IErrorInfo 接口用于传递给客户端。这些是通过ComObj单元中的HandleSafeCallException函数实现的。此外，VCL 类也为我们实现了ISupportErrorInfo 接口。
下面举例来说，当在服务器内部产生一个Ewhatever的异常时，它总会被客户端认为是EOleException异常，EOleException异常包括HRESULT 和IErrorInfo 所包含的所有信息，比如错误代号、描述、发生位置以及上下文相关帮助。而为了提供客户端所需要信息，服务器必须把EWhatever转化为EoleSysError异常，同时要确保错误代码为格式化好的HRESULT。比如，假设有一个TFoo对象，它有一个Bar方法。在Bar方法中我们想产生一个异常，异常的错误代号为5，描述="错误消息"，帮助文件="HelpFile.hlp"，帮助上下文= 1，代码示意如下：
uses ComServ;
const
CODE_BASE = $200; //推荐代码在0200 – FFFF之间
procedure TFoo.Bar;
begin
//帮助文件
ComServer.HelpFileName := 'HelpFile.hlp';
//引发异常
raise EOleSysError.Create (
'错误消息', ErrorNumberToHResult (5 + CODE_BASE), //格式化HRESULT
1 //帮助上下文
);
end;
//格式化Hresult
function ErrorNumberToHResult (ErrorNumber : integer) : HResult;
const
SEVERITY_ERROR = 1;
FACILITY_ITF = 4;
Begin
Result := (SEVERITY_ERROR shl 31) or (FACILITY_ITF shl 16) or word (ErrorNumber);
end;
上面的ErrorNumberToHResult函数就是简单的把错误代号转化为标准的HRESULT。同时给错误代号加上了CODE_BASE (0x200)，以便遵循COM的建议，就是使错误代码位于0200到 FFFF之间。
下面是客户端利用EOleException俘获错误的代码：
const
CODE_BASE = $200;
procedure CallFooBar;
var
Foo : IFoo;
Begin
Foo := CoFoo.Create;
Try
Foo.Bar;
Except
on E : EOleException do
ShowMessage ('错误信息: ' + E.Message + #13 +
'错误代号: ' + IntToStr (HResultToErrorNumber (E.ErrorCode) - CODE_BASE) + #13 +
'发生位置: ' + E.Source + #13 +
'帮助文件: ' + E.HelpFile + #13 +
'帮助上下文: ' + IntToStr (E.HelpContext)
);
end;
end;
function HResultToErrorNumber (hr : HResult) : integer;
begin
Result := (hr and $FFFF);
end;
上述过程其实就是服务器的逆过程，就是从HRESULT中提取错误代码，并显示额外错误信息的过程。
如何实现多重接口
其实非常非常简单，比如想建立一个COM对象，它已经支持IFooBar接口了，我们还想实现两个外部接口IFoo和IBar。IFoo和IBar 接口定义如下：
IFoo = interface
procedure Foo; //隐含返回HRESULT
end;
IBar = interface
procedure Bar;
end;
实现部分：
type
TFooBar = class (TAutoObject, IFooBar, IFoo, IBar)
Protected
//IfooBar
... IFooBar methods here ...
//IFoo methods
procedure Foo;
//IBar methods
procedure Bar;
...
end;
procedure TFooBar.Foo;
begin
end;
procedure TFooBar.Bar;
begin
end;
是不是很简单啊，要注意的是如果IfooBar、IFoo和IBar都是基于IDispatch接口的，TAutoObject 将只会为IFooBar实现IDispatch，基于脚本的客户端只能看到IFooBar接口方法。
Delphi中定义的COM基类的用途
Delphi提供了很多基类用于COM开发：TInterfacedObject、TComObject、TTypedComObject、TAutoObject、TAutoIntfObject、TComObjectFactory、TTypedComObjectFactory、TAutoObjectFactory等。那么这些类适用于哪些条件下呢？
（1）TInterfacedObject
TInterfacedObject 只提供对IUnknown接口的实现，如果想创建一个内部对象来实现内部接口的话，TInterfacedObject 就是一个最好的基类。
（2）TComObject
TComObject实现了IUnknown、ISupportErrorInfo、标准的COM聚集支持和一个对应的类工厂支持。如果我们想创建一个轻量级的可连接客户端的基于IUnknown接口的COM对象的话，COM对象就应该从TComObject 类继承。
（3）TComObjectFactory
TComObjectFactory 是同TComObject对象配合工作的。它把对应的TComObject 公开为coclass。TComObjectFactory 提供了coclass 的注册功能(根据CLSIDs、ThreadingModel、ProgID等)。还实现了IClassFactory 和 IClassFactory2 接口以及标准的COM 对象许可证支持。简单地说如果要想创建TComObject对象，就会同时需要TComObjectFactory对象。
（4）TTypedComObject
TTypedComObject等于TComObject + 对IProvideClassInfo接口的支持。IProvideClassInfo 是自动化的标准接口用来公开一个对象的类型信息的（比如可获得的名字、方法、支持的接口等，类型信息储存在相关的类型库中）。TTypedComObject 可以用来支持那些在运行时能够浏览类型信息的客户端，比如Visual Basic的TypeName 函数期望一个对象能够实现IProvideClassInfo 接口，以便通过类型信息确定对象的文档名称（documented name）。
（5）TTypedComObjectFactory
TTypedComObjectFactory 是和TTypedComObject配合工作的。就等于TComObjectFactory + 提供缓存了的TTypedComObject类型信息（ITypeInfo）引用。一句话，创建TTypedComObject必然会同时创建TypedComObjectFactory 类工厂。
（6）TAutoObject
TAutoObject 等于TTypedComObject + 实现IDispatch接口。TAutoObject适用于实现支持自动化控制的COM对象。
（7）TAutoObjectFactory
TAutoObjectFactory显然是同TAutoObject密不可分的。它等于TTypedComObjectFactory + 提供了TAutoObject的接口和连接点事件接口的缓存类型信息 (ITypeInfo)。
（8）TAutoIntfObject
TAutoIntfObject等于TInterfacedObject +实现了IDispatch接口。同TAutoObject相比， TAutoIntfObject 没有对应的类工厂支持，这意味着外部客户端无法直接实例化一个TAutoIntfObject的衍生类。然而，TAutoIntfObject 非常适合作为基于IDispatch接口的下层对象或属性对象，客户端可以通过最上层的自动化对象得到对它们的引用。
理解列集的概念
在进行COM调用的时候，最经常碰到的错误恐怕就是"Interface not supported/registered" (80004002)错误了。这通常是由于没有在客户端机器上注册类型库导致的。
|
图1.115 |
COM的位置透明性是通过代理和存根对象来实现的。当一个客户端调用一个远程机器上的COM对象（或是另一个Apartment中的COM对象）时，客户端的请求首先通过代理，然后代理再通过COM，然后再通过存根才到达真正的对象，其关系如图1.115所示。
每当客户端调用COM对象的方法时，代理都会把方法参数整理为一个平直数组然后再传递给COM，而COM再把数组传递给存根，由存根负责解包数组还原参数，最后服务器对象才会按参数调用方法，整个过程就成为列集。
注意代理和存根同样是COM对象，系统提供了一个缺省的存根和代理，它们实现在 oleaut32.dll 中，对于大多数的列集处理来说，缺省的存根和代理已经足够用了，但它只能列集那些自动化兼容的数据类型的参数。
在类型库中，必须注释接口定义的[oleautomation]标识，表明我们希望使用类型库列集器来列集我们的接口。[oleautomation]标识适用于任意接口（只要方法参数全是自动化兼容的），认为它只使用于IDispatch类型接口的想法是不正确的。
由于不能像Visual C++那样简单地创建用户定制的代理-存根DLL，所以Delphi严重依赖于类型库列集器实现列集。同时由于类型库列集器的列集依赖于类型库中的信息，所以必须在服务器和客户端的机器上同时注册类型库，否则调用时就会碰到"Interface not supported/registered" 错误。
另外，要注意只有当我们使用前期绑定时才需要注册类型库。如果使用后期绑定（比如variant或双接口绑定），COM会调用IDispatch 接口早已注册在系统中的代理-存根DLL，因此后期绑定时不需要注册类型库文件。
如何实现一个支持Visual Basic的For Each调用的COM对象
熟悉Visual Basic和ASP开发的人一定会很熟悉用Visual Basic的For Each语法调用COM集合对象。
For Each允许一个VB的客户端很方便地遍历一个集合中的元素：
Dim Items as Server.IItems //声明集合变量
Dim Item as Server.IItem //声明集合元素变量
Set Items = ServerObject.GetItems //获得服务器的集合对象
//用 For Each循环遍历集合元素
For Each Item in Items
Call DoSomething (Item)
Next
那么什么样的COM对象支持For Each语法呢？答案就是实现IEnumVARIANT COM接口，它的定义如下：
IEnumVARIANT = interface (IUnknown)
function Next (celt; var rgvar; pceltFetched): HResult;
function Skip (celt): HResult;
function Reset: HResult;
function Clone(out Enum): HResult;
end;
For Each语法知道如何调用IEnumVARIANT 接口的方法（特别是Next方法）来遍历集合中的全部元素。那么如何才能向客户端公开IEnumVARIANT 接口呢，下面是一个集合接口：
//集合元素
IFooItem = interface (IDispatch);
//元素集合
IFooItems = interface (IDispatch)
property Count : integer;
property Item [Index : integer] : IFoo;
end;
要想使用IEnumVARIANT接口，我们的集合接口首先必须支持自动化（也就是基于IDispatch接口），同时集合元素也必须是自动化兼容的（比如byte、BSTR、long、IUnknown、IDispatch等）。
然后，我们利用类型库编辑器添加一个名为_NewEnum的只读属性到集合接口中，_NewEnum 属性必须返回IUnknown 接口，同时dispid = -4 (DISPID_NEWENUM)。修改的IFooItems定义如下：
IFooItems = interface (IDispatch)
property Count : integer;
property Item [Index : integer] : IFoo;
property _NewEnum : IUnknown; dispid -4;
end;
接下来我们要实现_NewEnum属性来返回IEnumVARIANT 接口指针：
下面是一个完整的例子，它创建了一个ASP组件，有一个集合对象用来维护一个email地址列表：
unit uenumdem;
interface
uses
Windows, Classes, ComObj, ActiveX, AspTlb, enumdem_TLB, StdVcl;
type
IEnumVariant = interface(IUnknown)
['{00020404-0000-0000-C000-000000000046}']
function Next(celt: LongWord; var rgvar : OleVariant;
pceltFetched: PLongWord): HResult; stdcall;
function Skip(celt: LongWord): HResult; stdcall;
function Reset: HResult; stdcall;
function Clone(out Enum: IEnumVariant): HResult; stdcall;
end;
TRecipients = class (TAutoIntfObject, IRecipients, IEnumVariant)
protected
PRecipients : TStringList;
Findex : Integer;
Function Get_Count: Integer; safecall;
Function Get_Items(Index: Integer): OleVariant; safecall;
procedure Set_Items(Index: Integer; Value: OleVariant); safecall;
function Get__NewEnum: IUnknown; safecall;
procedure AddRecipient(Recipient: OleVariant); safecall;
function Next(celt: LongWord; var rgvar : OleVariant;
pceltFetched: PLongWord): HResult; stdcall;
function Skip(celt: LongWord): HResult; stdcall;
function Reset : HResult; stdcall;
function Clone (out Enum: IEnumVariant): HResult; stdcall;
public
constructor Create;
constructor Copy(slRecipients : TStringList);
destructor Destroy; override;
end;
TEnumDemo = class(TASPObject, IEnumDemo)
protected
FRecipients : IRecipients;
procedure OnEndPage; safecall;
procedure OnStartPage(const AScriptingContext: IUnknown); safecall;
function Get_Recipients: IRecipients; safecall;
end;
implementation
uses ComServ,
SysUtils;
constructor TRecipients.Create;
begin
inherited Create (ComServer.TypeLib, IRecipients);
PRecipients := TStringList.Create;
FIndex := 0;
end;
constructor TRecipients.Copy(slRecipients : TStringList);
begin
inherited Create (ComServer.TypeLib, IRecipients);
PRecipients := TStringList.Create;
FIndex := 0;
PRecipients.Assign(slRecipients);
end;
destructor TRecipients.Destroy;
begin
PRecipients.Free;
inherited;
end;
function TRecipients.Get_Count: Integer;
begin
Result := PRecipients.Count;
end;
function TRecipients.Get_Items(Index: Integer): OleVariant;
begin
if (Index >= 0) and (Index < PRecipients.Count) then
Result := PRecipients[Index]
else
Result := '';
end;
procedure TRecipients.Set_Items(Index: Integer; Value: OleVariant);
begin
if (Index >= 0) and (Index < PRecipients.Count) then
PRecipients[Index] := Value;
end;
function TRecipients.Get__NewEnum: IUnknown;
begin
Result := Self;
end;
procedure TRecipients.AddRecipient(Recipient: OleVariant);
var
sTemp : String;
begin
PRecipients.Add(Recipient);
sTemp := Recipient;
end;
function TRecipients.Next(celt: LongWord; var rgvar : OleVariant;
pceltFetched: PLongWord): HResult;
type
TVariantList = array [0..0] of olevariant;
var
i : longword;
begin
i := 0;
while (i < celt) and (FIndex < PRecipients.Count) do
begin
TVariantList (rgvar) [i] := PRecipients[FIndex];
inc (i);
inc (FIndex);
end; { while }
if (pceltFetched <> nil) then
pceltFetched^ := i;
if (i = celt) then
Result := S_OK
else
Result := S_FALSE;
end;
function TRecipients.Skip(celt: LongWord): HResult;
begin
if ((FIndex + integer (celt)) <= PRecipients.Count) then
begin
inc (FIndex, celt);
Result := S_OK;
end
else
begin
FIndex := PRecipients.Count;
Result := S_FALSE;
end; { else }
end;
function TRecipients.Reset : HResult;
begin
FIndex := 0;
Result := S_OK;
end;
function TRecipients.Clone (out Enum: IEnumVariant): HResult;
begin
Enum := TRecipients.Copy(PRecipients);
Result := S_OK;
end;
procedure TEnumDemo.OnEndPage;
begin
inherited OnEndPage;
end;
procedure TEnumDemo.OnStartPage(const AScriptingContext: IUnknown);
begin
inherited OnStartPage(AScriptingContext);
end;
function TEnumDemo.Get_Recipients: IRecipients;
begin
if FRecipients = nil then
FRecipients := TRecipients.Create;
Result := FRecipients;
end;
initialization
TAutoObjectFactory.Create(ComServer, TEnumDemo, Class_EnumDemo,
ciMultiInstance, tmApartment);
end.
下面是用来测试ASP组件的ASP脚本：
Set DelphiASPObj = Server.CreateObject("enumdem.EnumDemo")
DelphiASPObj.Recipients.AddRecipient "windows@ms.ccom"
DelphiASPObj.Recipients.AddRecipient "borland@hotmail.com"
DelphiASPObj.Recipients.AddRecipient "delphi@hotmail.com"
Response.Write "使用For Next 结构"
for i = 0 to DelphiASPObj.Recipients.Count-1
Response.Write "DelphiASPObj.Recipients.Items[" & i & "] = " & _
DelphiASPObj.Recipients.Items(i) & ""
next
Response.Write "使用 For Each 结构"
for each sRecipient in DelphiASPObj.Recipients
Response.Write "收信人 : " & sRecipient & ""
next
Set DelphiASPObj = Nothing
上面这个例子中，集合对象储存的是字符串数据，其实它可以储存任意的COM对象，对于COM对象可以用Delphi定义的TInterfaceList 类来管理集合中的COM对象元素。
下面是一个可重用的类TEnumVariantCollection，它隐藏了IEnumVARIANT接口的实现细节。为了插入TEnumVariantCollection 类到集合对象中去，我们需要实现一个有下列三个方法的接口：
IVariantCollection = interface
//使用枚举器来锁定列表拥有者
function GetController : IUnknown; stdcall;
//使用枚举器来确定元素数
function GetCount : integer; stdcall;
//使用枚举器来返回集合元素
function GetItems (Index : olevariant) : olevariant; stdcall;
end;
修改后的TFooItem的定义如下：
type
//Foo items collection
TFooItems = class (TSomeBaseClass, IFooItems, IVariantCollection)
Protected
{ IVariantCollection }
function GetController : IUnknown; stdcall;
function GetCount : integer; stdcall;
function GetItems (Index : olevariant) : olevariant; stdcall;
protected
FItems : TInterfaceList; //内部集合元素列表;
...
end;
function TFooItems.GetController: IUnknown;
begin
//always return Self/collection owner here
Result := Self;
end;
function TFooItems.GetCount: integer;
begin
//always return collection count here
Result := FItems.Count;
end;
function TFooItems.GetItems(Index: olevariant): olevariant;
begin
//获取IDispatch 接口
Result := FItems.Items [Index] as IDispatch;
end;
最后，我们来实现_NewEnum 属性：
function TFooItems.Get__NewEnum: IUnknown;
begin
Result := TEnumVariantCollection.Create (Self);
end;
这就是全部要做的工作。
客户端如何实现对基于IEnumVARIANT-接口的集合对象的枚举？
前面提到了在Visual Basic中，我们可以用For Each结构很简单地实现对基于IEnumVARIANT-接口的集合对象的枚举。那么在Delphi中有没有办法实现类似的操作呢？
答案是有两种方法可以做到，第一种比较困难，它需要我们非常熟悉IEnumVARIANT接口方法的调用，特别是reset和next方法。第二种简单的则是使用TEnumVariant类，它使用起来非常简单，代码示意如下：
uses ComLib;
var
Foo : IFoo;
Item : olevariant;
Enum : TEnumVariant;
Begin
Foo := CreateOleObject ('FooServer.Foo') as IFoo; //or CoFoo.Create
Enum := TEnumVariant.Create (Foo.Items);
while (Enum.ForEach (Item)) do
DoSomething (Item);
Enum.Free;
end;
看起来确实和For Each区别不大了。
如何使用聚集和包含
COM聚集和包含是两种重用COM对象的技术。为了弄清为什么需要使用聚集或包含技术，考虑一下下面的情况：假设现在有两个COM对象Foo (IFoo)和Bar (IBar)。我们想创建一个新的对象FooBar，它提供Foo和Bar两者的功能。那么我们可以这样定义新类：
IFoo = interface
procedure Foo;
end;
IBar = interface
procedure Bar;
end;
type
FooBar = class (BaseClass, IFoo, IBar)
end;
然后就是当实现IFoo接口的方法时重用Foo，当实现Ibar接口的时候重用Ibar。这时就需要聚集和包含了。
1. 包含
包含实际上就是初始化一个内部对象，然后把对接口方法的调用请求都传递给内部对象，如下为实现对IFoo的包含：
type
TFooBar = class (TComObject, IFoo)
Protected
//IFoo methods
procedure Foo;
protected
FInnerFoo : IFoo;
function GetInnerFoo : IFoo;
end;
procedure TFooBar.Foo;
var
Foo : IFoo;
Begin
//获得内部Foo对象
Foo := GetInnerFoo;
//传递方法请求给内部的Foo对象
Foo.Foo;
end;
function TFooBar.GetInnerFoo : IFoo;
begin
//创建内部的Foo对象
if (FInnerFoo = NIL) then
FInnerFoo := CreateComObject (Class_Foo) as IFoo;
Result := FInnerFoo;
end;
如果我们按下面定义实现类的话，由于没有代理接口请求，所以不能认为是包含：
type
TFooBar = class (TComObject, IFoo)
Protected
function GetInnerFoo : IFoo;
property InnerFoo : IFoo read GetInnerFoo implements IFoo;
end;
先前的实现和现在的不同在于代理的问题，前者必须公开了IFoo接口，然后通过Foo方法代理对接口的请求给内部对象，而后者是客户端直接请求InnerFoo提供的IFoo接口方法，没有代理请求的发生，所以不是包含。
2. 聚集
实现包含有时会变得非常烦琐，因为如果内部对象的接口支持大量的方法时，我们必须重复大量的编码工作来实现代理请求。还有很多其他原因使得我们需要聚集，简单地说聚集就是一种直接公开内部对象的机制。
聚集的首要规则是只能聚集那些支持聚集的内部对象，也就是说内部对象知道如何实现代理和非代理的接口请求。
要想了解更多关于代理和非代理的接口请求，参见Dale Rogerson写的《COM奥秘》一书。
第二条规则是当外部对象构建内部对象时，我们需要：
（1）把外部对象的IUnknown 接口作为CoCreateInstance调用的参数传递给内部对象。
（2）请求内部对象的IUnknown接口，而且是要IUnknown接口。
假设Foo对象是支持聚集的，下面让我们把Foo集成到TFooBar对象中。对IFoo的接口请求是通过Delphi的 implements 关键字实现的。代码示意如下：
Type
TFooBar = class (TComObject, IFoo)
Protected
function GetControllingUnknown : IUnknown;
function GetInnerFoo : IFoo;
property InnerFoo : IFoo read GetInnerFoo implements IFoo; //exposes IFoo directly from InnerFoo
protected
FInnerFoo : IUnknown;
end;
function TFoo.GetControllingUnknown : IUnknown;
begin
//返回正确的IUnknown接口
Result := Controller
Else
Result := Self as IUnknown;
end;
function TFooBar.GetInnerFoo : IFoo;
begin
//创建内部Foo对象 object if not yet initialized
if (FInnerFoo = NIL) then
CoCreateInstance (
CLASS_Foo, //Foo的CLSID
GetControllingUnknown, //传递Iunknown接口给内部对象
CLSCTX_INPROC, //假设Foo是进程内的
IUnknown, //请求Foo的Iunknown接口
FInnerFoo //输出内部Foo对象
);
//返回内部Foo对象
Result := FInnerFoo as IFoo;
end;
Delphi的TComObject 已经实现了内建的聚集特性，同时任何从TComObject继承的COM对象也支持聚集。同时不要忘记如果内部对象不支持聚集，那么这时我们只能使用包含。
理解类工厂的实例属性(SingleInstance, MultiInstance)
（1）类工厂的实例属性只对EXE类型的Server有作用。
（2）实例属性并不是EXE Server的属性也不是COM对象的属性而是类工厂的属性。它决定的是类工厂如何响应客户端的请求来创建对象的方式。所以所谓“一个Server生成一个对象和一个Server创建多个对象”的说法是完全错误的。
实例属性的真正意义其实是：
每一个COM服务器中的对象都会有一个相应的类工厂，每当客户端请求创建服务器中的对象时，COM将会要求对象的类工厂来创建这个对象。当EXE型的Server运行时会注册类工厂（当Server结束时又会被注销），类工厂的注册有三种实例模式：SingleUse、MultiUse和MultiSeparateUse。这里我们只讨论SingleUse和MultiUse这两种最常用的模式。
SingleUse意味着类工厂只创建最多一个相应对象的实例。在一个SingleUse的类工厂创建完它的一个实例后，COM将会注销它。因此，当下一个客户端请求创立一个对象时，COM 无法找到已注册的类工厂，它就会启动另一个EXE Server来获得新的类工厂，这就意味着如果前一个EXE Server运行没有结束，这时系统中会有两个EXE Server在同时运行。
MultiUse则意味着可以创建任意多个类工厂的实例。这意味着只要EXE Server不终止运行，则COM就不会注销类工厂，也就是说同时只可能有一个EXE Server运行并响应客户端创建相应对象的请求。
对于Delphi来说，实例模式相当于：
ciSingleInstance = SingleUse
ciMultiInstance = MultiUse
如何实现支持GetActiveObject函数的COM服务器
对于Microsoft Office来说，可以通过GetActiveObject函数获得系统中激活的Office程序：
var
Word : variant;
Begin
//连接到正在运行的Word实例，
//如果没有运行的实例，会产生异常
Word := GetActiveOleObject ('Word.Application');
end;
那么GetActiveOleObject函数是如何知道word是否正在运行的呢？又该如何实现支持GetActiveOleObject函数的COM Server呢？
需要把我们的COM Server注册到COM的运行对象表中去（Running Object Table，ROT），这可以通过调用RegisterActiveObject API实现：
function RegisterActiveObject (
unk: IUnknown; //要注册的对象
const clsid: TCLSID; //对象的CLSID
dwFlags: Longint; //注册标志通常使用ACTIVEOBJECT_STRONG
out dwRegister: Longint //成功注册后返回的句柄
): HResult; stdcall;
有注册自然就应该有撤消注册，撤消注册可以使用RevokeActiveObject API：
function RevokeActiveObject (
dwRegister: Longint; //先前调用RegisterActiveObject时返回的句柄
pvReserved: Pointer //保留参数，须设为nil
): HResult; stdcall;
要注意的是把一个COM对象注册到ROT中去，意味着只有当服务器从ROT撤消注册后，服务器才能终止运行，显然当不需要Server时，应该从ROT中把COM对象撤消，那么谁以及什么时候应该从ROT中撤消COM对象呢？
比较合适的办法是当客户端发出Quit或Exit命令时由服务器自己进行撤销。
详细的解决方案可参见Microsoft的自动化程序员参考。
另外下面要谈到的ROT的内容主要针对EXE类型的Server，对于进程内的DLL型Server来说，决定何时注册/撤消ROT比较复杂，因为DLL Server的生命期是依赖于客户端的。
假设我们想让一个全局的Foo对象注册到ROT中，代码如下：（在DPR文件中）
begin
Application.Initialize;
RegisterGlobalFoo;
Application.CreateForm(TForm1, Form1);
Application.Run;
end.
Var
GlobalFooHandle : longint = 0;
procedure RegisterGlobalFoo;
var
GlobalFoo : IFoo;
Begin
//创建Foo的实例
GlobalFoo := CoFoo.Create;
//注册到ROT
OleCheck (RegisterActiveObject (
GlobalFoo, //Foo的实例
Class_Foo, //Foo的CLSID
ACTIVEOBJECT_STRONG,
GlobalFooHandle //注册后返回句柄
));
end;
然后我们为Foo (IFoo) 添加一个Quit方法:
procedure TFoo.Quit;
begin
RevokeGlobalFoo;
end;
procedure RevokeGlobalFoo;
begin
if (GlobalFooHandle <> 0) then
begin
//撤销
OleCheck (RevokeActiveObject (
GlobalFooHandle, NIL
));
GlobalFooHandle := 0;
end;
end;
下面是一个客户端使用GetActiveOleObject API调用服务器的例子：
var
FooUnk : IUnknown;
Foo : IFoo;
Begin
if (Succeeded (GetActiveObject (
Class_Foo, //Foo的CLSID
NIL, //保留参数，这里用NIL
FooUnk //从ROT返回Foo )))
then begin
//请求IFoo接口
Foo := FooUnk as IFoo;
//......
//终止全局的Foo,从ROT撤销
Foo.Quit;
end;
end;
Delphi本身还有一个GetActiveOleObject函数使用对象的PROGID作为参数而不是对象的CLSID。GetActiveOleObject内部叫GetActiveObject，只工作于自动化对象。
如何实现支持自动化缺省属性语法的属性
假设我们要创建下面这样一个自动化接口：
ICollection = interface (IDispatch)
property Item [Index : variant] : variant;
end;
那么客户端则可以通过ICollection 接口指针像下面这样获得集合中的项目：
Collection.Item [Index]
但我们有时会很懒，希望能按下面的方式调用：
Collection [Index]
允许客户端使用这种简化的语法会带来很大的方便，特别是要调用很深层次的子对象的方法时，比较一下下面两种调用方法的方便程度：
Collection.Item [Index].SubCollection.Item [Index].SubsubCollection.Item [Index]
Collection [Index].SubCollection [Index].SubsubCollection [Index]
显然是后者要方便得多，实现缺省的属性语法支持同样非常方便，在类型库编辑器中，只要简单地标记Item [] 属性的dispid值为0 (DISPID_VALUE)就可以了。
因为缺省属性支持是基于dispids的，它只能在自动化接口中有作用。对于纯的虚方法表接口，不提供这方面的支持。
COM 组件分类
很多时候我们需要枚举一些功能类似的COM对象,例如假设想利用COM来提供插件的功能,那么宿主程序如何才能知道哪个COM对象可以作为插件呢?有没有什么标准的方法来实现COM识别呢?
在Windows 98/2000下可以通过组件分类来解决这个问题。简单地说，组件分类就是把实现一些通用功能的COM对象分为一组。客户端程序可以方便地确定要使用的COM对象。同其他COM对象类似，每个分类也要用一个唯一的标识符GUID来表示,这就是CATID (类别ID)。
Windows定义了ICatRegister和ICatInformation这两个接口来提供组件分类服务。实现了ICatRegister和ICatInformation接口组件的类GUID是CLSID_StdComponentCategoryMgr。我们可以使用ICatRegister接口的RegisterCategories方法来注册一个或多个类别。RegisterCategories方法需要两个参数，第一个参数确定有多少个类别将被注册，第二个参数是一个TCategoryInfo 类型的指针数组。TCategoryInfo声明如下：
TCATEGORYINFO = record
catid: TGUID; //类别 ID
lcid: UINT; //本地化 ID, 用于多语言支持
szDescription: array[0..127] of WideChar; //类别描述
end;
要想注册一个COM对象的类别，可以使用ICatRegister接口的RegisterClassImplCategories方法。RegisterClassImplCategories方法使用两个参数，一个是要注册的COM对象的CLSID，一个是要注册的类别数及类别记录(TcategoryInfo)的数组。对于客户端来说，为了扫描所有某一类别的COM对象，可以使用ICatInformation 接口的EnumClassesOfCategories方法。EnumClassesOfCategories方法需要五个参数，但通常只需要提供其中的三个参数就可以了，一个参数用来表明我们感兴趣的类别数，第二个参数是类别数组，最后一个参数是用来匹配COM对象的CLSID/GUID的枚举器。示意代码如下：
unit uhdshake;
interface
uses
Windows,
ActiveX,
ComObj;
type
TImplementedClasses = array [0..255] of TCLSID;
function GetImplementedClasses (var ImplementedClasses : TImplementedClasses) : integer;
procedure RegisterClassImplementation (const CATID, CLSID : TCLSID; const sDescription : String; bRegister : boolean);
implementation
function GetImplementedClasses (CategoryInfo : TCategoryInfo; var ImplementedClasses : TImplementedClasses) : integer;
var
CatInfo : ICatInformation;
Enum : IEnumGuid;
Fetched : UINT;
begin
Result := 0;
CatInfo := CreateComObject (CLSID_StdComponentCategoryMgr) as ICatInformation;
OleCheck (CatInfo.EnumClassesOfCategories (1, @CategoryInfo,0,nil,Enum));
if (Enum <> nil) then
begin
OleCheck (Enum.Reset);
OleCheck (Enum.Next (High (ImplementedClasses), ImplementedClasses [1], Fetched));
Result := Fetched;
end;
end;
procedure RegisterClassImplementation (const CATID, CLSID : TCLSID; const sDescription : String; bRegister : boolean);
var
CatReg : ICatRegister;
CategoryInfo : TCategoryInfo;
begin
CoInitialize (nil);
CategoryInfo.CATID := CATID;
CategoryInfo.LCID := LOCALE_SYSTEM_DEFAULT; //dummy
StringToWideChar(sDescription, CategoryInfo.szDescription, Length(sDescription) + 1);
CatReg := CreateComObject (CLSID_StdComponentCategoryMgr) as ICatRegister;
if (bRegister) then
begin
OleCheck (CatReg.RegisterCategories (1, @CategoryInfo));
OleCheck (CatReg.RegisterClassImplCategories (CLSID, 1, @CategoryInfo));
end
else
begin
OleCheck(CatReg.UnregisterClassImplCategories(CLSID,1,@CategoryInfo));
DeleteRegKey ('CLSID\' + GuidToString (CLSID) + '\' + 'Implemented Categories');
end;
CatReg := nil;
CoUninitialize;
end;
end.
客户端可以使用GetImplementedClasses方法来获得所有符合某一类别的COM对象的CLSID。注意这里使用TImplementedClasses 类型作为所有获得的CLSID的容器。TImplementedClasses 类型简单的定义为256个CLSID的数组，对于大多数情况来说已经足够了。封装的RegisterClassImplementation方法是用来按类别注册或撤消COM对象的。
扫一扫
5460
被折叠的 条评论
为什么被折叠?
到【灌水乐园】发言
