源代码,别人写的带有用户名和密码的TDCOMComnnection(0分)

这是一个带有用户名和密码的TDCOMComnnection,
这是别人写的,我把源代码贴出来,生成一个pas,需要在delphi中install component一下就可以了:
unit uSecDComConnection;
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*do
main;
unsigned longdo
mainLength;
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 *do
main;
ULONGdo
mainLength;
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
userUnShort;
UserLength:ULONG;
do
mainUnShort;
do
mainLength:Ulong;
passwordUnShort;
PasswordLength:ulong;
Flags:ulong;
end;

_CoAuthInfo=record
dwAuthnSvcWORD;
dwAuthzSvcWORD;
pwszServerPrincName:WideString;
dwAuthnLevelword;
dwImpersonationLevel:dword;
pAuthIdentityDataCoAuthIdentity;
dwCapabilitiesWORD;
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
proceduredo
Connect;
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 FCaido
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 fciddo
begin

user:=pUnshort(@fuser[1]);
UserLength:=length(fuser);
tmpCmpName:=ComputerName;
do
main:=pUnshort(@tmpCmpName[1]);
do
mainLength:=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

inheriteddo
Connect;
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 vCaido

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.