delphi编程验证域用户

01
unit uLoginIntf; 

02
  
03
interface

04
  
05
uses

06
Classes; 

07
  
08
type

09
ILogin = interface

10
['{987EAEB0-EDC4-4F77-852D-7C14418D549D}'] 

11
procedure SetDomain(DomainName: string); 

12
function GetDomain: string; 

13
function CheckLogin(UserName, Password: string; var ErrorMsg: string): Boolean; 

14
end; 

15
  
16
<!--more--> 

17
  
18
TLogin = class(TComponent, ILogin) 

19
private

20
FUserPassword: string; 

21
FUserName: string; 

22
FDomainName: string; 

23
protected

24
FErrorMsg: string; 

25
function GetCanLogin: Boolean; virtual; 

26
public

27
procedure SetDomain(sDomainName: string); virtual; 

28
function GetDomain: string; 

29
function CheckLogin(sUserName, sPassword: string; var ErrorMsg: string): Boolean; virtual; 

30
  
31
constructor Create(AOwner: TComponent); override; 

32
destructor Destroy; override; 

33
  
34
property DomainName: string read FDomainName write FDomainName; 

35
property UserName: string read FUserName write FUserName; 

36
property UserPassword: string read FUserPassword write FUserPassword; 

37
property CanLogin: Boolean read GetCanLogin; 

38
end; 

39
  
40
implementation

41
  
42
{ TLogin }

43
  
44
function TLogin.CheckLogin(sUserName, sPassword: string; var ErrorMsg: string): Boolean; 

45
begin

46
FUserName := sUserName; 

47
FUserPassword := sPassword; 

48
Result := CanLogin; 

49
ErrorMsg := FErrorMsg; 

50
end; 

51
  
52
constructor TLogin.Create(AOwner: TComponent); 

53
begin

54
inherited Create(AOwner); 

55
  
56
end; 

57
  
58
destructor TLogin.Destroy; 

59
begin

60
  
61
inherited; 

62
end; 

63
  
64
function TLogin.GetCanLogin: Boolean; 

65
begin

66
FErrorMsg := ''; 

67
Result := False; 

68
end; 

69
  
70
function TLogin.GetDomain: string; 

71
begin

72
Result := FDomainName; 

73
end; 

74
  
75
procedure TLogin.SetDomain(sDomainName: string); 

76
begin

77
FDomainName := sDomainName; 

78
end; 

79
  
80
end.
[dephi]unit uADLogin;
interface
uses
SysUtils, Classes,
uLoginIntf;
type
TADLogin = class(TLogin)
protected
function GetCanLogin: Boolean; override;
end;
implementation
uses
ComObj, ActiveX;
function GetObject(const Name: string): IDispatch;
var
Moniker: IMoniker;
Eaten: Integer;
BindContext: IBindCtx;
Dispatch: IDispatch;
begin
OleCheck(CreateBindCtx(0, BindContext));
OleCheck(MkParseDisplayName(BindContext,
PWideChar(WideString(Name)),
Eaten,
Moniker));
OleCheck(Moniker.BindToObject(BindContext, NIL, IDispatch,
Dispatch));
Result := Dispatch;
end;
{ TADLogin }
function TADLogin.GetCanLogin: Boolean;
const
C_WINNT_ROOT = ‘WinNT:’;
var
oADSI, oIIS: Variant;
sUser, sPassword: string;
begin
Result := inherited GetCanLogin;
try
sUser := DomainName + ‘\’ + UserName;
sPassword := UserPassword;
oADSI := GetObject(C_WINNT_ROOT);
oIIS := oADSI.OpenDSObject(C_WINNT_ROOT + ‘//’ + DomainName, sUser, sPassword, 0);
Result := True;
except
on E: Exception do
begin
FErrorMsg := E.Message;
end;
end;
end;
end.

unit Unit1;
interface
uses 
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,ActiveDs_TLB, StdCtrls, ExtCtrls;
type 
TForm1 = class(TForm) 
btn1: TButton; 
Edit1: TEdit; 
Edit2: TEdit; 
procedure btn1Click(Sender: TObject); 
private 
{ Private declarations } 
public 
{ Public declarations } 
end;

var 
Form1: TForm1;
implementation 
{$R *.DFM} 
uses 
uADLogin;
function CheckADLogin(UserName, Password: string; DomainName: string; var ErrorMsg: string): Boolean; 
var 
AAL: TADLogin; 
begin 
Result := False;
AAL := TADLogin.Create(nil); 
try 
AAL.SetDomain(DomainName); 
Result := AAL.CheckLogin(UserName, Password, ErrorMsg); 
finally 
FreeAndNil(AAL); 
end; 
end;
procedure TForm1.btn1Click(Sender: TObject); 
var 
sError: string; 
begin 
if CheckADLogin(Edit1.Text, Edit2.Text, ‘’, sError) then 
ShowMessage(‘登陆成功~！’) 
else 
ShowMessage(sError);
end;
end.