Delph中远程com+对象激活一般通过TdispatchConnection及其子类来实现,实际代码中多用TDCOMConnection或TsocketConnectoion这两个组件,TDCOMConnection组件最终调用CoCreateInstanceEx创建com+对象。CoCreateInstanceEx (const clsid: TCLSID; unkOuter: IUnknown; dwClsCtx: Longint; ServerInfo:PCoServerInfo;dwCount: Longint; rgmqResults: PMultiQIArray): HResult。
var
mts:IMTSXjpimsDB;
ov:Variant;
i:integer;
cai:_CoAuthInfo;
cid:_CoAuthIdentity;
csi:COSERVERINFO;
mqi:MULTI_QI;
iid_unk:TGUID;
idsp:IDispatch;
wUser,wDomain,wPsw:WideString;
begin
wUser:=eduser.text;//用户名
wDomain:=edSvr.Text;//远程计算机名
wPsw:=edPsw.Text;//密码
cid.user:=pUnshort(@wUser[1]);
cid.UserLength:=length(wUser);
cid.Domain:=pUnshort(@wDomain[1]);
cid.DomainLength:=length(wDomain);
cid.password:=pUnshort(@wPsw[1]);
cid.PasswordLength:=length(wPsw);
cid.Flags:=2;
//以上填充_CoAuthIdentity结构
cai.dwAuthnSvc:=10;//winNt默认的鉴证服务
cai.dwAuthzSvc:=0;
cai.pwszServerPrincName:=wDomain;
cai.dwAuthnLevel:=0;
cai.dwImpersonationLevel:=3;//必须设置成模拟
cai.pAuthIdentityData:=@cid;
cai.dwCapabilities:=$0800;
FillChar(csi, sizeof(csi), 0);
csi.dwReserved1:=0;
csi.pwszName:=pwidechar(wdomain);
csi.pAuthInfo:=@cai;
//以上填充COSERVERINFO结构
iid_unk:=IUnknown;
mqi.IID:=@iid_unk;mqi.Itf:=nil;mqi.hr:=0;
Screen.Cursor:=crHourGlass; olecheck(CoCreateInstanceEx(CLASS_MTSXjpimsDB,nil,CLSCTX_REMOTE_SERVER,@csi,1,@mqi));
unit SecDComConnection;
interface
uses
windows,SysUtils, Classes,ActiveX, DB, DBClient, MConnect,comobj,Midas;
type
{typedef struct _SEC_WINNT_AUTH_IDENTITY
unsigned short __RPC_FAR* User;
unsigned long UserLength;
unsigned short __RPC_FAR* Domain;
unsigned long DomainLength;
unsigned short __RPC_FAR* Password;
unsigned long PasswordLength;
unsigned long Flags;
SEC_WINNT_AUTH_IDENTITY, *PSEC_WINNT_AUTH_IDENTITY;
}
{typedef struct _COAUTHIDENTITY
USHORT * User;
ULONG UserLength;
USHORT * Domain;
ULONG DomainLength;
USHORT * Password;
ULONG PasswordLength;
ULONG Flags;
COAUTHIDENTITY;}
{#define RPC_C_AUTHN_NONE 0
#define RPC_C_AUTHN_DCE_PRIVATE 1
#define RPC_C_AUTHN_DCE_PUBLIC 2
#define RPC_C_AUTHN_DEC_PUBLIC 4
#define RPC_C_AUTHN_GSS_NEGOTIATE 9
#define RPC_C_AUTHN_WINNT 10
#define RPC_C_AUTHN_GSS_SCHANNEL 14
#define RPC_C_AUTHN_GSS_KERBEROS 16
#define RPC_C_AUTHN_MSN 17
#define RPC_C_AUTHN_DPA 18
#define RPC_C_AUTHN_MQ 100
#define RPC_C_AUTHN_DEFAULT 0xFFFFFFFFL
}
{#define RPC_C_AUTHZ_NONE 0
#define RPC_C_AUTHZ_NAME 1
#define RPC_C_AUTHZ_DCE 2
#define RPC_C_AUTHZ_DEFAULT 0xFFFFFFFF }
{
#define RPC_C_AUTHN_LEVEL_DEFAULT 0
#define RPC_C_AUTHN_LEVEL_NONE 1
#define RPC_C_AUTHN_LEVEL_CONNECT 2
#define RPC_C_AUTHN_LEVEL_CALL 3
#define RPC_C_AUTHN_LEVEL_PKT 4
#define RPC_C_AUTHN_LEVEL_PKT_INTEGRITY 5
#define RPC_C_AUTHN_LEVEL_PKT_PRIVACY 6 }
{SEC_WINNT_AUTH_IDENTITY_UNICODE=2 }
pUnShort=^Word;
pCoAuthIdentity=^_CoAuthIdentity;
_CoAuthIdentity=record
user:pUnShort;
UserLength:ULONG;
Domain:pUnShort;
DomainLength:Ulong;
password:pUnShort;
PasswordLength:ulong;
Flags:ulong;
end;
_CoAuthInfo=record
dwAuthnSvc:DWORD;
dwAuthzSvc:DWORD;
pwszServerPrincName:WideString;
dwAuthnLevel:Dword;
dwImpersonationLevel:dword;
pAuthIdentityData:pCoAuthIdentity;
dwCapabilities:DWORD;
end;
TSecDComConnection = class(TDCOMConnection)
private
FCai:_CoAuthInfo;
FCid:_CoAuthIdentity;
FSvInfo:COSERVERINFO;
FUser:WideString;
FPassWord:WideString;
procedure SetPassword(const Value: wideString);
procedure SetUser(const Value: wideString);
procedure SetSvInfo(const Value: COSERVERINFO);
protected
procedure DoConnect; override;
public
property SvInfo:COSERVERINFO read FSvInfo write SetSvInfo;
constructor Create(AOwner: TComponent); override;
procedure MySetBlanket(itf:IUnknown;const vCai:_CoAuthInfo);
function GetServer: IAppServer; override;
published
property User:wideString read FUser write SetUser;
Property Password:wideString read FPassword write SetPassword;
end;
procedure Register;
implementation
constructor TSecDCOMConnection.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FillMemory(@Fcai,sizeof(Fcai),0);
FillMemory(@FCid,sizeof(FCid),0);
FillMemory(@FSvInfo,sizeof(FSvInfo),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:=@fcid;
dwCapabilities:=$0800;
end;
end;
procedure TSecDCOMConnection.DoConnect;
var
tmpCmpName:widestring;
IID_IUnknown:TGUID;
iiu:IDispatch;
Mqi:MULTI_QI;
qr:HRESULT;
begin
if (ObjectBroker) <> nil then
begin
repeat
if ComputerName = '' then
ComputerName := ObjectBroker.GetComputerForGUID(GetServerCLSID);
try
SetAppServer(CreateRemoteComObject(ComputerName, GetServerCLSID) as IDispatch);
ObjectBroker.SetConnectStatus(ComputerName, True);
except
ObjectBroker.SetConnectStatus(ComputerName, False);
ComputerName := '';
end;
until Connected;
end
else if (ComputerName <> '') then
begin
with fcid do begin
user:=pUnshort(@fuser[1]);
UserLength:=length(fuser);
tmpCmpName:=ComputerName;
Domain:=pUnshort(@tmpCmpName[1]);
DomainLength:=length(TmpCmpName);
password:=pUnShort(@FPassword[1]);
PasswordLength:=length(FPassword);
Flags:=2;//Unicode
end;
FSvInfo.pwszName:=pwidechar(tmpCmpName);
FSvinfo.pAuthInfo:=@Fcai;
IID_IUnknown:=IUnknown;
mqi.IID:=@IID_IUnknown;mqi.Itf:=nil;mqi.hr:=0;
olecheck(CoCreateInstanceEx(GetServerCLSID,nil,CLSCTX_REMOTE_SERVER,@FSvinfo,1,@mqi));
olecheck(mqi.hr);
MySetBlanket(mqi.Itf,Fcai);
qr:=mqi.Itf.QueryInterface(idispatch,iiu);
olecheck(qr);
MySetBlanket(IUnknown(iiu),FCai);
SetAppServer(iiu);
end
else
inherited DoConnect;
end;
function TSecDComConnection.GetServer: IAppServer;
var
QIResult: HResult;
begin
Connected := True;
QIResult := IDispatch(AppServer).QueryInterface(IAppServer, Result);
if QIResult <> S_OK then
begin
Result := TDispatchAppServer.Create(IAppServerDisp(IDispatch(AppServer)));
end;
MySetBlanket(IUnknown(Result),FCai);
end;
procedure TSecDCOMConnection.MySetBlanket(itf: IUnknown;
const vCai: _CoAuthInfo);
begin
with vCai do
CoSetProxyBlanket(Itf,dwAuthnSvc,dwAuthzSvc,pwidechar(pAuthIdentityData^.Domain),
dwAuthnLevel,dwImpersonationLevel,pAuthIdentityData,dwCapabilities);
end;
procedure TSecDCOMConnection.SetPassword(const Value: wideString);
begin
FPassword := Value;
end;
procedure TSecDCOMConnection.SetSvInfo(const Value: COSERVERINFO);
begin
FSvInfo := Value;
end;
procedure TSecDCOMConnection.SetUser(const Value: wideString);
begin
FUser := Value;
end;
procedure Register;
begin
RegisterComponents('DataSnap', [TSecDComConnection]);
end;
end.
MySetBlanket(mqi.Itf,Fcai);
qr:=mqi.Itf.QueryInterface(idispatch,iiu);
olecheck(qr);
MySetBlanket(IUnknown(iiu),FCai);