曾经为com+分布式调用烦恼,几经周折获得解决,公布出来,互相学习借鉴
在server2003(做服务端部署机器)中测试通过,调用CreateRemoteObject(RemoteHost, AUser, APwd: WideString;ClassID: TGUID): IDispatch即可。
unit Core_ComCreate;
{
说明:远程com+对象创建,激活,验证单元
}
interface
uses SysUtils, ActiveX, ComObj, Windows, Classes;
type
PCoServerInfo = ^TCoServerInfo;
TCoServerInfo = record
dwReserved1: Longint;
pwszName: LPWSTR;
pAuthInfo: Pointer;
dwReserved2: Longint;
end;
PUnShort = ^Word;
PCoAuthIdentity = ^TCoAuthIdentity;
TCoAuthIdentity = record
User: PUnShort;
UserLength: ULONG;
Domain: PUnShort;
DomainLength: Ulong;
password: PUnShort;
PasswordLength: ulong;
Flags: ulong;
end;
TCoAuthInfo = record
dwAuthnSvc: DWORD;
dwAuthzSvc: DWORD;
pwszServerPrincName: WideString;
dwAuthnLevel: Dword;
dwImpersonationLevel: dword;
pAuthIdentityData: PCoAuthIdentity;
dwCapabilities: DWORD;
end;
TSocInfo = class(Tobject)
public
FCid: TCoAuthIdentity;
FCai: TCoAuthInfo;
ServerInfo: TCoServerInfo;
end;
TComManager = class(TComponent)
private
FCai: TCoAuthInfo;
FCid: TCoAuthIdentity;
FSvInfo: TCoServerInfo;
FUserName: WideString;
FPassword: WideString;
FRemoteHost: WideString;
//设置访问权限
protected
public
//创建对象
function CreateObject(ClassID: TGUID): IDispatch;
//接口类型转换
procedure Convert(Itf: IDispatch; IID: TGUID; out Obj);
constructor Create(AOwner: TComponent); override;
public
//远程主机所用登录名
property UserName: WideString read FUserName write FUserName;
//远程主机所用登录密码
property Password: WideString read FPassword write FPassword;
//远程主机,可填IP或机器名
property RemoteHost: WideString read FRemoteHost write FRemoteHost;
end;
function CreateRemoteObject(RemoteHost, AUser, APwd: WideString;
ClassID: TGUID): IDispatch;
procedure SetBlanket(Itf: IInterface; CAI: TCoAuthInfo); overload;
procedure SetBlanket(Itf: IInterface; RemoteHost, AUser, APwd: WideString); overload;
implementation
const
RPC_C_AUTHN_NONE: Integer = 0;
RPC_C_AUTHN_WINNT: Int64 = 10;
RPC_C_AUTHN_DEFAULT: Int64 = $FFFFFFFF;
//Authentication level constants
RPC_C_AUTHN_LEVEL_DEFAULT: Integer = 0;
RPC_C_AUTHN_LEVEL_NONE: Integer = 1;
RPC_C_AUTHN_LEVEL_CONNECT: Integer = 2;
RPC_C_AUTHN_LEVEL_CALL: Integer = 3;
RPC_C_AUTHN_LEVEL_PKT: Integer = 4;
RPC_C_AUTHN_LEVEL_PKT_INTEGRITY: Integer = 5;
RPC_C_AUTHN_LEVEL_PKT_PRIVACY: Integer = 6;
//Impersonation level constants
RPC_C_IMP_LEVEL_ANONYMOUS: Integer = 1;
RPC_C_IMP_LEVEL_IDENTIFY: Integer = 2;
RPC_C_IMP_LEVEL_IMPERSONATE: Integer = 3;
RPC_C_IMP_LEVEL_DELEGATE: Integer = 4;
//Constants for the capabilities
API_NULL: Integer = 0;
S_OK: Integer = 0;
EOAC_NONE: Integer = $0;
EOAC_MUTUAL_AUTH: Integer = $1;
EOAC_CLOAKING: Integer = $10;
EOAC_SECURE_REFS: Integer = $2;
EOAC_ACCESS_CONTROL: Integer = $4;
EOAC_APPID: Integer = $8;
{ TComManager }
procedure TComManager.Convert(Itf: IDispatch; IID: TGUID; out Obj);
begin
OleCheck(Itf.QueryInterface(IID, Obj));
SetBlanket(IUnknown(Obj), FCai);
end;
constructor TComManager.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FillMemory(@FCid, sizeof(FCid), 0);
FillMemory(@FSvInfo, sizeof(FSvInfo), 0);
FillMemory(@FCAI, sizeof(FCAI), 0);
with FCAI do begin
dwAuthnSvc := 10; //RPC_C_AUTHN_WINNT
dwAuthzSvc := 0; // RPC_C_AUTHZ_NONE
dwAuthnLevel := 0; //RPC_C_AUTHN_LEVEL_DEFAULT
dwImpersonationLevel := 3;
pAuthIdentityData := nil;
dwCapabilities := $0800;
end;
FCai.pAuthIdentityData := @FCid;
end;
function TComManager.CreateObject(ClassID: TGUID): IDispatch;
begin
Result := CreateRemoteObject(FRemoteHost, FUserName, FPassword, ClassID);
end;
function GetACAI(RemoteHost, AUser, APwd: WideString): TCoAuthInfo;
var
CID: TCoAuthIdentity;
begin
with CID do begin
User := PUnShort(@AUser[1]);
UserLength := Length(AUser);
Domain := PUnShort(@RemoteHost[1]);
DomainLength := Length(RemoteHost);
Password := PUnShort(@APwd[1]);
PasswordLength := Length(APwd);
Flags := 2; //Unicode
end;
with Result do begin
dwAuthnSvc := 10; //RPC_C_AUTHN_WINNT
dwAuthzSvc := 0; // RPC_C_AUTHZ_NONE
dwAuthnLevel := 0; //RPC_C_AUTHN_LEVEL_DEFAULT
dwImpersonationLevel := 3;
pAuthIdentityData := @CID;
dwCapabilities := $0800;
end;
end;
procedure SetBlanket(Itf: IInterface; CAI: TCoAuthInfo); overload;
begin
with CAI do
CoSetProxyBlanket(Itf, dwAuthnSvc, dwAuthzSvc, pwidechar(pAuthIdentityData^.Domain),
dwAuthnLevel, dwImpersonationLevel, pAuthIdentityData, dwCapabilities);
end;
procedure SetBlanket(Itf: IInterface; RemoteHost, AUser, APwd: WideString); overload;
begin
SetBlanket(Itf, GetACAI(RemoteHost, AUser, APwd));
end;
function CreateRemoteObject(RemoteHost, AUser, APwd: WideString;ClassID: TGUID): IDispatch;
const
LocalFlags = CLSCTX_LOCAL_SERVER or CLSCTX_REMOTE_SERVER or CLSCTX_INPROC_SERVER;
RemoteFlags = CLSCTX_REMOTE_SERVER;
var
Size, Flags: DWORD;
IID_IUnknown: TGUID;
MQI: MULTI_QI;
LocalMachine: array[0..MAX_COMPUTERNAME_LENGTH] of char;
CID: TCoAuthIdentity;
CAI: TCoAuthInfo;
CSI: TCoServerInfo;
begin
FillMemory(@CID, SizeOf(CID), 0);
FillMemory(@CSI, SizeOf(CSI), 0);
FillMemory(@CAI, sizeof(CAI), 0);
with CAI do begin
dwAuthnSvc := 10; //RPC_C_AUTHN_WINNT
dwAuthzSvc := 0; // RPC_C_AUTHZ_NONE
dwAuthnLevel := 0; //RPC_C_AUTHN_LEVEL_DEFAULT
dwImpersonationLevel := 3;
pAuthIdentityData := @CID;
dwCapabilities := $0800;
end;
with CID do begin
User := PUnShort(@AUser[1]);
UserLength := Length(AUser);
Domain := PUnShort(@RemoteHost[1]);
DomainLength := Length(RemoteHost);
Password := PUnShort(@APwd[1]);
PasswordLength := Length(APwd);
Flags := 2; //Unicode
end;
CSI.pwszName := PWideChar(RemoteHost);
if AUser <> '' then
CSI.pAuthInfo := @CAI;
IID_IUnknown := IUnknown;
MQI.IID := @IID_IUnknown;
MQI.Itf := nil;
MQI.hr := 0;
if Length(RemoteHost)> 0 then
begin
Size := Sizeof(LocalMachine); // Win95 is hypersensitive to size
if GetComputerName(LocalMachine, Size)and(AnsiCompareText(LocalMachine, RemoteHost) = 0)
or(RemoteHost='127.0.0.1') then
begin
Result:=CreateComObject(ClassID) as IDispatch;
Flags := LocalFlags;
Exit;
end
else Flags := RemoteFlags;
end else Flags := LocalFlags;
OleCheck(CoCreateInstanceEx(ClassID, nil, Flags, @CSI, 1, @MQI));
OleCheck(MQI.hr);
SetBlanket(MQI.Itf, CAI);
OleCheck(MQI.Itf.QueryInterface(IDispatch, Result));
SetBlanket(Result, CAI);
end;
end.
在server2003(做服务端部署机器)中测试通过,调用CreateRemoteObject(RemoteHost, AUser, APwd: WideString;ClassID: TGUID): IDispatch即可。
unit Core_ComCreate;
{
说明:远程com+对象创建,激活,验证单元
}
interface
uses SysUtils, ActiveX, ComObj, Windows, Classes;
type
PCoServerInfo = ^TCoServerInfo;
TCoServerInfo = record
dwReserved1: Longint;
pwszName: LPWSTR;
pAuthInfo: Pointer;
dwReserved2: Longint;
end;
PUnShort = ^Word;
PCoAuthIdentity = ^TCoAuthIdentity;
TCoAuthIdentity = record
User: PUnShort;
UserLength: ULONG;
Domain: PUnShort;
DomainLength: Ulong;
password: PUnShort;
PasswordLength: ulong;
Flags: ulong;
end;
TCoAuthInfo = record
dwAuthnSvc: DWORD;
dwAuthzSvc: DWORD;
pwszServerPrincName: WideString;
dwAuthnLevel: Dword;
dwImpersonationLevel: dword;
pAuthIdentityData: PCoAuthIdentity;
dwCapabilities: DWORD;
end;
TSocInfo = class(Tobject)
public
FCid: TCoAuthIdentity;
FCai: TCoAuthInfo;
ServerInfo: TCoServerInfo;
end;
TComManager = class(TComponent)
private
FCai: TCoAuthInfo;
FCid: TCoAuthIdentity;
FSvInfo: TCoServerInfo;
FUserName: WideString;
FPassword: WideString;
FRemoteHost: WideString;
//设置访问权限
protected
public
//创建对象
function CreateObject(ClassID: TGUID): IDispatch;
//接口类型转换
procedure Convert(Itf: IDispatch; IID: TGUID; out Obj);
constructor Create(AOwner: TComponent); override;
public
//远程主机所用登录名
property UserName: WideString read FUserName write FUserName;
//远程主机所用登录密码
property Password: WideString read FPassword write FPassword;
//远程主机,可填IP或机器名
property RemoteHost: WideString read FRemoteHost write FRemoteHost;
end;
function CreateRemoteObject(RemoteHost, AUser, APwd: WideString;
ClassID: TGUID): IDispatch;
procedure SetBlanket(Itf: IInterface; CAI: TCoAuthInfo); overload;
procedure SetBlanket(Itf: IInterface; RemoteHost, AUser, APwd: WideString); overload;
implementation
const
RPC_C_AUTHN_NONE: Integer = 0;
RPC_C_AUTHN_WINNT: Int64 = 10;
RPC_C_AUTHN_DEFAULT: Int64 = $FFFFFFFF;
//Authentication level constants
RPC_C_AUTHN_LEVEL_DEFAULT: Integer = 0;
RPC_C_AUTHN_LEVEL_NONE: Integer = 1;
RPC_C_AUTHN_LEVEL_CONNECT: Integer = 2;
RPC_C_AUTHN_LEVEL_CALL: Integer = 3;
RPC_C_AUTHN_LEVEL_PKT: Integer = 4;
RPC_C_AUTHN_LEVEL_PKT_INTEGRITY: Integer = 5;
RPC_C_AUTHN_LEVEL_PKT_PRIVACY: Integer = 6;
//Impersonation level constants
RPC_C_IMP_LEVEL_ANONYMOUS: Integer = 1;
RPC_C_IMP_LEVEL_IDENTIFY: Integer = 2;
RPC_C_IMP_LEVEL_IMPERSONATE: Integer = 3;
RPC_C_IMP_LEVEL_DELEGATE: Integer = 4;
//Constants for the capabilities
API_NULL: Integer = 0;
S_OK: Integer = 0;
EOAC_NONE: Integer = $0;
EOAC_MUTUAL_AUTH: Integer = $1;
EOAC_CLOAKING: Integer = $10;
EOAC_SECURE_REFS: Integer = $2;
EOAC_ACCESS_CONTROL: Integer = $4;
EOAC_APPID: Integer = $8;
{ TComManager }
procedure TComManager.Convert(Itf: IDispatch; IID: TGUID; out Obj);
begin
OleCheck(Itf.QueryInterface(IID, Obj));
SetBlanket(IUnknown(Obj), FCai);
end;
constructor TComManager.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FillMemory(@FCid, sizeof(FCid), 0);
FillMemory(@FSvInfo, sizeof(FSvInfo), 0);
FillMemory(@FCAI, sizeof(FCAI), 0);
with FCAI do begin
dwAuthnSvc := 10; //RPC_C_AUTHN_WINNT
dwAuthzSvc := 0; // RPC_C_AUTHZ_NONE
dwAuthnLevel := 0; //RPC_C_AUTHN_LEVEL_DEFAULT
dwImpersonationLevel := 3;
pAuthIdentityData := nil;
dwCapabilities := $0800;
end;
FCai.pAuthIdentityData := @FCid;
end;
function TComManager.CreateObject(ClassID: TGUID): IDispatch;
begin
Result := CreateRemoteObject(FRemoteHost, FUserName, FPassword, ClassID);
end;
function GetACAI(RemoteHost, AUser, APwd: WideString): TCoAuthInfo;
var
CID: TCoAuthIdentity;
begin
with CID do begin
User := PUnShort(@AUser[1]);
UserLength := Length(AUser);
Domain := PUnShort(@RemoteHost[1]);
DomainLength := Length(RemoteHost);
Password := PUnShort(@APwd[1]);
PasswordLength := Length(APwd);
Flags := 2; //Unicode
end;
with Result do begin
dwAuthnSvc := 10; //RPC_C_AUTHN_WINNT
dwAuthzSvc := 0; // RPC_C_AUTHZ_NONE
dwAuthnLevel := 0; //RPC_C_AUTHN_LEVEL_DEFAULT
dwImpersonationLevel := 3;
pAuthIdentityData := @CID;
dwCapabilities := $0800;
end;
end;
procedure SetBlanket(Itf: IInterface; CAI: TCoAuthInfo); overload;
begin
with CAI do
CoSetProxyBlanket(Itf, dwAuthnSvc, dwAuthzSvc, pwidechar(pAuthIdentityData^.Domain),
dwAuthnLevel, dwImpersonationLevel, pAuthIdentityData, dwCapabilities);
end;
procedure SetBlanket(Itf: IInterface; RemoteHost, AUser, APwd: WideString); overload;
begin
SetBlanket(Itf, GetACAI(RemoteHost, AUser, APwd));
end;
function CreateRemoteObject(RemoteHost, AUser, APwd: WideString;ClassID: TGUID): IDispatch;
const
LocalFlags = CLSCTX_LOCAL_SERVER or CLSCTX_REMOTE_SERVER or CLSCTX_INPROC_SERVER;
RemoteFlags = CLSCTX_REMOTE_SERVER;
var
Size, Flags: DWORD;
IID_IUnknown: TGUID;
MQI: MULTI_QI;
LocalMachine: array[0..MAX_COMPUTERNAME_LENGTH] of char;
CID: TCoAuthIdentity;
CAI: TCoAuthInfo;
CSI: TCoServerInfo;
begin
FillMemory(@CID, SizeOf(CID), 0);
FillMemory(@CSI, SizeOf(CSI), 0);
FillMemory(@CAI, sizeof(CAI), 0);
with CAI do begin
dwAuthnSvc := 10; //RPC_C_AUTHN_WINNT
dwAuthzSvc := 0; // RPC_C_AUTHZ_NONE
dwAuthnLevel := 0; //RPC_C_AUTHN_LEVEL_DEFAULT
dwImpersonationLevel := 3;
pAuthIdentityData := @CID;
dwCapabilities := $0800;
end;
with CID do begin
User := PUnShort(@AUser[1]);
UserLength := Length(AUser);
Domain := PUnShort(@RemoteHost[1]);
DomainLength := Length(RemoteHost);
Password := PUnShort(@APwd[1]);
PasswordLength := Length(APwd);
Flags := 2; //Unicode
end;
CSI.pwszName := PWideChar(RemoteHost);
if AUser <> '' then
CSI.pAuthInfo := @CAI;
IID_IUnknown := IUnknown;
MQI.IID := @IID_IUnknown;
MQI.Itf := nil;
MQI.hr := 0;
if Length(RemoteHost)> 0 then
begin
Size := Sizeof(LocalMachine); // Win95 is hypersensitive to size
if GetComputerName(LocalMachine, Size)and(AnsiCompareText(LocalMachine, RemoteHost) = 0)
or(RemoteHost='127.0.0.1') then
begin
Result:=CreateComObject(ClassID) as IDispatch;
Flags := LocalFlags;
Exit;
end
else Flags := RemoteFlags;
end else Flags := LocalFlags;
OleCheck(CoCreateInstanceEx(ClassID, nil, Flags, @CSI, 1, @MQI));
OleCheck(MQI.hr);
SetBlanket(MQI.Itf, CAI);
OleCheck(MQI.Itf.QueryInterface(IDispatch, Result));
SetBlanket(Result, CAI);
end;
end.