delphi实现com+远程(包括本地)调用

曾经为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.