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.
Related
SITUATION. I have created an unit with some classes to solve algebra stuff (congruences and systems), I am showing you the code:
type
TCongrError = class(Exception)
end;
type
TCongruence = class(TComponent)
//code stuff
constructor Create(a, b, n: integer); virtual;
end;
type
TCongrSystem = array of TCongruence;
type
TCongruenceSystem = class(TThread)
private
resInner: integer;
FData: TCongrSystem;
function modinv(u, v: integer): integer; //not relevant
protected
procedure Execute; override;
public
constructor Create(data: TCongrSystem; var result: integer; hasClass: boolean);
end;
I have decided to use TThread because this class has an Execute method that could take some time to finish due to the length of the parameters passed to the constructor. Here's the implementation:
constructor TCongruenceSystem.Create(data: TCongrSystem; var result: integer; hasClass: boolean);
begin
inherited Create(True);
FreeOnTerminate := true;
FData := data;
setClass := hasClass;
resInner := result;
end;
procedure TCongruenceSystem.Execute;
var sysResult, i, n, t: integer;
begin
sysResult := 0;
n := 1;
//computation
Queue( procedure
begin
ShowMessage('r = ' + sysResult.ToString);
resInner := sysResult;
end );
end;
PROBLEM
If you look at the Queue you see that I am using (just as test) the ShowMessage and it is showing the correct value of sysResult. The second line by the way has some problems that I cannot understand.
The constructor has var result: integer so I can have side-effect from the passed variable and then I can assign resInner := result;. At the end (in the Queue) I am giving resInner the value of sysResult and I expect result to be updated too due to the side effect of var. Why doesn't this happen?
I have made another test changing the constructor like this:
constructor TCongruenceSystem.Create(data: TCongrSystem; result: TMemo; hasClass: boolean);
//now of course I have resInner: TMemo
And changing the Queue to this:
Queue( procedure
begin
ShowMessage('r = ' + sysResult.ToString);
resInner.Lines.Add(sysResult.ToString);
end ); //this code now works properly in both cases! (showmessage and memo)
In the constructor I am passing TMemo which is a reference and ok, but isn't the original var result: integer passed as reference too? Why then it doesn't work?
I want to do this because I'd like to do something like this:
//I put var a: integer; inside the public part of the TForm
test := TCongruenceSystem.Create(..., a, true);
test.OnTerminate := giveMeSolution;
test.Start;
test := nil;
Where giveMeSolution is just a simple procedure that uses the variable a containing the result of the system. If this is not possible what could I do? Basically the result at the end of Execute is just an integer number that has to be passed to the main thread.
I have read about ReturnValue but I am not sure how to use it.
Basically the result at the end of Execute is just an integer number that has to be passed to the main thread.
I have read about ReturnValue but I am not sure how to use it.
Using the ReturnValue property is very easy:
type
TCongruenceSystem = class(TThread)
...
protected
procedure Execute; override;
public
property ReturnValue; // protected by default
end;
procedure TCongruenceSystem.Execute;
var
...
begin
// computation
ReturnValue := ...;
end;
test := TCongruenceSystem.Create(...);
test.OnTerminate := giveMeSolution;
test.Start;
....
procedure TMyForm.giveMeSolution(Sender: TObject);
var
Result: Integer;
begin
Result := TCongruenceSystem(Sender).ReturnValue;
...
end;
Let's assume a class field FFoo : integer; ;
procedure TFoo.Foo(var x : integer);
begin
FFoo := x;
end;
Here what you are doing is assigning the value of x to FFoo. Inside the method Foo you are free to modify the value of the variable passed in as x but integers are otherwise value types that are copied on assignment. If you want to keep a reference to an external integer variable you would need to declare FFoo (or, in your case, resInner) as a PInteger (pointer to an integer). For example (simplifying) :
TCongruenceSystem = class(TThread)
private
resInner: PInteger;
protected
procedure Execute; override;
public
constructor Create(result: PInteger);
end;
where
constructor TCongruenceSystem.Create(result: PInteger);
begin
inherited Create(True);
FreeOnTerminate := true;
resInner := result;
end;
which you would call as test := TCongruenceSystem.Create(#a); and assign:
{ ** See the bottom of this answer for why NOT to use }
{ Queue with FreeOnTerminate = true ** }
Queue( procedure
begin
ShowMessage('r = ' + sysResult.ToString);
resInner^ := sysResult;
end );
The reason it works with TMemo is that classes are reference types - their variables do not hold values but rather point to the address of the object in memory. When you copy a class variable you are only copying a reference (ie: a pointer) whereas for value types the contents of the variable are copied on assignment.
With that said, there's nothing stopping you from keeping the argument typed as var x : integer and taking a reference in your constructor :
constructor TCongruenceSystem.Create(var result: Integer);
begin
inherited Create(True);
FreeOnTerminate := true;
resInner := #result; {take the reference here}
end;
but this gives the caller the impression that once the constructor is complete that you have made any modifications to the variable you intend to and they are free to dispose of the integer. Passing explicitly as PInteger gives the caller a hint that your object will keep a reference to the integer they provide and that need to ensure the underlying variable remains valid while your class is alive.
And... with all that said, I still fundamentally don't like this idea. By taking in a variable reference like this you are offloading an atypical lifetime management issue to the caller. Passing pointers is best done in place where they are used at the point of transfer only. Holding onto a foreign pointer is messy and it's too easy for mistakes to happen. A far better approach here would be to provide a completion event and have the consumer of your class attach a handler.
For example :
{ define a suitable callback signature }
TOnCalcComplete = procedure(AResult : integer) of object;
TCongruenceSystem = class(TThread)
private
Fx, Fy : integer;
FOnCalcComplete : TOnCalcComplete;
protected
procedure Execute; override;
public
constructor Create(x,y: integer);
property OnCalcComplete : TOnCalcComplete read FOnCalcComplete write FOnCalcComplete;
end;
constructor TCongruenceSystem.Create(x: Integer; y: Integer);
begin
inherited Create(true);
FreeOnTerminate := true;
Fx := x;
Fy := y;
end;
procedure TCongruenceSystem.Execute;
var
sumOfxy : integer;
begin
sumOfxy := Fx + Fy;
sleep(3000); {take some time...}
if Assigned(FOnCalcComplete) then
Synchronize(procedure
begin
FOnCalcComplete(sumOfxy);
end);
end;
Which you would then call as :
{ implement an event handler ... }
procedure TForm1.CalcComplete(AResult: Integer);
begin
ShowMessage(IntToStr(AResult));
end;
procedure TForm1.Button1Click(Sender: TObject);
var
LCongruenceSystem : TCongruenceSystem;
begin
LCongruenceSystem := TCongruenceSystem.Create(5, 2);
LCongruenceSystem.OnCalcComplete := CalcComplete; { attach the handler }
LCongruenceSystem.Start;
end;
You'll also notice that I used Synchronize here instead of Queue. On this topic, please have a read of this question (I'll quote Remy...):
Ensure all TThread.Queue methods complete before thread self-destructs
Setting FreeOnTerminate := True in a queued method is asking for a memory leak.
I have a TFrame that I use for searching for entities in a Delphi 2010 VCL project, in the TFrame I have a button edit, that allows the user to open a specific form to browse for that entity. (All the browse forms inherit from a common base browse form)
Currently I achieve this by inheriting from the base frame, then implement the Browse event that fires off the specific form. The only difference each time is what form (type) is shown on the click event, is there a way I can achieve this with generics.
That way I can reuse the same base frame without having to rewrite the same code for each entity (there are over 100), and at form create of the host form pass the type constraint to open the appropriate form on browse.
I have tried adding a generic type to the frame:
type
Browser<T: TfrmBrowser, constructor> = class
class function BrowseForm(Owner: Tcomponent): T;
end;
class function Browser<T>.BrowseForm(Owner: Tcomponent): T;
var
_browseForm: T;
begin
_browseForm := T.Create; // 1st problem T.Create(Owner); throws a comile error
Result := _browseForm;
end;
and then in the picker frame I expose Start that can be called from the the host form's create event:
procedure TPickerFrame.Start<T>(const idProp, nameProp, anIniSection: string; aDto: IDto);
begin
_browseForm:= Browser<T>.BrowseForm(self);
_iniSectionName:= anIniSection;
_idField:= idProp;
_descriptionField:= nameProp;
_dto := aDto;
end;
the truth is, I don't really get generics in Delphi, and none of this is working.
Below are excerpts from the frame:
_browseForm: TfrmBrowser;
procedure TPickerFrame.Browse(var DS: TDataSet; var Txt: string; var mr: TModalResult);
begin
// How do I achieve this with Generics
// _browseForm := T.Create(nil); // <-- this line is what needs to know the form type at runtime
// Everything else from here is the same
_browseForm.ProductName := Application.Title;
_browseForm.PageSize := 20;
_browseForm.DatabaseType := bdbtADO;
_browseForm.ADOConnection := dmdbWhereHouse.BaseADOConnection;
_browseForm.INISectionName := _iniSectionName;
_browseForm.DoSelBrowse(DS, Txt, mr, _descriptionField, _text);
if mr = mrOk then
begin
DoSelect(DS);
end;
end;
Does anyone have any experience with a similar requirement? Any help would be appreciated.
Thanks
Below is an example of the rack master browser:
type
TfrmMbfRACK_MASTER = class(TMxfrmBrowseHoster)
procedure FormCreate(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
//...
private
FWHID: Integer;
procedure SetWHID(const Value: Integer);
{ Private declarations }
public
{ Public declarations }
procedure BuildADO(Sender: TObject; Q: TADOQuery); override;
end;
implementation
{$R *.DFM}
{ TfrmMbfRACK_MASTER }
procedure TfrmMbfRACK_MASTER.FormCreate(Sender: TObject);
begin
inherited;
fmeMxFrmBrowseHoster1.KeyField := 'RACK_ID';
// FWHID := -2; // 22/06/04
FWHID := 0; // 22/06/04
end;
procedure TfrmMbfRACK_MASTER.BuildADO(Sender: TObject; Q: TADOQuery);
begin
Q.Close;
Q.SQL.Clear;
Q.SQL.Add(
'SELECT R.RACK_DESC, R.RACK_BARCODE, W.ERP_WH, WC.CLASS_NAME, W.DESCRIPTION WAREHOUSE, R.RACK_PACKING_ORDER, ');
//...
end;
The base class
type
TMxfrmBrowseHoster = class(TfrmMxForm)
protected
// ...
procedure FormCreate(Sender: TObject);
procedure BuildADO(Sender: TObject; ADOQ: TADOQuery); virtual; abstract;
public
procedure TMxfrmBrowseHoster.FormCreate(Sender: TObject);
begin
TMxFormProductName := Application.Title;
fmeMxFrmBrowseHoster1.Initialise;
INISectionName := Name;
AbortAction := False;
fmeMxFrmBrowseHoster1.OnSelect := SelectNormaliser;
fmeMxFrmBrowseHoster1.OnNeedADO := BuildADO;
fmeMxFrmBrowseHoster1.INISectionName := self.Name;
fmeMxFrmBrowseHoster1.MultiSelect := dxBarLargeButton10.Down;
fmeMxFrmBrowseHoster1.AutoSaveGrid := True;
dxBarEdit1.OnChange := ActPageSizeChangedExecute;
FormStorage.RestoreFormPlacement;
ActConfirmDelete.Execute;
end;
I find your question a little on the vague side and I'm not 100% sure I understand exactly what you are asking. However, I know how to deal with your problem when calling the constructor. Perhaps that's all you need help with.
You need to use virtual constructor polymorphism and a bit of casting:
class function Browser<T>.BrowseForm(Owner: Tcomponent): T;
var
_browseForm: T;
begin
_browseForm := TfrmBrowser(T).Create(Owner);
Result := _browseForm;
end;
This relies on virtual constructor polymorphism. So you must make sure that each constructor for every class derived from TfrmBrowser is marked with the override directive.
I have a class in my Delphi app where I would like an easy and dynamic way of resetting all the string properties to '' and all the boolean properties to False
As far as I can see on the web it should be possible to make a loop of some sort, but how to do it isn't clear to me.
if you are an Delphi 2010 (and higher) user then there is a new RTTI unit (rtti.pas). you can use it to get runtime information about your class and its properties (public properties by default, but you can use {$RTTI} compiler directive to include protected and private fields information).
For example we have next test class with 3 public fields (1 boolean and 2 string fields (one of them is readonly)).
TTest = class(TObject)
strict private
FString1 : string;
FString2 : string;
FBool : boolean;
public
constructor Create();
procedure PrintValues();
property String1 : string read FString1 write FString1;
property String2 : string read FString2;
property BoolProp : boolean read FBool write FBool;
end;
constructor TTest.Create();
begin
FBool := true;
FString1 := 'test1';
FString2 := 'test2';
end;
procedure TTest.PrintValues();
begin
writeln('string1 : ', FString1);
writeln('string2 : ', FString2);
writeln('bool: ', BoolToStr(FBool, true));
end;
to enumerate all properties of object and set it values to default you can use something like code below.
First at all you have to init TRttiContext structure (it is not neccesary, because it is a record). Then you should get rtti information about your obejct, after that you can loop your properties and filter it (skip readonly properties and other than boolean and stirng). Take into account that there are few kind of strings : tkUString, tkString and others (take a look at TTypeKind in typinfo.pas)
TObjectReset = record
strict private
public
class procedure ResetObject(obj : TObject); static;
end;
{ TObjectReset }
class procedure TObjectReset.ResetObject(obj: TObject);
var ctx : TRttiContext;
rt : TRttiType;
prop : TRttiProperty;
value : TValue;
begin
ctx := TRttiContext.Create();
try
rt := ctx.GetType(obj.ClassType);
for prop in rt.GetProperties() do begin
if not prop.IsWritable then continue;
case prop.PropertyType.TypeKind of
tkEnumeration : value := false;
tkUString : value := '';
else continue;
end;
prop.SetValue(obj, value);
end;
finally
ctx.Free();
end;
end;
simple code to test:
var t : TTest;
begin
t := TTest.Create();
try
t.PrintValues();
writeln('reset values'#13#10);
TObjectReset.ResetObject(t);
t.PrintValues();
finally
readln;
t.Free();
end;
end.
and result is
string1 : test1
string2 : test2
bool: True
reset values
string1 :
string2 : test2
bool: False
also take a look at Attributes, imo it is good idea to mark properties (wich you need to reset) with some attribute, and may be with default value like:
[ResetTo('my initial value')]
property MyValue : string read FValue write FValue;
then you can filter only properties wich are marked with ResetToAttribute
Please note, the following code works only for published properties of a class! Also, the instance of a class passed to the function below must have at least published section defined!
Here is how to set the published string property values to an empty string and boolean values to False by using the old style RTTI.
If you have Delphi older than Delphi 2009 you might be missing the tkUString type. If so, simply removeit from the following code:
uses
TypInfo;
procedure ResetPropertyValues(const AObject: TObject);
var
PropIndex: Integer;
PropCount: Integer;
PropList: PPropList;
PropInfo: PPropInfo;
const
TypeKinds: TTypeKinds = [tkEnumeration, tkString, tkLString, tkWString,
tkUString];
begin
PropCount := GetPropList(AObject.ClassInfo, TypeKinds, nil);
GetMem(PropList, PropCount * SizeOf(PPropInfo));
try
GetPropList(AObject.ClassInfo, TypeKinds, PropList);
for PropIndex := 0 to PropCount - 1 do
begin
PropInfo := PropList^[PropIndex];
if Assigned(PropInfo^.SetProc) then
case PropInfo^.PropType^.Kind of
tkString, tkLString, tkUString, tkWString:
SetStrProp(AObject, PropInfo, '');
tkEnumeration:
if GetTypeData(PropInfo^.PropType^)^.BaseType^ = TypeInfo(Boolean) then
SetOrdProp(AObject, PropInfo, 0);
end;
end;
finally
FreeMem(PropList);
end;
end;
Here is a simple test code (note the properties must be published; if there are no published properties in the class, at least empty published section must be there):
type
TSampleClass = class(TObject)
private
FStringProp: string;
FBooleanProp: Boolean;
published
property StringProp: string read FStringProp write FStringProp;
property BooleanProp: Boolean read FBooleanProp write FBooleanProp;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
SampleClass: TSampleClass;
begin
SampleClass := TSampleClass.Create;
try
SampleClass.StringProp := 'This must be cleared';
SampleClass.BooleanProp := True;
ResetPropertyValues(SampleClass);
ShowMessage('StringProp = ' + SampleClass.StringProp + sLineBreak +
'BooleanProp = ' + BoolToStr(SampleClass.BooleanProp));
finally
SampleClass.Free;
end;
end;
suppose I have a TModel:
TModelClass = class of TModel;
TModel = class
procedure DoSomeStuff;
end;
and 2 descendants:
TModel_A = class(TModel);
TModel_B = class(TModel);
and a factory :
TModelFactory = class
class function CreateModel_A: TModel_A;
class function CreateModel_B: TModel_B;
end;
Now I want to refactor a bit :
TModelFactory = class
class function CreateGenericModel(Model: TModelClass) : TModel
end;
class function TModelFactory.CreateGenericModel(Model: TModelClass) : TModel
begin
...
case Model of
TModel_A: Result := TModel_A.Create;
TModel_B: Result := TModel_B.Create;
end;
...
end;
So far it's ok, but every time I create a TModel descendant, I have to modify the factory case statement.
My question: Is this possible to create a 100% generic factory for all my TModel descendants, so every time I create a TModel descendants I don't have to modify TModelFactory ?
I tried to play with Delphi 2009 generics but didn't find valuable information, all are related to basic usage of TList<T>and so on.
Update
Sorry, but maybe I'm not clear or don't understand your answer (I'm still a noob), but what i'm trying to achieve is :
var
M: TModel_A;
begin
M: TModelFactory.CreateGenericModel(MY_CONCRETE_CLASS);
Well, you could write
class function TModelFactory.CreateGenericModel(AModelClass: TModelClass): TModel;
begin
Result := AModelClass.Create;
end;
but then you don't need a factory any more. Usually one would have a selector of a different type, like an integer or string ID, to select the concrete class the factory should create.
Edit:
To answer your comment on how to add new classes without the need to change the factory - I will give you some simple sample code that works for very old Delphi versions, Delphi 2009 should upen up much better ways to do this.
Each new descendant class only needs to be registered with the factory. The same class can be registered using several IDs. The code uses a string ID, but integers or GUIDs would work just as well.
type
TModelFactory = class
public
class function CreateModelFromID(const AID: string): TModel;
class function FindModelClassForId(const AID: string): TModelClass;
class function GetModelClassID(AModelClass: TModelClass): string;
class procedure RegisterModelClass(const AID: string;
AModelClass: TModelClass);
end;
{ TModelFactory }
type
TModelClassRegistration = record
ID: string;
ModelClass: TModelClass;
end;
var
RegisteredModelClasses: array of TModelClassRegistration;
class function TModelFactory.CreateModelFromID(const AID: string): TModel;
var
ModelClass: TModelClass;
begin
ModelClass := FindModelClassForId(AID);
if ModelClass <> nil then
Result := ModelClass.Create
else
Result := nil;
end;
class function TModelFactory.FindModelClassForId(
const AID: string): TModelClass;
var
i, Len: integer;
begin
Result := nil;
Len := Length(RegisteredModelClasses);
for i := 0 to Len - 1 do
if RegisteredModelClasses[i].ID = AID then begin
Result := RegisteredModelClasses[i].ModelClass;
break;
end;
end;
class function TModelFactory.GetModelClassID(AModelClass: TModelClass): string;
var
i, Len: integer;
begin
Result := '';
Len := Length(RegisteredModelClasses);
for i := 0 to Len - 1 do
if RegisteredModelClasses[i].ModelClass = AModelClass then begin
Result := RegisteredModelClasses[i].ID;
break;
end;
end;
class procedure TModelFactory.RegisterModelClass(const AID: string;
AModelClass: TModelClass);
var
i, Len: integer;
begin
Assert(AModelClass <> nil);
Len := Length(RegisteredModelClasses);
for i := 0 to Len - 1 do
if (RegisteredModelClasses[i].ID = AID)
and (RegisteredModelClasses[i].ModelClass = AModelClass)
then begin
Assert(FALSE);
exit;
end;
SetLength(RegisteredModelClasses, Len + 1);
RegisteredModelClasses[Len].ID := AID;
RegisteredModelClasses[Len].ModelClass := AModelClass;
end;
Result := Model.Create;
should work, too.
The solution with Model.Create works if the constructor is virtual.
If you use delphi 2009, you can use another trick using generics:
type
TMyContainer<T: TModel, constructor> (...)
protected
function CreateModel: TModel;
end;
function TMyContainer<T>.CreateModel: TModel;
begin
Result := T.Create; // Works only with a constructor constraint.
end;
If I understand your question properly, I wrote something similar here http://www.malcolmgroves.com/blog/?p=331
There is probably a simpler way to accomplish this. I seem to remember finding the built-in TClassList object that handled this, but that this point I already had this working. TClassList does not have a way to look up the stored objects by the string name, but it could still be useful.
Basically to make this work you need to register your classes with a global object. That way it can take a string input for the class name, lookup that name in a list to find the correct class object.
In my case I used a TStringList to hold the registered classes and I use the class name as the identifier for the class. In order to add the class to the "object" member of the string list I needed to wrap the class in a real object. I'll admit that I don't really understand the "class" so this may not be needed if you cast everything right.
// Needed to put "Class" in the Object member of the
// TStringList class
TClassWrapper = class(TObject)
private
FGuiPluginClass: TAgCustomPluginClass;
public
property GuiPluginClass: TAgCustomPluginClass read FGuiPluginClass;
constructor Create(GuiPluginClass: TAgCustomPluginClass);
end;
I have a global "PluginManager" object. This is where classes get registered and created. The "AddClass" method puts the class in the TStringList so I can look it up later.
procedure TAgPluginManager.AddClass(GuiPluginClass: TAgCustomPluginClass);
begin
FClassList.AddObject(GuiPluginClass.ClassName,
TClassWrapper.Create(GuiPluginClass));
end;
In each class that I create I add it to the class list in the "initialization" section.
initialization;
AgPluginManager.AddClass(TMyPluginObject);
Then, when it comes time to create the class I can lookup the name in the string list, find the class and create it. In my actual function I am checking to make sure the entry exists and deal with errors, etc. I am also passing in more data to the class constructor. In my case I am creating forms so I don't actually return the object back to the caller (I track them in my PluginManager), but that would be easy to do if needed.
procedure TAgPluginManager.Execute(PluginName: string);
var
ClassIndex: integer;
NewPluginWrapper: TClassWrapper;
begin
ClassIndex := FClassList.IndexOf(PluginName);
if ClassIndex > -1 then
begin
NewPluginWrapper := TClassWrapper(FClassList.Objects[ClassIndex]);
FActivePlugin := NewPluginWrapper.GuiPluginClass.Create();
end;
end;
Since I first wrote this I have not needed to touch the code. I just make sure to add my new classes to the list in their initialization section and everything works.
To create an object I just call
PluginManger.Execute('TMyPluginObject');
You can do generic factory like this: But the only issue you should set the generic construct method to it for each of the factory final class like this:
type
TViewFactory = TGenericFactory<Integer, TMyObjectClass, TMyObject>;
...
F := TViewFactory.Create;
F.ConstructMethod :=
function(AClass: TMyObjectClass; AParams: array of const): TMyObject
begin
if AClass = nil then
Result := nil
else
Result := AClass.Create;
end;
and the unit for the factory is:
unit uGenericFactory;
interface
uses
System.SysUtils, System.Generics.Collections;
type
EGenericFactory = class(Exception)
public
constructor Create; reintroduce;
end;
EGenericFactoryNotRegistered = class(EGenericFactory);
EGenericFactoryAlreadyRegistered = class(EGenericFactory);
TGenericFactoryConstructor<C: constructor; R: class> = reference to function(AClass: C; AParams: array of const): R;
TGenericFactory<T; C: constructor; R: class> = class
protected
FType2Class: TDictionary<T, C>;
FConstructMethod: TGenericFactoryConstructor<C, R>;
procedure SetConstructMethod(const Value: TGenericFactoryConstructor<C, R>);
public
constructor Create(AConstructor: TGenericFactoryConstructor<C, R> = nil); reintroduce; overload; virtual;
destructor Destroy; override;
procedure RegisterClass(AType: T; AClass: C);
function ClassForType(AType: T): C;
function TypeForClass(AClass: TClass): T;
function SupportsClass(AClass: TClass): Boolean;
function Construct(AType: T; AParams: array of const): R;
property ConstructMethod: TGenericFactoryConstructor<C, R> read FConstructMethod write SetConstructMethod;
end;
implementation
uses
System.Rtti;
{ TGenericFactory<T, C, R> }
function TGenericFactory<T, C, R>.ClassForType(AType: T): C;
begin
FType2Class.TryGetValue(AType, Result);
end;
function TGenericFactory<T, C, R>.Construct(AType: T; AParams: array of const): R;
begin
if not Assigned(FConstructMethod) then
Exit(nil);
Result := FConstructMethod(ClassForType(AType), AParams);
end;
constructor TGenericFactory<T, C, R>.Create(AConstructor: TGenericFactoryConstructor<C, R> = nil);
begin
inherited Create;
FType2Class := TDictionary<T, C>.Create;
FConstructMethod := AConstructor;
end;
destructor TGenericFactory<T, C, R>.Destroy;
begin
FType2Class.Free;
inherited;
end;
procedure TGenericFactory<T, C, R>.RegisterClass(AType: T; AClass: C);
begin
if FType2Class.ContainsKey(AType) then
raise EGenericFactoryAlreadyRegistered.Create;
FType2Class.Add(AType, AClass);
end;
procedure TGenericFactory<T, C, R>.SetConstructMethod(const Value: TGenericFactoryConstructor<C, R>);
begin
FConstructMethod := Value;
end;
function TGenericFactory<T, C, R>.SupportsClass(AClass: TClass): Boolean;
var
Key: T;
Val: C;
begin
for Key in FType2Class.Keys do
begin
Val := FType2Class[Key];
if CompareMem(#Val, AClass, SizeOf(Pointer)) then
Exit(True);
end;
Result := False;
end;
function TGenericFactory<T, C, R>.TypeForClass(AClass: TClass): T;
var
Key: T;
Val: TValue;
begin
for Key in FType2Class.Keys do
begin
Val := TValue.From<C>(FType2Class[Key]);
if Val.AsClass = AClass then
Exit(Key);
end;
raise EGenericFactoryNotRegistered.Create;
end;
{ EGenericFactory }
constructor EGenericFactory.Create;
begin
inherited Create(Self.ClassName);
end;
end.
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