Following _isEdit function detects whether input could be applied to the currently focused control:
class function TSpeedInput._getFocusedControlClassName(): WideString;
var
lpClassName: array[0..1000] of WideChar;
begin
FillChar(lpClassName, SizeOf(lpClassName), 0);
Windows.GetClassNameW(GetFocus(), PWideChar(#lpClassName), 999);
Result := lpClassName;
end;
class function TSpeedInput._isEdit(): Boolean;
const
CNAMES: array[0..3] of string = ('TEdit', 'TMemo', 'TTntMemo.UnicodeClass',
'TTntEdit.UnicodeClass');
var
cn: WideString;
i: Integer;
begin
Result := False;
cn := _getFocusedControlClassName();
for i := Low(CNAMES) to High(CNAMES) do
if cn = CNAMES[i] then begin
Result := True;
Exit;
end;
//MessageBoxW(0, PWideChar(cn), nil, 0);
end;
What I don't like about it is the hard coding of the class name list. Could it be detected that a currently focused window belongs to the editors family or, better to say, that it has an active caret? (in order that _isEdit returns False for a WhateverItIsControl that is in read-only mode).
If the Handle of the control is allocated, you can use this hack:
function IsEdit(AControl: TWinControl): boolean;
begin
if AControl.HandleAllocated then
begin
Result := SendMessage(AControl.Handle, EM_SETREADONLY,
WPARAM(Ord(AControl.Enabled)), 0) <> 0;
end
else
begin
Result := AControl is TCustomEdit;
end;
end;
If the controls you are interested in are on a specific form and are owned by that form (and are standard Delphi controls) you could use the following:
function TFormML2.FocusIsEdit: boolean;
var
i : integer;
begin
Result := FALSE;
for i := 0 to ComponentCount - 1 do
begin
if Components[ i ] is TCustomEdit then
begin
if (Components[ i ] as TCustomEdit).Focused and not (Components[ i ] as TCustomEdit).ReadOnly then
begin
Result := TRUE;
break;
end;
end;
end;
end;
If you know the form and can pass it as a parameter, you could do something similar.
TCustomEdit is the ancestor of all edit boxes, memos, etc.
Related
I have a TFrame that is Inherited from a TBaseFrame = class(TFrame)
Inside this there is an embeded TFrame with same inheritence
TViewStandardMovimentoFinanceiro = class(TFrameBase)
ViewStandardEdiMovimentoFinanceiro1: TViewStandardEdiMovimentoFinanceiro;
TViewStandardEdiMovimentoFinanceiro = class(TFrameBase)
TFrameBase = class(TFrame, INaharView, INaharViewAdapter)
The TViewStandardMovimentoFinanceiro is created with parent set to the main form (particularly to a THorzScrollBox)
From INSIDE the TViewStandardMovimentoFinanceiro frame I tried the classical approach of using the Children list and have not found that embedded TFrame.
I have tried also using the Parent`s Children list with no success. Same thing with the Components List
What I want to do is to to locate all available TFrames so I can ask for an interface (I know how to do that)
What am I missing?
Following recommendations bellow I have implemented this code for testing:
function TFrameBase.LocateControl(AControl: TControl; ADomainName: string): TControlHandler;
var
NaharView: INaharView;
ControlHandler: TControlHandler;
i: integer;
begin
result := nil;
for i := 0 to AControl.ChildrenCount - 1 do
if (AControl.Children[i] is TFrame) and (AControl.Children[i] <> Self) then
if Supports((AControl.Children[i] as TFrame), INaharView, NaharView) then
begin
ControlHandler := NaharView.Control[ADomainName];
if Assigned(ControlHandler) then
exit(ControlHandler);
end;
end;
function GetUltimateParent(Control: TControl): TControl;
begin
if Control.Parent is TControl then
Result := GetUltimateParent(TControl(Control.Parent))
else
Result := Control;
end;
function TFrameBase.GetNaharControl(ADomainName: string): TControlHandler;
var
i: integer;
ControlHandler: TControlHandler;
begin
if NaharControls.ContainsKey(ADomainName) then
Exit(NaharControls.Items[ADomainName])
else
begin
ControlHandler := LocateControl(GetUltimateParent(Self), ADomainName);
if Assigned(ControlHandler) then
exit(ControlHandler);
end;
raise EViewControlDomainNameNotFound.Create(ADomainName);
end;
When LocateControl is executed it goes several levels to the top and from there it tries to iterate on Children List, it only contains 3 items in a form form full of controls.
Your function LocateControl need to be recursive, as stated by Ondrej. Something like this
function TFrameBase.LocateControl(AControl: TControl; ADomainName: string): TControlHandler;
var
NaharView: INaharView;
ControlHandler: TControlHandler;
i: integer;
begin
result := nil;
for i := 0 to AControl.ChildrenCount - 1 do
begin
if (AControl.Children[i] is TFrame) and (AControl.Children[i] <> Self) then
begin
if Supports((AControl.Children[i] as TFrame), INaharView, NaharView) then
begin
ControlHandler := NaharView.Control[ADomainName];
if Assigned(ControlHandler) then
begin
exit(ControlHandler);
end;
end;
end;
// recursive bit
Result := LocateControl(AControl.Children[i], ADomainName):
if assigned( Result ) then
begin
exit;
end;
end;
end;
We can use the SuperObject library to invoke methods of a certain object by its name and giving its parameters as a json string using the SOInvoker method like in this answer
I'd like to know how do I send a created object as a parameter. I tried to send it like
LObjectList := TObjectList.Create;
LSuperRttiCtx := TSuperRttiContext.Create;
LSuperObjectParameter := LObjectList.ToJson(LSuperRttiCtx);
SOInvoke(MyInstantiatedObject, 'MyMethod', LSuperObjectParameter);
but inside MyMethod the LObjectList reference is lost.
What am I doing wrong?
The superobject library can be downloaded here
It will works if you use array of records intead of object list.
If you still want to use object list you will have to write encoders and decoders like this. I have written encoder/decoder for TObjectList, you will have to do the same for your objects and embed the class name somewhere.
ctx.SerialToJson.Add(TypeInfo(TObjectList), ObjectListToJSON);
ctx.SerialFromJson.Add(TypeInfo(TObjectList), JSONToObjectList);
function ObjectListToJSON(ctx: TSuperRttiContext; var value: TValue;
const index: ISuperObject): ISuperObject;
var
list: TObjectList;
i: Integer;
begin
list := TObjectList(value.AsObject);
if list <> nil then
begin
Result := TSuperObject.Create(stArray);
for i := 0 to list.Count - 1 do
Result.AsArray.Add(encodeyourobject(list[i]));
end else
Result := nil;
end;
function JSONToObjectList(ctx: TSuperRttiContext; const obj: ISuperObject; var Value: TValue): Boolean;
var
list: TObjectList;
i: Integer;
begin
list := nil;
case ObjectGetType(obj) of
stNull:
begin
Value := nil;
Result := True;
end;
stArray:
begin
list := TObjectList.Create;
for i := 0 to obj.AsArray.Length - 1 do
list.Add(decodeyourobject(obj.AsArray[i]));
Value := list;
Result := True;
end;
else
result := False;
end;
end;
I need the opposite information that the question "How to get cursor position on a control?" asks.
Given the current cursor position, how can I find the form (in my application) and the control that the cursor is currently over? I need the handle to it so that I can use Windows.SetFocus(Handle).
For reference, I'm using Delphi 2009.
I experienced some problems with suggested solutions (Delphi XE6/Windows 8.1/x64):
FindVCLWindow doesn't search disabled controls (Enabled=False).
TWinControl.ControlAtPos doesn't search controls if they are disabled
indirectly (for example if Button.Enabled=True, but Button.Parent.Enabled=False).
In my case it was a problem, because i need to find any visible control under the mouse cursor, so i have to use my own implementation of function FindControlAtPos:
function FindSubcontrolAtPos(AControl: TControl; AScreenPos, AClientPos: TPoint): TControl;
var
i: Integer;
C: TControl;
begin
Result := nil;
C := AControl;
if (C=nil) or not C.Visible or not TRect.Create(C.Left, C.Top, C.Left+C.Width, C.Top+C.Height).Contains(AClientPos) then
Exit;
Result := AControl;
if AControl is TWinControl then
for i := 0 to TWinControl(AControl).ControlCount-1 do
begin
C := FindSubcontrolAtPos(TWinControl(AControl).Controls[i], AScreenPos, AControl.ScreenToClient(AScreenPos));
if C<>nil then
Result := C;
end;
end;
function FindControlAtPos(AScreenPos: TPoint): TControl;
var
i: Integer;
f,m: TForm;
p: TPoint;
r: TRect;
begin
Result := nil;
for i := Screen.FormCount-1 downto 0 do
begin
f := Screen.Forms[i];
if f.Visible and (f.Parent=nil) and (f.FormStyle<>fsMDIChild) and
TRect.Create(f.Left, f.Top, f.Left+f.Width, f.Top+f.Height).Contains(AScreenPos)
then
Result := f;
end;
Result := FindSubcontrolAtPos(Result, AScreenPos, AScreenPos);
if (Result is TForm) and (TForm(Result).ClientHandle<>0) then
begin
WinAPI.Windows.GetWindowRect(TForm(Result).ClientHandle, r);
p := TPoint.Create(AScreenPos.X-r.Left, AScreenPos.Y-r.Top);
m := nil;
for i := TForm(Result).MDIChildCount-1 downto 0 do
begin
f := TForm(Result).MDIChildren[i];
if TRect.Create(f.Left, f.Top, f.Left+f.Width, f.Top+f.Height).Contains(p) then
m := f;
end;
if m<>nil then
Result := FindSubcontrolAtPos(m, AScreenPos, p);
end;
end;
I think FindVCLWindow will meet your needs. Once you have the windowed control under the cursor you can walk the parent chain to find the form on which the window lives.
If you want to know the control inside a form that is at a certain x,y coordinate
Use
function TWinControl.ControlAtPos(const Pos: TPoint; AllowDisabled: Boolean;
AllowWinControls: Boolean = False; AllLevels: Boolean = False): TControl;
Given the fact that you seem only interested in forms inside your application, you can just query all forms.
Once you get a non-nil result, you can query the control for its Handle, with code like the following
Pseudo code
function HandleOfControlAtCursor: THandle;
const
AllowDisabled = true;
AllowWinControls = true;
AllLevels = true;
var
CursorPos: TPoint
FormPos: TPoint;
TestForm: TForm;
ControlAtCursor: TControl;
begin
Result:= THandle(0);
GetCursorPos(CursorPos);
for each form in my application do begin
TestForm:= Form_to_test;
FormPos:= TestForm.ScreenToClient(CursorPos);
ControlAtCursor:= TestForm.ControlAtPos(FormPos, AllowDisabled,
AllowWinControls, AllLevels);
if Assigned(ControlAtCursor) then break;
end; {for each}
//Break re-enters here
if Assigned(ControlAtCursor) then begin
while not(ControlAtCursor is TWinControl) do
ControlAtCursor:= ControlAtCursor.Parent;
Result:= ControlAtCursor.Handle;
end; {if}
end;
This also allows you to exclude certain forms from consideration should you so desire. If you're looking for simplicity I'd go with David and use FindVCLWindow.
P.S. Personally I'd use a goto rather than a break, because with a goto it's instantly clear where the break re-enters, but in this case it's not a big issue because there are no statements in between the break and the re-entry point.
How do I get a list of the running processes (with details of PID, Owner etc) on my machine using Delphi?
EDIT: None of the solutions proposed gives me the user that owns the process, only info such as PID, ExeName etc...
One way is using the Tool Help library (see TlHelp32 unit), or EnumProcesses on Windows NT (see PsAPI unit). Have a look at JclSysInfo.RunningProcessesList in the JCL for an example.
Here's a quick example of how to get the user name of a process:
type
PTokenUser = ^TTokenUser;
TTokenUser = packed record
User: SID_AND_ATTRIBUTES;
end;
function GetProcessUserName(ProcessID: Cardinal; out DomainName, UserName: string): Boolean;
var
ProcessHandle, ProcessToken: THandle;
InfoSize, UserNameSize, DomainNameSize: Cardinal;
User: PTokenUser;
Use: SID_NAME_USE;
_DomainName, _UserName: array[0..255] of Char;
begin
Result := False;
DomainName := '';
UserName := '';
ProcessHandle := OpenProcess(PROCESS_QUERY_INFORMATION or PROCESS_VM_READ, False, ProcessID);
if ProcessHandle = 0 then
Exit;
try
if not OpenProcessToken(ProcessHandle, TOKEN_QUERY, ProcessToken) then
Exit;
try
GetTokenInformation(ProcessToken, TokenUser, nil, 0, InfoSize);
User := AllocMem(InfoSize * 2);
try
if GetTokenInformation(ProcessToken, TokenUser, User, InfoSize * 2, InfoSize) then
begin
DomainNameSize := SizeOf(_DomainName);
UserNameSize := SizeOf(_UserName);
Result := LookupAccountSid(nil, User^.User.Sid, _UserName, UserNameSize, _DomainName, DomainNameSize, Use);
if Result then
begin
SetString(DomainName, _DomainName, StrLen(_DomainName));
SetString(UserName, _UserName, StrLen(_UserName));
end;
end;
finally
FreeMem(User);
end;
finally
CloseHandle(ProcessToken);
end;
finally
CloseHandle(ProcessHandle);
end;
end;
This is the function we use to check if a process exists, the FProcessEntry32 holds all the info on the process, so you should be able to extend it to what every you need.
it was taken from here
uses TlHelp32
function processExists(exeFileName: string): Boolean;
{description checks if the process is running
URL: http://www.swissdelphicenter.ch/torry/showcode.php?id=2554}
var
ContinueLoop: BOOL;
FSnapshotHandle: THandle;
FProcessEntry32: TProcessEntry32;
begin
FSnapshotHandle := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
FProcessEntry32.dwSize := SizeOf(FProcessEntry32);
ContinueLoop := Process32First(FSnapshotHandle, FProcessEntry32);
Result := False;
while Integer(ContinueLoop) <> 0 do
begin
if ((UpperCase(ExtractFileName(FProcessEntry32.szExeFile)) =
UpperCase(ExeFileName)) or (UpperCase(FProcessEntry32.szExeFile) =
UpperCase(ExeFileName))) then
begin
Result := True;
end;
ContinueLoop := Process32Next(FSnapshotHandle, FProcessEntry32);
end;
CloseHandle(FSnapshotHandle);
end;
The TProcessEntry32 record looks like so:
tagPROCESSENTRY32 = packed record
dwSize: DWORD;
cntUsage: DWORD;
th32ProcessID: DWORD; // this process
th32DefaultHeapID: DWORD;
th32ModuleID: DWORD; // associated exe
cntThreads: DWORD;
th32ParentProcessID: DWORD; // this process's parent process
pcPriClassBase: Longint; // Base priority of process's threads
dwFlags: DWORD;
szExeFile: array[0..MAX_PATH - 1] of Char;// Path
end;
You have to use:
CreateToolhelp32Snapshot Function
Process32First Function
Process32Next Function
PROCESSENTRY32 Structure will contain all the informations that you may need.
The documentation is from MDSN, for C++, but it's the same in Delphi.
This class will give you a list of all open windows (listed below) with PID, caption, dimensions, etc. It's not exactly running processes information, but I've used it to find apps via it.
// Window List Component 1.5 by Jerry Ryle
//
// Aaugh! I accidentally uploaded the wrong source
// which had a nasty bug in the refresh procedure!
// Thanks to Serge, who found my mistake and suggested
// a few other improvements!
//
// This component will enumerate windows and return
// information about them in the Windows property.
// The component currently returns a handle, caption text,
// associated ProcessID, visibility, and dimensions.
// For documentation, please read the accompanying
// WindowList.txt
//
// This component is completely free of course. If you find
// it useful, and are compelled to send me cash, beer, or
// dead things in envelopes, please feel free to do so.
//
// email me if you make it better: gryle#calpoly.edu
unit WindowList;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;
type
TWindowObject = record
WinHandle : HWnd; // Window Handle
WinCaption : String; // Window Caption Text (If any)
ProcessID : Integer; // Process the window belongs to
IsVisible : Boolean; // Is the window visible?
IsEnabled : Boolean; // Is the window enabled for mouse/keyboard input?
IsIconic : Boolean; // Is the window minimized?
WindowRect : TRect; // Window Dimensions
// Add more properties here if you like,
// then fill them in at the WindowCallback
// function.
end;
PTWindowObject = ^TWindowObject;
TWindowList = class(TComponent)
private
WindowLst : TList;
FCount : Integer;
protected
Function GetAWindow(Index : Integer) : TWindowObject;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
Procedure Refresh;
Property Windows[Index : Integer]: TWindowObject read GetAWindow;
Property Count : Integer read FCount;
published
// Published declarations
end;
procedure Register;
implementation
// Note that this function is not a member of WindowList.
// Therefore, the list to be filled needs to be passed
// as a pointer. Note that this is passed as a VAR. if you
// don't do this, bad things happen in memory.
Function WindowCallback(WHandle : HWnd; Var Parm : Pointer) : Boolean; stdcall;
// This function is called once for each window
Var MyString : PChar;
MyInt : Integer;
MyWindowPtr : ^TWindowObject;
begin
New(MyWindowPtr);
// Window Handle (Passed by the enumeration)
MyWindowPtr.WinHandle := WHandle;
// Window text
MyString := Allocmem(255);
GetWindowText(WHandle,MyString,255);
MyWindowPtr.WinCaption := String(MyString);
FreeMem(MyString,255);
// Process ID
MyInt := 0;
MyWindowPtr.ProcessID := GetWindowThreadProcessId(WHandle,#MyInt);
// Visiblity
MyWindowPtr.IsVisible := IsWindowVisible(WHandle);
// Enabled
MyWindowPtr.IsEnabled := IsWindowEnabled(WHandle);
// Iconic
MyWindowPtr.IsIconic := IsIconic(WHandle);
// Window Dimensions
MyWindowPtr.WindowRect := Rect(0,0,0,0);
GetWindowRect(WHandle,MyWindowPtr.WindowRect);
// Add the structure to the list. Do not dereference Parm...
// once again, bad things happen.
TList(Parm).Add(MyWindowPtr);
Result := True; // Everything's okay. Continue to enumerate windows
end;
constructor TWindowList.Create(AOwner: TComponent);
var MyWindowPtr : PTWindowObject;
begin
inherited;
WindowLst := TList.Create;
// Thanks Serge, I should've done this from the start :)
// Sloppy me.
If Not ( csDesigning in ComponentState ) Then
Begin
EnumWindows(#WindowCallback,Longint(#WindowLst));
FCount := WindowLst.Count;
End
Else
FCount := 0;
end;
destructor TWindowList.Destroy;
var I : Integer;
begin
If WindowLst.Count > 0 Then
Begin
For I := 0 To (WindowLst.Count - 1) Do
Dispose(PTWindowObject(WindowLst[I]));
End;
WindowLst.Free;
inherited;
end;
procedure TWindowList.Refresh;
begin
WindowLst.Clear; {Clear the list!}
EnumWindows(#WindowCallback,Longint(#WindowLst));
FCount := WindowLst.Count;
end;
function TWindowList.GetAWindow(Index : Integer) : TWindowObject;
begin
Result := PTWindowObject(WindowLst[Index])^;
end;
procedure Register;
begin
RegisterComponents('System', [TWindowList]);
end;
end.
You could look at using the WMISet components ($69 single licence, $199 for site licence, trial version available). The TWmiProcessControl component seems to encapsulate calls to Win32_Process. They also have an example of getting a process owner.
I think Madshi madKernel could be interesting to check out.
We need to validate an user on Microsoft's Active Directory using Delphi 7, what is the best way to do that?
We can have two scenarios: the user inputs its network username and password, where the username may include the domain, and we check on active directory if it is a valid, active user. Or we get the current logged user from Windows, and check on AD if it is still valid.
The first scenario requires user validation, while the second one just a simple AD search and locate.
Does anyone know of components or code that do one or both of the scenarios described above?
Here's a unit we wrote and use. Simple and gets the job done.
unit ADSI;
interface
uses
SysUtils, Classes, ActiveX, Windows, ComCtrls, ExtCtrls, ActiveDs_TLB,
adshlp, oleserver, Variants;
type
TPassword = record
Expired: boolean;
NeverExpires: boolean;
CannotChange: boolean;
end;
type
TADSIUserInfo = record
UID: string;
UserName: string;
Description: string;
Password: TPassword;
Disabled: boolean;
LockedOut: boolean;
Groups: string; //CSV
end;
type
TADSI = class(TComponent)
private
FUserName: string;
FPassword: string;
FCurrentUser: string;
FCurrentDomain: string;
function GetCurrentUserName: string;
function GetCurrentDomain: string;
protected
{ Protected declarations }
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
property CurrentUserName: string read FCurrentUser;
property CurrentDomain: string read FCurrentDomain;
function GetUser(Domain, UserName: string; var ADSIUser: TADSIUserInfo): boolean;
function Authenticate(Domain, UserName, Group: string): boolean;
published
property LoginUserName: string read FUserName write FUserName;
property LoginPassword: string read FPassword write FPassword;
end;
procedure Register;
implementation
function ContainsValComma(s1,s: string): boolean;
var
sub,str: string;
begin
Result:=false;
if (s='') or (s1='') then exit;
if SameText(s1,s) then begin
Result:=true;
exit;
end;
sub:=','+lowercase(trim(s1))+','; str:=','+lowercase(trim(s))+',';
Result:=(pos(sub, str)>0);
end;
procedure Register;
begin
RegisterComponents('ADSI', [TADSI]);
end;
constructor TADSI.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FCurrentUser:=GetCurrentUserName;
FCurrentDomain:=GetCurrentDomain;
FUserName:='';
FPassword:='';
end;
destructor TADSI.Destroy;
begin
inherited Destroy;
end;
function TADSI.GetCurrentUserName : string;
const
cnMaxUserNameLen = 254;
var
sUserName : string;
dwUserNameLen : DWord;
begin
dwUserNameLen := cnMaxUserNameLen-1;
SetLength(sUserName, cnMaxUserNameLen );
GetUserName(PChar(sUserName), dwUserNameLen );
SetLength(sUserName, dwUserNameLen);
Result := sUserName;
end;
function TADSI.GetCurrentDomain: string;
const
DNLEN = 255;
var
sid : PSID;
sidSize : DWORD;
sidNameUse : DWORD;
domainNameSize : DWORD;
domainName : array[0..DNLEN] of char;
begin
sidSize := 65536;
GetMem(sid, sidSize);
domainNameSize := DNLEN + 1;
sidNameUse := SidTypeUser;
try
if LookupAccountName(nil, PChar(FCurrentUser), sid, sidSize,
domainName, domainNameSize, sidNameUse) then
Result:=StrPas(domainName);
finally
FreeMem(sid);
end;
end;
function TADSI.Authenticate(Domain, UserName, Group: string): boolean;
var
aUser: TADSIUserInfo;
begin
Result:=false;
if GetUser(Domain,UserName,aUser) then begin
if not aUser.Disabled and not aUser.LockedOut then begin
if Group='' then
Result:=true
else
Result:=ContainsValComma(Group, aUser.Groups);
end;
end;
end;
function TADSI.GetUser(Domain, UserName: string; var ADSIUser: TADSIUserInfo): boolean;
var
usr : IAdsUser;
flags : integer;
Enum : IEnumVariant;
grps : IAdsMembers;
grp : IAdsGroup;
varGroup : OleVariant;
Temp : LongWord;
dom1, uid1: string;
//ui: TADSIUserInfo;
begin
ADSIUser.UID:='';
ADSIUser.UserName:='';
ADSIUser.Description:='';
ADSIUser.Disabled:=true;
ADSIUser.LockedOut:=true;
ADSIUser.Groups:='';
Result:=false;
if UserName='' then
uid1:=FCurrentUser
else
uid1:=UserName;
if Domain='' then
dom1:=FCurrentDomain
else
dom1:=Domain;
if uid1='' then exit;
if dom1='' then exit;
try
if trim(FUserName)<>'' then
ADsOpenObject('WinNT://' + dom1 + '/' + uid1, FUserName, FPassword, 1, IADsUser, usr)
else
ADsGetObject('WinNT://' + dom1 + '/' + uid1, IADsUser, usr);
if usr=nil then exit;
ADSIUser.UID:= UserName;
ADSIUser.UserName := usr.FullName;
ADSIUser.Description := usr.Description;
flags := usr.Get('userFlags');
ADSIUser.Password.Expired := usr.Get('PasswordExpired');
ADSIUser.Password.CannotChange := (flags AND ADS_UF_PASSWD_CANT_CHANGE)<>0;
ADSIUser.Password.NeverExpires := (flags and ADS_UF_DONT_EXPIRE_PASSWD)<>0;
ADSIUser.Disabled := usr.AccountDisabled;
ADSIUser.LockedOut := usr.IsAccountLocked;
ADSIUser.Groups:='';
grps := usr.Groups;
Enum := grps._NewEnum as IEnumVariant;
if Enum <> nil then begin
while (Enum.Next(1,varGroup, Temp) = S_OK) do begin
grp := IDispatch(varGroup) as IAdsGroup;
//sGroupType := GetGroupType(grp);
if ADSIUser.Groups<>'' then ADSIUser.Groups:=ADSIUser.Groups+',';
ADSIUser.Groups:=ADSIUser.Groups+grp.Name;
VariantClear(varGroup);
end;
end;
usr:=nil;
Result:=true;
except
on e: exception do begin
Result:=false;
exit;
end;
end;
end;
end.
I'm flattered to see my ADSISearch component mentioned here :-), but in order to simply validate user credentials, you're probably even better off using the "LogonUser" Win32 API. I'm pretty sure (not doing any Delphi work anymore myself) that there's an implementation of that floating around somewhere - probably in the JVCL library or somewhere else.
I've always used the 'ADSISearch.pas' unit for working with AD, with great success. Also, here is some code I used (that uses this unit) to retrieve a user's HOMEDRIVE info from their AD object:
try
ADSISearch1.Filter := WideString('samaccountname=' + GetUserFromWindows());
try
ADSISearch1.Search;
slTemp := ADSISearch1.GetFirstRow();
except
//uh-oh, this is a problem, get out of here
// --- must not have been able to talk to AD
// --- could be the user recently changed pwd and is logged in with
// their cached credentials
// just suppress this exception
bHomeDriveMappingFailed := True;
Result := bSuccess;
Exit;
end;
while (slTemp <> nil) do
begin
for ix := 0 to slTemp.Count - 1 do
begin
curLine := AnsiUpperCase(slTemp[ix]);
if AnsiStartsStr('HOMEDIRECTORY', curLine) then
begin
sADHomeDriveUncPath := AnsiReplaceStr(curLine, 'HOMEDIRECTORY=', '');
//sADHomeDriveUncPath := slTemp[ix];
end
else if AnsiStartsStr('HOMEDRIVE', curLine) then
begin
sADHomeDriveLetter := AnsiReplaceStr(curLine, 'HOMEDRIVE=', '');
//sADHomeDriveLetter := slTemp[ix];
end;
end;
FreeAndNil(slTemp);
slTemp := ADSISearch1.GetNextRow();
end;
except
//suppress this exception
bHomeDriveMappingFailed := True;
Exit;
end;
And without further delay, here is the unit (not written by me):
(* ----------------------------------------------------------------------------
Module: ADSI Searching in Delphi
Author: Marc Scheuner
Date: July 17, 2000
Changes:
Description:
constructor Create(aOwner : TComponent); override;
Creates a new instance of component
destructor Destroy; override;
Frees instance of component
function CheckIfExists() : Boolean;
Checks to see if the object described in the properties exists or not
TRUE: Object exists, FALSE: object does not exist
procedure Search;
Launches the ADSI search - use GetFirstRow and GetNextRow to retrieve information
function GetFirstRow() : TWideStringList;
function GetNextRow() : TWideStringList;
Returns the first row / next row of the result set, as a WideStringList.
The values are stored in the string list as a <name>=<value> pair, so you
can access the values via the FWideStringList.Values['name'] construct.
Multivalued attributes are returned as one per line, in an array index
manner:
objectClass[0]=top
objectClass[1]=Person
objectClass[2]=organizationalPerson
objectClass[3]=user
and so forth. The index is zero-based.
If there are no (more) rows, the return value will be NIL.
It's up to the receiver to free the string list when no longer needed.
property Attributes : WideString
Defines the attributes you want to retrieve from the object. If you leave
this empty, all available attributes will be returned.
You can specify multiple attributes separated by comma:
cn,distinguishedName,name,ADsPath
will therefore retrieve these four attributes for all the objects returned
in the search (if the attributes exist).
property BaseIADs : IADs
If you already have an interface to an IADs object, you can reuse it here
by setting it to the BaseIADs property - in this case, ADSISearch can skip
the step of binding to the ADSI object and will be executing faster.
property BasePath : WideString
LDAP base path for the search - the further down in the LDAP tree you start
searching, the smaller the namespace to search and the quicker the search
will return what you're looking for.
LDAP://cn=Users,dc=stmaarten,dc=qc,dc=rnd
is the well-known LDAP path for the Users container in the stmaarten.qc.rnd
domain.
property ChaseReferrals : Boolean
If set to TRUE, the search might need to connect to other domain controllers
and naming contexts, which is very time consuming.
Set this property to FALSE to limit it to the current naming context, thus
speeding up searches significantly.
property DirSrchIntf : IDirectorySearch
Provides access to the basic Directory Search interface, in case you need
to do some low-level tweaking
property Filter : WideString
LDAP filter expression to search for. It will be ANDed together with a
(objectClass=<ObjectClass>) filter to form the full search filter.
It can be anything that is a valid LDAP search filter - see the appropriate
books or online help files for details.
It can be (among many other things):
cn=Marc*
badPwdCount>=0
countryCode=49
givenName=Steve
and multiple conditions can be ANDed or ORed together using the LDAP syntax.
property MaxRows : Integer
Maximum rows of the result set you want to retrieve.
Default is 0 which means all rows.
property PageSize : Integer
Maximum number of elements to be returned in a paged search. If you set this to 0,
the search will *not* be "paged", e.g. IDirectorySearch will return all elements
found in one big gulp, but there's a limit at 1'000 elements.
With paged searching, you can search and find any number of AD objects. Default is
set to 100 elements. No special need on the side of the developer / user to use
paged searches - just set the PageSize to something non-zero.
property ObjectClass: WideString
ObjectClass of the ADSI object you are searching for. This allows you to
specify e.g. just users, only computers etc.
Be aware that ObjectClass is a multivalued attribute in LDAP, and sometimes
has unexpected hierarchies (e.g."computer" descends from "user" and will therefore
show up if you search for object class "user").
This property will be included in the LDAP search filter passed to the
search engine. If you don't want to limit the objects returned, just leave
it at the default value of *
property SearchScope
Limits the scope of the search.
scBase: search only the base object (as specified by the LDAP path) - not very
useful.....
scOneLevel: search only object immediately contained by the specified base
object (does not include baes object) - limits the depth of
the search
scSubtree: no limit on how "deep" the search goes, below the specified
base object - this is the default.
---------------------------------------------------------------------------- *)
unit ADSISearch;
interface
uses
ActiveX,
ActiveDs_TLB,
Classes,
SysUtils
{$IFDEF UNICODE}
,Unicode
{$ENDIF}
;
type
EADSISearchException = class(Exception);
TSearchScope = (scBase, scOneLevel, scSubtree);
TADSISearch = class(TComponent)
private
FBaseIADs : IADs;
FDirSrchIntf : IDirectorySearch;
FSearchHandle : ADS_SEARCH_HANDLE;
FAttributes,
FFilter,
FBasePath,
FObjectClass : Widestring;
FResult : HRESULT;
FChaseReferrals,
FSearchExecuted : Boolean;
FMaxRows,
FPageSize : Integer;
FSearchScope : TSearchScope;
FUsername: Widestring;
FPassword: Widestring;
{$IFDEF UNICODE}
procedure EnumerateColumns(aStrList : TWideStringList);
{$ELSE}
procedure EnumerateColumns(aStrList : TStringList);
{$ENDIF}
function GetStringValue(oSrchColumn : ads_search_column; Index : Integer) : WideString;
procedure SetBaseIADs(const Value: IADs);
procedure SetBasePath(const Value: WideString);
procedure SetFilter(const Value: WideString);
procedure SetObjectClass(const Value: Widestring);
procedure SetMaxRows(const Value: Integer);
procedure SetPageSize(const Value: Integer);
procedure SetAttributes(const Value: WideString);
procedure SetChaseReferrals(const Value: Boolean);
procedure SetUsername(const Value: WideString);
procedure SetPassword(const Value: WideString);
public
constructor Create(aOwner : TComponent); override;
destructor Destroy; override;
function CheckIfExists() : Boolean;
procedure Search;
{$IFDEF UNICODE}
function GetFirstRow() : TWideStringList;
function GetNextRow() : TWideStringList;
{$ELSE}
function GetFirstRow() : TStringList;
function GetNextRow() : TStringList;
{$ENDIF}
published
// list of attributes to return - empty string equals all attributes
property Attributes : WideString read FAttributes write SetAttributes;
// search base - both as an IADs interface, as well as a LDAP path
property BaseIADs : IADs read FBaseIADs write SetBaseIADs stored False;
property BasePath : WideString read FBasePath write SetBasePath;
// chase possible referrals to other domain controllers?
property ChaseReferrals : Boolean read FChaseReferrals write SetChaseReferrals default False;
// "raw" search interface - for any low-level tweaking necessary
property DirSrchIntf : IDirectorySearch read FDirSrchIntf;
// LDAP filter to limit the search
property Filter : WideString read FFilter write SetFilter;
// maximum number of rows to return - 0 = all rows (no limit)
property MaxRows : Integer read FMaxRows write SetMaxRows default 0;
property ObjectClass : Widestring read FObjectClass write SetObjectClass;
property PageSize : Integer read FPageSize write SetPageSize default 100;
property SearchScope : TSearchScope read FSearchScope write FSearchScope default scSubtree;
property Username : Widestring read FUsername write SetUsername;
property Password : Widestring read FPassword write SetPassword;
end;
const
// ADSI success codes
S_ADS_ERRORSOCCURRED = $00005011;
S_ADS_NOMORE_ROWS = $00005012;
S_ADS_NOMORE_COLUMNS = $00005013;
// ADSI error codes
E_ADS_BAD_PATHNAME = $80005000;
E_ADS_INVALID_DOMAIN_OBJECT = $80005001;
E_ADS_INVALID_USER_OBJECT = $80005002;
E_ADS_INVALID_COMPUTER_OBJECT = $80005003;
E_ADS_UNKNOWN_OBJECT = $80005004;
E_ADS_PROPERTY_NOT_SET = $80005005;
E_ADS_PROPERTY_NOT_SUPPORTED = $80005006;
E_ADS_PROPERTY_INVALID = $80005007;
E_ADS_BAD_PARAMETER = $80005008;
E_ADS_OBJECT_UNBOUND = $80005009;
E_ADS_PROPERTY_NOT_MODIFIED = $8000500A;
E_ADS_PROPERTY_MODIFIED = $8000500B;
E_ADS_CANT_CONVERT_DATATYPE = $8000500C;
E_ADS_PROPERTY_NOT_FOUND = $8000500D;
E_ADS_OBJECT_EXISTS = $8000500E;
E_ADS_SCHEMA_VIOLATION = $8000500F;
E_ADS_COLUMN_NOT_SET = $80005010;
E_ADS_INVALID_FILTER = $80005014;
procedure Register;
(*============================================================================*)
(* IMPLEMENTATION *)
(*============================================================================*)
implementation
uses
Windows;
var
ActiveDSHandle : THandle;
gADsGetObject: function(pwcPathName: PWideChar; const xRIID: TGUID; out pVoid): HResult; stdcall;
gFreeADsMem : function(aPtr : Pointer) : BOOL; stdcall;
// Active Directory API helper functions - implemented in ActiveDs.DLL and
// dynamically loaded at time of initialization of this module
function ADsGetObject(pwcPathName: PWideChar; const xRIID: TGUID; var pVoid): HResult;
begin
Result := gADsGetObject(pwcPathName, xRIID, pVoid);
end;
function FreeADsMem(aPtr : Pointer) : BOOL;
begin
Result := gFreeADsMem(aPtr);
end;
// resource strings for all messages - makes localization so much easier!
resourcestring
rc_CannotLoadActiveDS = 'Cannot load ActiveDS.DLL';
rc_CannotGetProcAddress = 'Cannot GetProcAddress of ';
rc_CouldNotBind = 'Could not bind to object %s (%x)';
rc_CouldNotFreeSH = 'Could not free search handle (%x)';
rc_CouldNotGetIDS = 'Could not obtain IDirectorySearch interface for %s (%x)';
rc_GetFirstFailed = 'GetFirstRow failed (%x)';
rc_GetNextFailed = 'GetNextRow failed (%x)';
rc_SearchFailed = 'Search in ADSI failed (result code %x)';
rc_SearchNotExec = 'Search has not been executed yet';
rc_SetSrchPrefFailed = 'Setting the max row limit failed (%x)';
rc_UnknownDataType = '(unknown data type %d)';
// ---------------------------------------------------------------------------
// Constructor and destructor
// ---------------------------------------------------------------------------
constructor TADSISearch.Create(aOwner : TComponent);
begin
inherited Create(aOwner);
FBaseIADs := nil;
FDirSrchIntf := nil;
FAttributes := '';
FBasePath := '';
FFilter := '';
FObjectClass := '*';
FMaxRows := 0;
FPageSize := 100;
FChaseReferrals := False;
FSearchScope := scSubtree;
FSearchExecuted := False;
end;
destructor TADSISearch.Destroy;
begin
if (FSearchHandle <> 0) then
FResult := FDirSrchIntf.CloseSearchHandle(FSearchHandle);
FBaseIADs := nil;
FDirSrchIntf := nil;
inherited;
end;
// ---------------------------------------------------------------------------
// Set and Get methods
// ---------------------------------------------------------------------------
procedure TADSISearch.SetPassword(const Value: WideString);
begin
if (FPassword <> Value) then
begin
FPassword := Value;
end;
end;
procedure TADSISearch.SetUsername(const Value: WideString);
begin
if (FUsername <> Value) then
begin
FUsername := Value;
end;
end;
procedure TADSISearch.SetAttributes(const Value: WideString);
begin
if (FAttributes <> Value) then begin
FAttributes := Value;
end;
end;
// the methods to set the search base always need to update the other property
// as well, in order to make sure the base IADs interface and the BasePath
// property stay in sync
// setting the search base will require a new search
// therefore set internal flag FSearchExecuted to false
procedure TADSISearch.SetBaseIADs(const Value: IADs);
begin
if (FBaseIADs <> Value) then begin
FBaseIADs := Value;
FBasePath := FBaseIADs.ADsPath;
FSearchExecuted := False;
end;
end;
procedure TADSISearch.SetBasePath(const Value: WideString);
begin
if (FBasePath <> Value) then begin
FBasePath := Value;
FBaseIADs := nil;
FSearchExecuted := False;
end;
end;
procedure TADSISearch.SetChaseReferrals(const Value: Boolean);
begin
if (FChaseReferrals <> Value) then begin
FChaseReferrals := Value;
end;
end;
// setting the filter will require a new search
// therefore set internal flag FSearchExecuted to false
procedure TADSISearch.SetFilter(const Value: WideString);
begin
if (FFilter <> Value) then begin
FFilter := Value;
FSearchExecuted := False;
end;
end;
procedure TADSISearch.SetMaxRows(const Value: Integer);
begin
if (Value >= 0) and (Value <> FMaxRows) then begin
FMaxRows := Value;
end;
end;
procedure TADSISearch.SetPageSize(const Value: Integer);
begin
if (Value >= 0) and (Value <> FPageSize) then begin
FPageSize := Value;
end;
end;
// setting the object category will require a new search
// therefore set internal flag FSearchExecuted to false
procedure TADSISearch.SetObjectClass(const Value: Widestring);
begin
if (FObjectClass <> Value) then begin
if (Value = '') then
FObjectClass := '*'
else
FObjectClass := Value;
FSearchExecuted := False;
end;
end;
// ---------------------------------------------------------------------------
// Private helper methods
// ---------------------------------------------------------------------------
// EnumerateColumns iterates through all the columns in the current row of
// the search results and builds the string list of results
{$IFDEF UNICODE}
procedure TADSISearch.EnumerateColumns(aStrList: TWideStringList);
{$ELSE}
procedure TADSISearch.EnumerateColumns(aStrList: TStringList);
{$ENDIF}
var
ix : Integer;
bMultiple : Boolean;
pwColName : PWideChar;
oSrchColumn : ads_search_column;
wsColName, wsValue : WideString;
begin
// determine name of next column to fetch
FResult := FDirSrchIntf.GetNextColumnName(FSearchHandle, pwColName);
// as long as no error occured and we still do have columns....
while Succeeded(FResult) and (FResult <> S_ADS_NOMORE_COLUMNS) do begin
// get the column from the result set
FResult := FDirSrchIntf.GetColumn(FSearchHandle, pwColName, oSrchColumn);
if Succeeded(FResult) then begin
// check if it's a multi-valued attribute
bMultiple := (oSrchColumn.dwNumValues > 1);
if bMultiple then begin
// if it's a multi-valued attribute, iterate through the values
for ix := 0 to oSrchColumn.dwNumValues-1 do begin
wsColName := Format('%s[%d]', [oSrchColumn.pszAttrName, ix]);
wsValue := GetStringValue(oSrchColumn, ix);
aStrList.Add(wsColName + '=' + wsValue);
end;
end
else begin
// single valued attributes are quite straightforward
wsColName := oSrchColumn.pszAttrName;
wsValue := GetStringValue(oSrchColumn, 0);
aStrList.Add(wsColName + '=' + wsValue);
end;
end;
// free the memory associated with the search column, and the column name
FDirSrchIntf.FreeColumn(oSrchColumn);
FreeADsMem(pwColName);
// get next column name
FResult := FDirSrchIntf.GetNextColumnName(FSearchHandle, pwColName);
end;
end;
// Get string value will turn the supported types of data into a string representation
// for inclusion in the resulting string list
// For a complete list of possible values, see the ADSTYPE_xxx constants in the
// ActiveDs_TLB.pas file
function TADSISearch.GetStringValue(oSrchColumn: ads_search_column; Index: Integer): WideString;
var
wrkPointer : PADSValue;
oSysTime : _SYSTEMTIME;
dtDate,
dtTime : TDateTime;
begin
Result := '';
// advance the value pointer to the correct one of the potentially multiple
// values in the "array of values" for this attribute
wrkPointer := oSrchColumn.pADsValues;
Inc(wrkPointer, Index);
// depending on the type of the value, turning it into a string is more
// or less straightforward
case oSrchColumn.dwADsType of
ADSTYPE_CASE_EXACT_STRING : Result := wrkPointer^.__MIDL_0010.CaseExactString;
ADSTYPE_CASE_IGNORE_STRING : Result := wrkPointer^.__MIDL_0010.CaseIgnoreString;
ADSTYPE_DN_STRING : Result := wrkPointer^.__MIDL_0010.DNString;
ADSTYPE_OBJECT_CLASS : Result := wrkPointer^.__MIDL_0010.ClassName;
ADSTYPE_PRINTABLE_STRING : Result := wrkPointer^.__MIDL_0010.PrintableString;
ADSTYPE_NUMERIC_STRING : Result := wrkPointer^.__MIDL_0010.NumericString;
ADSTYPE_BOOLEAN : Result := IntToStr(wrkPointer^.__MIDL_0010.Boolean);
ADSTYPE_INTEGER : Result := IntToStr(wrkPointer^.__MIDL_0010.Integer);
ADSTYPE_LARGE_INTEGER : Result := IntToStr(wrkPointer^.__MIDL_0010.LargeInteger);
ADSTYPE_UTC_TIME:
begin
// ADS_UTC_TIME maps to a _SYSTEMTIME structure
Move(wrkPointer^.__MIDL_0010.UTCTime, oSysTime, SizeOf(oSysTime));
// create two TDateTime values for the date and the time
dtDate := EncodeDate(oSysTime.wYear, oSysTime.wMonth, oSysTime.wDay);
dtTime := EncodeTime(oSysTime.wHour, oSysTime.wMinute, oSysTime.wSecond, oSysTime.wMilliseconds);
// add the two TDateTime's (really only a Float), and turn into a string
Result := DateTimeToStr(dtDate+dtTime);
end;
else Result := Format(rc_UnknownDataType, [oSrchColumn.dwADsType]);
end;
end;
// ---------------------------------------------------------------------------
// Public methods
// ---------------------------------------------------------------------------
// Check if any object matching the criteria as defined in the properties exists
function TADSISearch.CheckIfExists(): Boolean;
var
{$IFDEF UNICODE}
slTemp : TWideStringList;
{$ELSE}
slTemp : TStringList;
{$ENDIF}
iOldMaxRows : Integer;
wsOldAttributes : WideString;
begin
Result := False;
// save the settings of the MaxRows and Attributes properties
iOldMaxRows := FMaxRows;
wsOldAttributes := FAttributes;
try
// set the attributes to return just one row (that's good enough for
// making sure it exists), and the Attribute of instanceType which is
// one attribute that must exist for any of the ADSI objects
FMaxRows := 1;
FAttributes := 'instanceType';
try
Search;
// did we get any results?? If so, at least one object exists!
slTemp := GetFirstRow();
Result := (slTemp <> nil);
slTemp.Free;
except
on EADSISearchException do ;
end;
finally
// restore the attributes to what they were before
FMaxRows := iOldMaxRows;
FAttributes := wsOldAttributes;
end;
end;
{$IFDEF UNICODE}
function TADSISearch.GetFirstRow(): TWideStringList;
var
slTemp : TWideStringList;
{$ELSE}
function TADSISearch.GetFirstRow(): TStringList;
var
slTemp : TStringList;
{$ENDIF}
begin
slTemp := nil;
try
if FSearchExecuted then begin
// get the first row of the result set
FResult := FDirSrchIntf.GetFirstRow(FSearchHandle);
// did we succeed? ATTENTION: if we don't have any more rows,
// we still get a "success" value back from ADSI!!
if Succeeded(FResult) then begin
// any more rows in the result set?
if (FResult <> S_ADS_NOMORE_ROWS) then begin
// create a string list
{$IFDEF UNICODE}
slTemp := TWideStringList.Create;
{$ELSE}
slTemp := TStringList.Create;
{$ENDIF}
// enumerate all columns into that resulting string list
EnumerateColumns(slTemp);
end;
end
else begin
raise EADSISearchException.CreateFmt(rc_GetFirstFailed, [FResult]);
end;
end
else begin
raise EADSISearchException.Create(rc_SearchNotExec);
end;
finally
Result := slTemp;
end;
end;
{$IFDEF UNICODE}
function TADSISearch.GetNextRow(): TWideStringList;
var
slTemp : TWideStringList;
{$ELSE}
function TADSISearch.GetNextRow(): TStringList;
var
slTemp : TStringList;
{$ENDIF}
begin
slTemp := nil;
try
if FSearchExecuted then begin
// get the next row of the result set
FResult := FDirSrchIntf.GetNextRow(FSearchHandle);
// did we succeed? ATTENTION: if we don't have any more rows,
// we still get a "success" value back from ADSI!!
if Succeeded(FResult) then begin
// any more rows in the result set?
if (FResult <> S_ADS_NOMORE_ROWS) then begin
// create result string list
{$IFDEF UNICODE}
slTemp := TWideStringList.Create;
{$ELSE}
slTemp := TStringList.Create;
{$ENDIF}
// enumerate all columns in result set
EnumerateColumns(slTemp);
end;
end
else begin
raise EADSISearchException.CreateFmt(rc_GetNextFailed, [FResult]);
end;
end
else begin
raise EADSISearchException.Create(rc_SearchNotExec);
end;
finally
Result := slTemp;
end;
end;
// this is the core piece of the component - the actual search method
procedure TADSISearch.Search;
var
ix : Integer;
wsFilter : WideString;
{$IFDEF UNICODE}
slTemp : TWideStringList;
{$ELSE}
slTemp : TStringList;
{$ENDIF}
AttrCount : Cardinal;
AttrArray : array of WideString;
SrchPrefInfo : array of ads_searchpref_info;
DSO :IADsOpenDSObject;
Dispatch:IDispatch;
begin
// check to see if we have assigned an IADs, if not, bind to it
if (FBaseIADs = nil) then begin
ADsGetObject('LDAP:', IID_IADsOpenDSObject, DSO);
Dispatch := DSO.OpenDSObject(FBasePath, FUsername, FPassword, ADS_SECURE_AUTHENTICATION);
FResult := Dispatch.QueryInterface(IID_IADs, FBaseIADs);
//FResult := ADsGetObject(#FBasePath[1], IID_IADs, FBaseIADs);
if not Succeeded(FResult) then begin
raise EADSISearchException.CreateFmt(rc_CouldNotBind, [FBasePath, FResult]);
end;
end;
// get the IDirectorySearch interface from the base object
FDirSrchIntf := (FBaseIADs as IDirectorySearch);
if (FDirSrchIntf = nil) then begin
raise EADSISearchException.CreateFmt(rc_CouldNotGetIDS, [FBasePath, FResult]);
end;
// if we still have a valid search handle => close it
if (FSearchHandle <> 0) then begin
FResult := FDirSrchIntf.CloseSearchHandle(FSearchHandle);
if not Succeeded(FResult) then begin
raise EADSISearchException.CreateFmt(rc_CouldNotFreeSH, [FResult]);
end;
end;
// we are currently setting 3 search preferences
// for a complete list of possible search preferences, please check
// the ADS_SEARCHPREF_xxx values in ActiveDs_TLB.pas
SetLength(SrchPrefInfo, 4);
// Set maximum number of rows to be what is defined in the MaxRows property
SrchPrefInfo[0].dwSearchPref := ADS_SEARCHPREF_SIZE_LIMIT;
SrchPrefInfo[0].vValue.dwType := ADSTYPE_INTEGER;
SrchPrefInfo[0].vValue.__MIDL_0010.Integer := FMaxRows;
// set the "chase referrals" search preference
SrchPrefInfo[1].dwSearchPref := ADS_SEARCHPREF_CHASE_REFERRALS;
SrchPrefInfo[1].vValue.dwType := ADSTYPE_BOOLEAN;
SrchPrefInfo[1].vValue.__MIDL_0010.Boolean := Ord(FChaseReferrals);
// set the "search scope" search preference
SrchPrefInfo[2].dwSearchPref := ADS_SEARCHPREF_SEARCH_SCOPE;
SrchPrefInfo[2].vValue.dwType := ADSTYPE_INTEGER;
SrchPrefInfo[2].vValue.__MIDL_0010.Integer := Ord(FSearchScope);
// set the "page size " search preference
SrchPrefInfo[3].dwSearchPref := ADS_SEARCHPREF_PAGESIZE;
SrchPrefInfo[3].vValue.dwType := ADSTYPE_INTEGER;
SrchPrefInfo[3].vValue.__MIDL_0010.Integer := FPageSize;
// set the search preferences of our directory search interface
FResult := FDirSrchIntf.SetSearchPreference(Pointer(SrchPrefInfo), Length(SrchPrefInfo));
if not Succeeded(FResult) then begin
raise EADSISearchException.CreateFmt(rc_SetSrchPrefFailed,
Google for using ADSI with Delphi, you can find some articles talking about that
Active Directory Service Interfaces
Using ADSI in Delphi
and you can also look at online-admin which they offer components to manage many of windows services including AD