I am trying to write a spec utility library.
One of the Specification is a TExpressionSpecification. Basically, it implements the Specification pattern by evaluating an inner TExpression.
One of the TExpression is a TPropertyExpression. It's simply an expression that gets the value of a property by its name with Rtti.
I implemented it the simplest way I could, but really cannot understand why it throws an AV at me.
I stepped throrouly with the debugger. All types are what they are supposed to be. I just dont know why the TRttiProperty.GetValue is wrecking havoc.
Can anybody help?
unit Spec;
interface
uses
Classes;
type
TPropertyExpression<TObjectType, TResultType> = class
private
FPropertyName: string;
public
constructor Create(aPropertyName: string); reintroduce;
function Evaluate(aObject: TObjectType): TResultType;
property PropertyName: string read FPropertyName write FPropertyName;
end;
procedure TestIt;
implementation
uses
Rtti;
constructor TPropertyExpression<TObjectType, TResultType>.Create(aPropertyName:
string);
begin
inherited Create;
PropertyName := aPropertyName;
end;
function TPropertyExpression<TObjectType, TResultType>.Evaluate(aObject:
TObjectType): TResultType;
var
aCtx : TRttiContext;
aModelType : TRttiType;
aResultType : TRttiType;
aProperty : TRttiProperty;
aValue : TValue;
begin
aCtx := TRttiContext.Create;
aModelType := aCtx.GetType(System.TypeInfo(TObjectType));
aResultType := aCtx.GetType(System.TypeInfo(TResultType));
aProperty := aModelType.GetProperty(PropertyName);
aValue := aProperty.GetValue(Addr(aObject));
Result := aValue.AsType<TResultType>;
end;
procedure TestIt;
var
aComponent : TComponent;
aSpec : TPropertyExpression<TComponent, string>;
begin
aComponent := TComponent.Create(nil);
aComponent.Name := 'ABC';
aSpec := TPropertyExpression<TComponent, string>.Create('Name');
WriteLn(aSpec.Evaluate(aComponent));
Readln;
end;
end.
GetValue expects the instance pointer (aObject) but you are passing it the address of the pointer variable (#aObject).
Constrain your TObjectType to a class type:
type
TPropertyExpression<TObjectType: class; TResultType> = class...
Then, instead of Addr(aObject), pass the instance directly:
aValue := aProperty.GetValue(Pointer(aObject));
This question already has answers here:
Delphi: Access Violation at the end of Create() constructor
(2 answers)
Closed 7 years ago.
I have a program that makes a bike (TObject)
When calling my Create method, I get an access violation error 00453359 and a write of address 00000004.
constructor MyBike.Create(iPrice, iStroke, iYear, iCC: Integer; sName,
sModel: string);
begin
fCC := iCC; // <- Here is the error
fPrice := iPrice;
fStroke := iStroke;
fYear := iYear;
fName := sName;
fModel := sModel;
When I watch that line, it says that it is an inaccessible value, as for all the variables there.
Here is the rest of my class:
type
MyBike = class(TObject)
private
fCC, fStroke, fYear, fPrice: Integer; //I will at a later stage use fPrice as a currency
fName, fModel: string;
public
constructor Create(iPrice, iStroke, iYear, iCC: Integer; sName, sModel:
string);
function GetValues: string;
end;
implementation
{ MyBike }
constructor MyBike.Create(iPrice, iStroke, iYear, iCC: Integer; sName,
sModel: string);
begin
fCC := iCC;
fPrice := iPrice;
fStroke := iStroke;
fYear := iYear;
fName := sName;
fModel := sModel;
end;
and my main unit:
private
{ Private declarations }
NewBike : MyBike;
public
{ Public declarations }
end;
var
Form1: TForm1;
redtSavedObject: TRichEdit;
btnClearSavedObject: TButton;
implementation
{$R *.dfm}
procedure TForm1.FormCreate(Sender: TObject);
begin
btnSaveToText.Enabled := False;
btnSavetodata.Enabled := False;
end;
procedure TForm1.btnSaveasObjectClick(Sender: TObject);
var
Price, Year, CC, Stroke : Integer;
Name, Model : String;
begin
Price := StrToInt(edtPrice.Text); //All of these values are fine
Year := StrToInt(edtYear.Text);
CC := StrToInt(edtCC.Text);
Stroke := StrToInt(edtStroke.Text);
Name := edtName.Text;
Model := edtModel.Text;
NewBike.Create(Price, Stroke, Year, CC, Name, Model);
I looked at this post: Delphi strange inaccessible value (acess violation) o.O and says I must edit the project settings to:
Debug info: ON
Local Symbols: ON
Optimization: OFF.
Ive done a rebuild, still no change. Ive gone as far as restarting my pc to no avail
Change
NewBike.Create(Price, Stroke, Year, CC, Name, Model);
To
NewBike := MyBike.Create(Price, Stroke, Year, CC, Name, Model);
Thats the correct way to mane a new instance of a Class.
When you create an new instance of a class you call then constructor on the Class (MyBike) and assign it's retun value to a variable NewBike := MyBike.Create(...);`
Inside every object (instance of a class) you have a hidden parameter called Self more info on Delphi Basics. The problem in your case was that you didn't create a new instance of the class and therefor your self variable was nil.
is it possible to have different kind of results when declaring property in delphi class?
Example:
property month: string read monthGet(string) write monthSet(integer);
In the example, I want, with the property month, that when I :
READ, I get a string; SET, I set an integer;
The closest you can get is to use Operator Overloading but the Getter/Setter must be the same type. There is no way to change that.
program so_26672343;
{$APPTYPE CONSOLE}
{$R *.res}
uses
System.SysUtils;
type
TMonth = record
private
FValue: Integer;
procedure SetValue( const Value: Integer );
public
class operator implicit( a: TMonth ): string;
class operator implicit( a: Integer ): TMonth;
property Value: Integer read FValue write SetValue;
end;
TFoo = class
private
FMonth: TMonth;
public
property Month: TMonth read FMonth write FMonth;
end;
{ TMonth }
class operator TMonth.implicit( a: TMonth ): string;
begin
Result := 'Month ' + IntToStr( a.Value );
end;
class operator TMonth.implicit( a: Integer ): TMonth;
begin
Result.FValue := a;
end;
procedure TMonth.SetValue( const Value: Integer );
begin
FValue := Value;
end;
procedure Main;
var
LFoo: TFoo;
LMonthInt: Integer;
LMonthStr: string;
begin
LFoo := TFoo.Create;
try
LMonthInt := 4;
LFoo.Month := LMonthInt;
LMonthStr := LFoo.Month;
finally
LFoo.Free;
end;
end;
begin
try
Main;
except
on E: Exception do
Writeln( E.ClassName, ': ', E.Message );
end;
end.
That is not possible. But properties do not have to correspond to internal storage directly, so you can do:
private
FMonth: Integer;
function GetMonthName: string;
...
property Month: Integer read FMonth write FMonth;
property MonthName: string read GetMonthName;
...
procedure TMyClass.GetMonthName: string;
begin
// code that finds name that corresponds to value of FMonth and returns it in Result.
end;
In other words, you'll have to use two properties, one write-only (or normal), one read-only.
You can't directly do that in Delphi.
What you can do is having a "casting property" like:
private
//...
intMonth: integer
//...
public
//...
property StrMonth: string read GetStrMonth write SetStrMonth;
property IntMonth: integer read intMonth write intMonth;
//...
end;
function YourClass.GetStrMonth: string;
begin
case intMonth of
1: Result := "January";
//...
end;
end;
procedure YourClass.SetStrMonth(Value: string);
begin
if StrMonth = "January" then
intMonth := 1;
//...
end;
end;
There's no way to do that for a property. A property has a single type.
The obvious way to achieve you goal is to have getter and setter functions that you use directly.
function GetMonth: string;
procedure SetMonth(Value: Integer);
You might decide to make the type part of the name to reduce confusion in the calling code. Say GetMonthStr and SetMonthOrd.
You could expose these functions as two separate properties. One read only, the other write only.
I'm making a Delphi VCL application. There is a class TStudent where I have two static functions: one which returns last name from an array of TStudent and another one which returns the first name of the student. Their code is something like:
class function TStudent.FirstNameOf(aLastName: string): string;
var i : integer;
begin
for i := 0 to Length(studentsArray) - 1 do begin
if studentsArray[i].LastName = aLastName then
begin
result := studentsArray[i].FirstName;
Exit;
end;
end;
result := 'no match was found';
end;
class function TStudent.LastNameOf(aFirstName: string): string;
var i : integer;
begin
for i := 0 to Length(studentsArray) - 1 do begin
if studentsArray[i].FirstName = aFirstName then
begin
result := studentsArray[i].LastName;
Exit;
end;
end;
result := 'no match was found';
end;
My question is how can I avoid writing almost same code twice. Is there any way to pass the property as parameter of the functions.
You can use an anonymous method with variable capture for this linear search. This approach gives you complete generality with your predicate. You can test for equality of any field, of any type. You can test for more complex predicates for instance an either or check.
The code might look like this:
class function TStudent.LinearSearch(const IsMatch: TPredicate<TStudent>;
out Index: Integer): Boolean;
var
i: Integer;
begin
for i := low(studentsArray) to high(studentsArray) do
begin
if IsMatch(studentsArray[i]) then
begin
Index := i;
Result := True;
exit;
end;
end;
Index := -1;
Result := False;
end;
Now all you need to do is provide a suitable predicate. The definition of TPredicate<T>, from the System.SysUtils unit, is:
type
TPredicate<T> = reference to function (Arg1: T): Boolean;
So you would code your method like this:
class function TStudent.GetFirstName(const LastName: string): string;
var
Index: Integer;
IsMatch: TPredicate<TStudent>;
begin
IsMatch :=
function(Student: TStudent): Boolean
begin
Result := Student.LastName=LastName;
end;
if not LinearSearch(IsMatch, Index) then
begin
raise ...
end;
Result := studentsArray[Index].FirstName;
end;
And likewise for GetLastName.
If your Delphi does not support anonymous methods then you won't be able to use variable capture and will have to find a more convoluted approach using of object method types. However, the basic idea will be much the same.
I haven't tested it, but I believe this could be one solution.
uses TypInfo;
class function TStudent.GetProperty( propertyName: string, searchValue : Variant ) : Variant ;
var i : integer;
begin
for i := 0 to Length(studentsArray) - 1 do begin
if GetPropValue( studentsArray[i], propertyName ) = searchValue
result := GetPropValue( studentsArray[i], propertyName );
end;
// your code in case of not finding anything
end;
If you are using Delphi 2010 or later, you could use Extended RTTI:
uses
..., Rtti;
type
TStudent = class
public
FirstName: String;
LastName: String;
class function GetNameOf(const aFieldToFind, aNameToFind, aFieldToReturn: string): string;
end;
class function TStudent.GetNameOf(const aFieldToFind, aNameToFind, aFieldToReturn: string): string;
var
i : integer;
ctx: TRttiContent;
StudentType: TRttiType;
Field: TRttiField;
Value: TValue;
begin
ctx := TRttiContext.Create;
StudentType := ctx.GetType(TStudent);
Field := StudentType.GetField(aFieldToFind);
for i := 0 to Length(studentsArray) - 1 do
begin
if Field.GetValue(#studentsArray[i]).AsString = aNameToFind then
begin
Result := StudentType.GetField(aFieldToReturn).GetValue(#studentsArray[i]).AsString;
Exit;
end;
end;
Result := 'no match was found';
end;
Then you can call it like this:
FirstName := TStudent.GetNameOf('LastName', 'Smoe', 'FirstName');
LastName := TStudent.GetNameOf('FirstName', 'Joe', 'LastName');
If you restructure the TStudent record a little, everything gets easier. Instead of having multiple string fields with different names, declare an array of strings with an enumeration range.
Give the enumeration meaningful names and add a search function where the search field and result field can be specified.
Type
TStudentField = (sfFirstName,sfLastName); // Helper enumeration type
TStudent = record
Field: array[TStudentField] of String;
class function SearchNameOf(searchField: TStudentField;
const aSearchName: string; resultField: TStudentField): string; static;
end;
Here is a test example:
program ProjectTest;
{$APPTYPE CONSOLE}
Type
TStudentField = (sfFirstName,sfLastName);
TStudent = record
Field: array[TStudentField] of String;
class function SearchNameOf(searchField: TStudentField; const aSearchName: string; resultField: TStudentField): string; static;
end;
var
studentsArray : array of TStudent;
class function TStudent.SearchNameOf(searchField: TStudentField; const aSearchName: string; resultField: TStudentField): string;
var
i : integer;
begin
for i := 0 to Length(studentsArray) - 1 do begin
if (studentsArray[i].Field[searchField] = aSearchName) then
begin
Result := studentsArray[i].Field[resultField];
Exit;
end;
end;
result := 'no match was found';
end;
begin
SetLength(studentsArray,2);
studentsArray[0].Field[sfFirstName] := 'Buzz';
studentsArray[0].Field[sfLastName] := 'Aldrin';
studentsArray[1].Field[sfFirstName] := 'Neil';
studentsArray[1].Field[sfLastName] := 'Armstrong';
WriteLn(TStudent.SearchNameOf(sfFirstName,'Neil',sfLastName));
ReadLn;
end.
You could use a several properties with index specifier backed by single getter function just as you do for regular array properties:
TDefault = class(TObject)
private
class function GetProp(const FindWhat: string; FindWhere: Integer): string;
static;
protected
/// <remarks>
/// You don't really need this one. I've added it for an illustration
/// purposes.
/// </remarks>
class property Prop[const FindWhat: string; FindWhere: Integer]: string read GetProp;
public
class property A[const FindWhat: string]: string index 0 read GetProp;
class property B[const FindWhat: string]: string index 1 read GetProp;
end;
{ ... }
class function TDefault.GetProp(const FindWhat: string; FindWhere: Integer): string;
begin
case FindWhere of
0: Result := 'Hallo!';
1: Result := 'Hello!';
end;
Result := Result + ' ' + Format('searching for "%s"', [FindWhat]);
end;
As you see, the class properties are just the same as instance properties.
And I must say its a pretty bad idea to perform a search in the property getter.
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