Search for a Label by its Caption - delphi

I was trying to figure out how to search for a Label by its Caption:
for I := ComponentCount - 1 downto 0 do
begin
if Components[i] is TLabel then
if Components[i].Caption = mnNumber then
begin
Components[i].Left := Left;
Components[i].Top := Top + 8;
end;
end;
I get an error: Undeclared identifier: 'Caption'.
How can I resolve this issue?

Iterating over Components[] is the wrong approach. That just yields the components that are owned by the form. You will miss any components that are added dynamically, and not owned by the form, or components that are owned by frames.
Instead you should use Controls[]. However, that only yields first generation children. If there is deeper parent/child nesting then you need to recurse. That's more work. I use some helpers to make it easy. I've wrapped them up in this unit:
unit ControlEnumerator;
interface
uses
System.SysUtils, System.Generics.Collections, Vcl.Controls;
type
TControls = class
private
type
TEnumerator<T: TControl> = record
FControls: TArray<T>;
FIndex: Integer;
procedure Initialise(WinControl: TWinControl; Predicate: TFunc<T, Boolean>);
class function Count(WinControl: TWinControl; Predicate: TFunc<T, Boolean>): Integer; static;
function GetCurrent: T;
function MoveNext: Boolean;
property Current: T read GetCurrent;
end;
TEnumeratorFactory<T: TControl> = record
FWinControl: TWinControl;
FPredicate: TFunc<T, Boolean>;
function Count: Integer;
function Controls: TArray<T>;
function GetEnumerator: TEnumerator<T>;
end;
public
class procedure WalkControls<T: TControl>(WinControl: TWinControl; Predicate: TFunc<T, Boolean>; Method: TProc<T>); static;
class function Enumerator<T: TControl>(WinControl: TWinControl; Predicate: TFunc<T, Boolean>=nil): TEnumeratorFactory<T>; static;
class function ChildCount<T: TControl>(WinControl: TWinControl; Predicate: TFunc<T, Boolean>=nil): Integer; static;
end;
implementation
{ TControls.TEnumerator<T> }
procedure TControls.TEnumerator<T>.Initialise(WinControl: TWinControl; Predicate: TFunc<T, Boolean>);
var
List: TList<T>;
Method: TProc<T>;
begin
List := TObjectList<T>.Create(False);
Try
Method :=
procedure(Control: T)
begin
List.Add(Control);
end;
WalkControls<T>(WinControl, Predicate, Method);
FControls := List.ToArray;
Finally
List.Free;
End;
FIndex := -1;
end;
class function TControls.TEnumerator<T>.Count(WinControl: TWinControl; Predicate: TFunc<T, Boolean>): Integer;
var
Count: Integer;
Method: TProc<T>;
begin
Method :=
procedure(Control: T)
begin
inc(Count);
end;
Count := 0;
WalkControls<T>(WinControl, Predicate, Method);
Result := Count;
end;
function TControls.TEnumerator<T>.GetCurrent: T;
begin
Result := FControls[FIndex];
end;
function TControls.TEnumerator<T>.MoveNext: Boolean;
begin
inc(FIndex);
Result := FIndex<Length(FControls);
end;
{ TControls.TEnumeratorFactory<T> }
function TControls.TEnumeratorFactory<T>.Count: Integer;
begin
Result := TEnumerator<T>.Count(FWinControl, FPredicate);
end;
function TControls.TEnumeratorFactory<T>.Controls: TArray<T>;
var
Enumerator: TEnumerator<T>;
begin
Enumerator.Initialise(FWinControl, FPredicate);
Result := Enumerator.FControls;
end;
function TControls.TEnumeratorFactory<T>.GetEnumerator: TEnumerator<T>;
begin
Result.Initialise(FWinControl, FPredicate);
end;
class procedure TControls.WalkControls<T>(WinControl: TWinControl; Predicate: TFunc<T, Boolean>; Method: TProc<T>);
var
i: Integer;
Control: TControl;
Include: Boolean;
begin
if not Assigned(WinControl) then begin
exit;
end;
for i := 0 to WinControl.ControlCount-1 do begin
Control := WinControl.Controls[i];
if not (Control is T) then begin
Include := False;
end else if Assigned(Predicate) and not Predicate(Control) then begin
Include := False;
end else begin
Include := True;
end;
if Include then begin
Method(Control);
end;
if Control is TWinControl then begin
WalkControls(TWinControl(Control), Predicate, Method);
end;
end;
end;
class function TControls.Enumerator<T>(WinControl: TWinControl; Predicate: TFunc<T, Boolean>): TEnumeratorFactory<T>;
begin
Result.FWinControl := WinControl;
Result.FPredicate := Predicate;
end;
class function TControls.ChildCount<T>(WinControl: TWinControl; Predicate: TFunc<T, Boolean>): Integer;
begin
Result := Enumerator<T>(WinControl, Predicate).Count;
end;
end.
Now you can solve your problem like this:
var
lbl: TLabel;
....
for lbl in TControls.Enumerator<TLabel>(Form) do
if lbl.caption=mnNumber then
begin
lbl.Left := Left;
lbl.Top := Top + 8;
end;
Or you could make use of a predicate to put the caption test inside the iterator:
var
Predicate: TControlPredicate;
lbl: TLabel;
....
Predicate := function(lbl: TLabel): Boolean
begin
Result := lbl.Caption='hello';
end;
for lbl in TControls.Enumerator<TLabel>(Form, Predicate) do
begin
lbl.Left := Left;
lbl.Top := Top + 8;
end;

The final piece of information fell into place in your comment to Golez's answer: your Labels are created at run-time, so there's a chance they don't have the Form as an owner. You'll need to use the Controls[] array to look at all the controls that are parented by the form, and look recursively into all TWinControl descendants because they might also contain TLabel's.
If you're going to do this allot and for different types of controls, you'll probably want to implement some sort of helper so you don't repeat yourself too often. Look at David's answer for a ready-made solution that manages to include some "bells and whistles", beyond solving the problem at hand; Like the ability to use anonymous functions to manipulate the found controls, and it's ability use an anonymous function to filter controls based on any criteria.
Before you start using such a complicated solution, you should probably understand the simplest one. A very simple recursive function that simply looks at all TControls on all containers starting from the form. Something like this:
procedure TForm1.Button1Click(Sender: TObject);
procedure RecursiveSearchForLabels(const P: TWinControl);
var i:Integer;
begin
for i:=0 to P.ControlCount-1 do
if P.Controls[i] is TWinControl then
RecursiveSearchForLabels(TWinControl(P.Controls[i]))
else if P.Controls[i] is TLabel then
TLabel(P.Controls[i]).Caption := 'Test';
end;
begin
RecursiveSearchForLables(Self);
end;
Using David's generic code, the above could be re-written as:
procedure TForm1.Button1Click(Sender: TObject);
begin
TControls.WalkControls<TLabel>(Self, nil,
procedure(lbl: TLabel)
begin
lbl.Caption := 'Test';
end
);
end;

ComponentCount is only for the count. Use the Components array to find the actual components. For easy, you can put the label in a TLabel variable, which will also allow you to use label-specific properties that are not visible in TComponent. You could use with for this as well, but I think it degrades readability.
var
l: TLabel;
for I := ComponentCount -1 downto 0 do
begin
if Components[i] is TLabel then // Check if it is.
begin
l := TLabel(Components[i]); // Typecast, to reach it's properties.
if l.Caption = mnNumber then
begin
l.Left := Left;
l.Top := Top +8;
end;
end;
end;

The compiler doesn't know your Components[i] is a TLabel.
You need to cast your component to Tlabel like this:
for I := ComponentCount - 1 downto 0 do
begin
if Components[i] is TLabel then //here you check if it is a tlabel
if TLabel(Components[i]).Caption = mnNumber then //and here you explicitly tell the
begin //compiler to treat components[i]
TLabel(Components[i]).Left := Left; //as a tlabel.
TLabel(Components[i]).Top := Top + 8;
end;
end;
This is needed because components[i] doesn't know the caption.

Try this:
for I := ControlCount-1 downto 0 do
begin
if Controls[i] is TLabel then // Check if it is.
begin
if (Controls[i] as TLabel).Caption = mnNumber then
begin
(Controls[i] as TLabel).Left := Left;
(Controls[i] as TLabel).Top := Top +8;
end;
end;
end;

Related

Possible to loop only declared properties of a class?

The extended RTTI has the GetDeclaredProperties function which is exactly what i need, however i faced problems if i use the extended RTTI in multi-threading.
Therefore, i used GetPropList, but this gives me a list of all properties - not only published in the current class (or explicit stated).
i.e.
TBaseSettings = class(TPersistent)
published
property Charset: string read FCharset write FCharset;
end;
TBasicSettings = class(TBaseSettings)
published
property forums: Variant read fforums write fforums;
end;
TConcreteSettings = class(TBasicSettings)
published
property forums; // <-- make it explicit visible: OK
property prefix: Variant read fprefix write fprefix; // <-- OK
end;
I don't want to read the Charset property.
My first guess was to use a modified version of https://stackoverflow.com/a/1565686 to check for inheritance, but actually the forums property is also inherited.
Maybe this is not possible with the classic RTTI? I use Delphi 2010.
In case it's convenient to have your code calling GetDeclaredPropList in a similar way to calling GetPropList, see below.
Edit: I've rewritten the code in Delphi 7 and I believe it should work in Delphi 2010, too (which I don't have at hand).
type
PPropData = ^TPropData;
function AfterString(P: Pointer): Pointer;
begin
Result := Pointer(NativeUInt(P) + (PByte(P)^ + 1));
end;
function GetPropData(TypeData: PTypeData): PPropData;
begin
Result := AfterString(#TypeData^.UnitName);
end;
function NextPropInfo(PropInfo: PPropInfo): PPropInfo;
begin
Result := AfterString(#PropInfo^.Name);
end;
procedure GetDeclaredPropInfos(TypeInfo: PTypeInfo; PropList: PPropList);
var
TypeData: PTypeData;
PropData: PPropData;
PropInfo: PPropInfo;
I: Integer;
begin
TypeData := GetTypeData(TypeInfo);
PropData := GetPropData(TypeData);
FillChar(PropList^, Sizeof(PPropInfo) * PropData^.PropCount, 0);
PropInfo := PPropInfo(#PropData^.PropList);
for I := 0 to PropData^.PropCount - 1 do
begin
PropList^[I] := PropInfo;
PropInfo := NextPropInfo(PropInfo);
end;
end;
function GetDeclaredPropList(TypeInfo: PTypeInfo; out PropList: PPropList): Integer; overload;
begin
Result := GetPropData(GetTypeData(TypeInfo))^.PropCount;
if Result > 0 then
begin
GetMem(PropList, Result * SizeOf(Pointer));
GetDeclaredPropInfos(TypeInfo, PropList);
end;
end;
function GetDeclaredPropList(AObject: TObject; out PropList: PPropList): Integer; overload;
begin
Result := GetDeclaredPropList(PTypeInfo(AObject.ClassInfo), PropList);
end;
// example usage:
var
I, Count: Integer;
PropList: PPropList;
PropInfo: PPropInfo;
begin
Count := GetDeclaredPropList(TypeInfo(TConcreteSettings), PropList);
try
for I := 0 to Count - 1 do
begin
PropInfo := PropList^[I];
Writeln(PropInfo^.Name);
end;
finally
FreeMem(PropList);
end;
end.
var
TypeData: PTypeData;
PropData: PPropData;
PropInfo: PPropInfo;
I: Integer;
begin
TypeData := GetTypeData(TypeInfo(TConcreteSettings));
PropData := GetPropData(TypeData);
if Assigned(PropData) then
begin
PropInfo := #PropData^.PropList;
for I := 0 to PropData^.PropCount - 1 do
begin
Writeln(PropInfo^.Name);
PropInfo := NextPropInfo(PropInfo);
end;
end;
end;
For implementation of GetPropData and NextPropInfo see my other answer above.

How do I cast a TObject as a TObjectList<T>?

I have a procedure that needs to insert an array of TObjects into to a list. The list can be of any of the supported types, e.g. TObjectList, TObjectList<T>, TROArray, etc.
The procedure looks like this:
type
TObjectArray = Array of TObject;
...
procedure TMyClass.DoAssignObjectList(const ObjectArray: TObjectArray;
const DstList: TObject);
var
i: Integer;
begin
if DstList is TObjectList then
begin
for i := 0 to pred(TObjectList(DstList).Count) do
TObjectList(DstList).Add(ObjectArray[i]);
end else
if DstList is TObjectList<T> then // Obviously this doesn't work
begin
for i := 0 to pred(TObjectList<T>(DstList).Count) do
TObjectList<T>(DstList).Add(ObjectArray[i]);
end
else
begin
raise Exception.CreateFmt(StrNoDoAssignORMObject, [DstList.ClassName]);
end;
end;
How can I check that an object is a TObjectList<T> and then add the elements of an array to it?
You have to use a bit RTTI to get some more information about the generic type.
The following code uses Spring4D which has some methods for that:
uses
...
Spring.Reflection;
procedure DoAssignObjectList(const ObjectArray: TObjectArray;
const DstList: TObject);
function IsGenericTObjectList(const obj: TObject): Boolean;
var
t: TRttiType;
begin
t := TType.GetType(obj.ClassInfo);
Result := t.IsGenericType and (t.GetGenericTypeDefinition = 'TObjectList<>');
end;
begin
...
if IsGenericTObjectList(DstList) then
begin
for i := 0 to pred(TObjectList<TObject>(DstList).Count) do
TObjectList<TObject>(DstList).Add(ObjectArray[i]);
...
end;
Additionally to that you can also get information about the generic parameter type of the list to check if the objects you are putting into it are matching the requirements (only works on a generic type of course):
function GetGenericTObjectListParameter(const obj: TObject): TClass;
var
t: TRttiType;
begin
t := TType.GetType(obj.ClassInfo);
Result := t.GetGenericArguments[0].AsInstance.MetaclassType;
end;
As I was writing this question I figured out a way to do this using RTTI. It should work with any list that has a procedure Add(AObject: TObject).
procedure TransferArrayItems(const Instance: TObject;
const ObjectArray: TObjectArray);
const
AddMethodName = 'Add';
var
Found: Boolean;
LMethod: TRttiMethod;
LIndex: Integer;
LParams: TArray<TRttiParameter>;
i: Integer;
RTTIContext: TRttiContext;
RttiType: TRttiType;
begin
Found := False;
LMethod := nil;
if length(ObjectArray) > 0 then
begin
RTTIContext := TRttiContext.Create;
RttiType := RTTIContext.GetType(Instance.ClassInfo);
for LMethod in RttiType.GetMethods do
begin
if SameText(LMethod.Name, AddMethodName) then
begin
LParams := LMethod.GetParameters;
if length(LParams) = 1 then
begin
Found := TRUE;
for LIndex := 0 to length(LParams) - 1 do
begin
if LParams[LIndex].ParamType.Handle <> TValue(ObjectArray[0]).TypeInfo
then
begin
Found := False;
Break;
end;
end;
end;
if Found then
Break;
end;
end;
if Found then
begin
for i := Low(ObjectArray) to High(ObjectArray) do
begin
LMethod.Invoke(Instance, [ObjectArray[i]]);
end;
end
else
begin
raise Exception.CreateFmt(StrMethodSNotFound, [AddMethodName]);
end;
end;
end;

How to display hint for a disabled control?

I have a check box which will be enabled/disabled at run time. I just want to show different tool tips if it is enabled/disabled. I was thinking about overriding OnMouseEnter event and handle it there but OnMouseEnter will be called only if the control is enabled. How can i possible achieve that behavior? Any help would be appreciated.
I tried to handle OnMouseMove of the form and do something like this
procedure Tdlg.pnlTopMouseMove(Sender: TObject;Shift: TShiftState; X, Y: Integer);
var
point: TPoint;
checkBoxCursorPos: TPoint;
begin
inherited;
point.X := X;
point.Y := Y;
checkBoxCursorPos := chkBx.ScreenToClient(point);
if (PtInRect(chkBx.ClientRect, checkBoxCursorPos)) then
begin
if(chkBx.Enabled) then
chkBx.Hint := 'Enabled'
else
chkBx.Hint := 'Disabled' ;
Application.ShowHint := True;
end;
end;
but the condition PtinRect is not satisfied. What i am doing wrong?
There is a simple solution: place an empty TLabel over the checkbox and set its Hint to the value for the disabled checkbox state. The label has to be AutoSize off and you can enforce position and size by its BoundsRect property set to that of the CheckBox.
When the CheckBox is enabled the Hint of the Checkbox is used, while the Hint of the Label is used when the CheckBox is disabled.
Update: just saw that Bummi mentions a similar idea in his comment.
The official answer: you can’t.
The workaround: you could try using the form's MouseMove-event (assuming that won’t be disabled, of course), and if the mouse cursor is over the relevant control, display the appropriate hint.
Here is a unit that can show hints for disabled controls.
I used it like this:
TATHintControl.Create(self).HintStyleController := GlobalHintStyleController;
GlobalHintStyleController is a DevExpress stylecontroller.
Then the unit
unit ATHintControl;
{
The purpose of this component is to show hints for disabled controls (VCL doesn't)
It uses timestamp comparison instead of Timers to save resources
}
interface
uses
// VCL
Classes,
Controls,
Forms,
AppEvnts,
Messages,
Windows,
// DevEx
cxHint;
type
TGetHintForControlEvent = function(AControl: TControl): string of object;
THandleControlEvent = function(AControl: TControl): boolean of object;
TATHintControl = class(TComponent)
private
fHintTimeStamp: TDateTime;
fHintHideTimeStamp: TDateTime;
fHintControl: TControl;
fHintVisible: boolean;
FHintStyleController: TcxHintStyleController;
FHintShowDelay: Integer;
FHintHideDelay: Integer;
fGetHintForControlEvent: TGetHintForControlEvent;
fHandleControlEvent: THandleControlEvent;
fApplicationEvents: TApplicationEvents;
procedure IdleHandler(Sender: TObject; var Done: Boolean);
procedure ShortcutHandler(var Msg: TWMKey; var Handled: Boolean);
procedure SetHintStyleController(const Value: TcxHintStyleController);
procedure HideHint;
function GetCursorPos(out APoint: TPoint): Boolean;
function HandleHint: boolean;
protected
function GetHintForControl(AControl: TControl): string; virtual;
function HandleControl(AControl: TControl): boolean; virtual;
public
procedure AfterConstruction; override;
published
property HintStyleController: TcxHintStyleController read FHintStyleController write SetHintStyleController;
property OnGetHintForControl: TGetHintForControlEvent read fGetHintForControlEvent write fGetHintForControlEvent;
property OnHandleControl: THandleControlEvent read fHandleControlEvent write fHandleControlEvent;
end;
implementation
uses
Types,
SysUtils,
DateUtils;
const
cHintShowDelay: Integer = 500; // msec
cHintHideDelay: Integer = 3 * 1000; // 3 sec
{ TATHintControl }
procedure TATHintControl.AfterConstruction;
begin
inherited;
fApplicationEvents := TApplicationEvents.Create(self);
fApplicationEvents.OnIdle := IdleHandler;
fApplicationEvents.OnShortCut := ShortcutHandler;
fHintShowDelay := cHintShowDelay;
fHintHideDelay := cHintHideDelay;
end;
function TATHintControl.GetCursorPos(out APoint: TPoint): Boolean;
begin
{$WARN SYMBOL_PLATFORM OFF}
result := Windows.GetCursorPos(APoint);
{$WARN SYMBOL_PLATFORM ON}
end;
function TATHintControl.GetHintForControl(AControl: TControl): string;
begin
if Assigned(OnGetHintForControl) then
result := OnGetHintForControl(AControl)
else
result := AControl.Hint;
end;
procedure TATHintControl.HideHint;
begin
HintStyleController.HideHint;
fHintTimeStamp := 0;
fHintVisible := false;
fHintHideTimeStamp := 0;
end;
procedure TATHintControl.IdleHandler(Sender: TObject; var Done: Boolean);
begin
if Assigned(HintStyleController) then
Done := HandleHint;
end;
procedure TATHintControl.SetHintStyleController(
const Value: TcxHintStyleController);
begin
FHintStyleController := Value;
end;
procedure TATHintControl.ShortcutHandler(var Msg: TWMKey; var Handled: Boolean);
begin
fHintControl := nil; // clear the HintControl so that keypress causes it to be shown again w/o having to move the mouse
end;
function TATHintControl.HandleControl(AControl: TControl): boolean;
begin
if Assigned(OnHandleControl) then
result := OnHandleControl(AControl)
else
result := not AControl.Enabled;
end;
function TATHintControl.HandleHint: boolean;
var
vNow: TDateTime;
vScreenPos: TPoint;
vClientPos: TPoint;
vControl: TControl;
vHintString: string;
vForm: TForm;
vWinControl: TWinControl;
begin
result := (fHintTimeStamp = 0);
vForm := Screen.ActiveForm;
if not Assigned(vForm) then
exit;
if not boolean(GetCursorPos(vScreenPos)) then
exit;
vNow := Now;
vControl := nil;
vWinControl := vForm as TWinControl;
while Assigned(vWinControl) do
try
vClientPos := vWinControl.ScreenToClient(vScreenPos);
vControl := vWinControl.ControlAtPos(vClientPos, true, true, true);
if not Assigned(vControl) then
begin
vControl := vWinControl;
break;
end
else
if vControl is TWinControl then
vWinControl := vControl as TWinControl
else
vWinControl := nil;
except
exit; // in some cases ControlAtPos can fail with EOleError: Could not obtain OLE control window handle.
end;
if (fHintControl <> vControl) then
begin
if fHintVisible then
HideHint;
if Assigned(vControl) and HandleControl(vControl) then
begin
fHintControl := vControl;
fHintTimeStamp := vNow; // starts timer for hint to show
end
else
begin
fHintTimeStamp := 0;
fHintControl := nil;
end;
end
else
begin
if fHintVisible and (vNow > fHintHideTimeStamp) then
begin
HideHint;
end
else // we check HandleControl again here to make sure we still want to show the hint
if not fHintVisible and Assigned(vControl) and HandleControl(vControl) and (fHintTimeStamp > 0) and (vNow > IncMillisecond(fHintTimeStamp, fHintShowDelay)) then
begin
vHintString := GetHintForControl(vControl);
if vHintString = '' then
exit;
HintStyleController.ShowHint(vScreenPos.X + 0, vScreenPos.Y + 18, '', vHintString);
fHintTimeStamp := vNow;
fHintControl := vControl;
fHintVisible := true;
// base hide delay + dynamic part based on length of the hint string, 500 msec per 30 characters
fHintHideTimeStamp := vNow + IncMillisecond(0, fHintHideDelay) + ((Length(vHintString) div 20) * EncodeTime(0,0,0,500));
end
end;
result := (fHintTimeStamp = 0);
end;
end.

Delphi: How to make cells' texts in TStringGrid center aligned?

It seems something obvious to have. I want the texts to be in the center of the cells, but for some reason I can't find it in properties. How can I do this?
There's no property to center the text in TStringGrid, but you can do that at DrawCell event as:
procedure TForm1.StringGrid1DrawCell(Sender: TObject; ACol, ARow: Integer;
Rect: TRect; State: TGridDrawState);
var
S: string;
SavedAlign: word;
begin
if ACol = 1 then begin // ACol is zero based
S := StringGrid1.Cells[ACol, ARow]; // cell contents
SavedAlign := SetTextAlign(StringGrid1.Canvas.Handle, TA_CENTER);
StringGrid1.Canvas.TextRect(Rect,
Rect.Left + (Rect.Right - Rect.Left) div 2, Rect.Top + 2, S);
SetTextAlign(StringGrid1.Canvas.Handle, SavedAlign);
end;
end;
The code I posted from here
UPDATE:
to center text while writing in the cell, add this code to GetEditText Event:
procedure TForm1.StringGrid1GetEditText(Sender: TObject; ACol, ARow: Integer;
var Value: string);
var
S : String;
I: Integer;
IE : TInplaceEdit ;
begin
for I := 0 to StringGrid1.ControlCount - 1 do
if StringGrid1.Controls[i].ClassName = 'TInplaceEdit' then
begin
IE := TInplaceEdit(StringGrid1.Controls[i]);
ie.Alignment := taCenter
end;
end;
This one is a much better solution that the others and on them there was a mistype on procedures TStringGrid.SetCellsAlignment and TStringGrid.SetCellsAlignment the (-1 < Index) compare was correct, but then and else parts were swapped... The correct version (this one) will show that when index is bigger than -1 it will overwrite value stored else it will add a new entry, the others will do just the oposite bringing a list out of index message, thanks for detecting such.
I have also make able to be all in another separated unit, so here it is (hope now it is correct and thanks for detecting such mistypes):
unit AlignedTStringGrid;
interface
uses Windows,SysUtils,Classes,Grids;
type
TStringGrid=class(Grids.TStringGrid)
private
FCellsAlignment:TStringList;
FColsDefaultAlignment:TStringList;
function GetCellsAlignment(ACol,ARow:Integer):TAlignment;
procedure SetCellsAlignment(ACol,ARow:Integer;const Alignment:TAlignment);
function GetColsDefaultAlignment(ACol:Integer):TAlignment;
procedure SetColsDefaultAlignment(ACol:Integer;const Alignment:TAlignment);
protected
procedure DrawCell(ACol,ARow:Longint;ARect:TRect;AState:TGridDrawState);override;
public
constructor Create(AOwner:TComponent);override;
destructor Destroy;override;
property CellsAlignment[ACol,ARow:Integer]:TAlignment read GetCellsAlignment write SetCellsAlignment;
property ColsDefaultAlignment[ACol:Integer]:TAlignment read GetColsDefaultAlignment write SetColsDefaultAlignment;
end;
implementation
constructor TStringGrid.Create(AOwner:TComponent);
begin
inherited Create(AOwner);
FCellsAlignment:=TStringList.Create;
FCellsAlignment.CaseSensitive:=True;
FCellsAlignment.Sorted:=True;
FCellsAlignment.Duplicates:=dupIgnore;
FColsDefaultAlignment:=TStringList.Create;
FColsDefaultAlignment.CaseSensitive:=True;
FColsDefaultAlignment.Sorted:=True;
FColsDefaultAlignment.Duplicates:=dupIgnore;
end;
destructor TStringGrid.Destroy;
begin
FCellsAlignment.Free;
FColsDefaultAlignment.Free;
inherited Destroy;
end;
procedure TStringGrid.SetCellsAlignment(ACol,ARow: Integer; const Alignment: TAlignment);
var
Index:Integer;
begin
if (-1 < Index) then begin
FCellsAlignment.Objects[Index]:= TObject(Alignment);
end else begin
FCellsAlignment.AddObject(IntToStr(ACol) + '-' + IntToStr(ARow), TObject(Alignment));
end;
end;
function TStringGrid.GetCellsAlignment(ACol,ARow: Integer): TAlignment;
var
Index:Integer;
begin
Index:= FCellsAlignment.IndexOf(IntToStr(ACol)+'-'+IntToStr(ARow));
if (-1 < Index) then begin
GetCellsAlignment:= TAlignment(FCellsAlignment.Objects[Index]);
end else begin
GetCellsAlignment:= ColsDefaultAlignment[ACol];
end;
end;
procedure TStringGrid.SetColsDefaultAlignment(ACol: Integer; const Alignment: TAlignment);
var
Index:Integer;
begin
Index:= FColsDefaultAlignment.IndexOf(IntToStr(ACol));
if (-1 < Index) then begin
FColsDefaultAlignment.Objects[Index]:= TObject(Alignment);
end else begin
FColsDefaultAlignment.AddObject(IntToStr(ACol), TObject(Alignment));
end;
end;
function TStringGrid.GetColsDefaultAlignment(ACol:Integer):TAlignment;
var
Index:Integer;
begin
Index:= FColsDefaultAlignment.IndexOf(IntToStr(ACol));
if (-1 < Index) then begin
GetColsDefaultAlignment:= TAlignment(FColsDefaultAlignment.Objects[Index]);
end else begin
GetColsDefaultAlignment:=taLeftJustify;
end;
end;
procedure TStringGrid.DrawCell(ACol,ARow:Longint;ARect:TRect;AState:TGridDrawState);
var
Old_DefaultDrawing:Boolean;
begin
if DefaultDrawing then begin
case CellsAlignment[ACol,ARow] of
taLeftJustify: begin
Canvas.TextRect(ARect,ARect.Left+2,ARect.Top+2,Cells[ACol,ARow]);
end;
taRightJustify: begin
Canvas.TextRect(ARect,ARect.Right -2 -Canvas.TextWidth(Cells[ACol,ARow]), ARect.Top+2,Cells[ACol,ARow]);
end;
taCenter: begin
Canvas.TextRect(ARect,(ARect.Left+ARect.Right-Canvas.TextWidth(Cells[ACol,ARow]))div 2,ARect.Top+2,Cells[ACol,ARow]);
end;
end;
end;
Old_DefaultDrawing:= DefaultDrawing;
DefaultDrawing:=False;
inherited DrawCell(ACol,ARow,ARect,AState);
DefaultDrawing:= Old_DefaultDrawing;
end;
end.
This is a whole unit, save it to a file called AlignedTStringGrid.pas.
Then on any form you have a TStringGrid add ,AlignedTStringGrid at the end of the interface uses clause.
Note: The same can be done for rows, but for now I do not know how to mix both (cols and rows) because of how to select priority, if anyone is very interested on it let me know.
P.D.: The same idea is possible to be done for TEdit, just search on stackoverflow.com for TEdit.CreateParams or read post How to set textalignment in TEdit control

How to "scan" the full list of currently-installed VCL components

I still haven't found a truly satisfactory answer to this question, and am now considering rolling my own. I have ModelMaker and GExperts, and neither seems to load the comprehensive class-hierarchy I am looking for. As well, I don't think the folks at DevExpress will fork over the CDK code which compiles a full class list to inherit from... ;-)
SO...
If ALL I want to do is build a self-referencing table of all registered component classes (or even all classes including non-components, if that's just as easy/possible), what would be the best way to go about doing that?
Note: I don't really need property / method details; JUST a complete list of class names (and parent names) I can store to a table and put in a treeview. Anything beyond that, though, is more than welcome as bonus info. :-)
Update later:
One answer that shows up in my "recent" section on SO, but not here on the question (maybe they erased it?), was this:"u may want to take a look on code of Component Search, it may help you to enumrate all components installed." Is that code available? Is so, where is it hiding? Would be interesting to study.
Unfortunately, the code implementing the RegisterClass mechanism is hidden in Classes implementation section.
If you need this for getting the list of components installed in the IDE, you can write a design package, install it into the IDE and use IOTAPackageServices in ToolsAPI unit. This will give you the list of installed packages and their components.
Note: You'll have to add designide.dcp to your 'requires' clause to be able to use Delphi's internal units like ToolsAPI.
A bit more work but a more generic way would be to enumerate all loaded modules. You can call GetPackageInfo (SysUtils) on a package module to enumerate contained unit names and required packages. However this will not give you a list of classes contained in the package.
You could enumerate the package's list of exported functions (e.g. with TJclPeImage in the JCL) and search for those named like this:
#<unit_name>#<class_name>#
for example: '#System#TObject#'.
By calling GetProcAddress with the function name you get the TClass reference. From there you can walk the hierarchy using ClassParent. This way you can enumerate all classes in all packages loaded in a process running a Delphi executable compiled with runtime packages (Delphi IDE, too).
Another idea is to scan for type information which is on top of the list of exported functions so you can skip enumerating further. The type infos are exported with names starting with prefix '#$xp$'. Here's an example:
unit PackageUtils;
interface
uses
Windows, Classes, SysUtils, Contnrs, TypInfo;
type
TDelphiPackageList = class;
TDelphiPackage = class;
TDelphiProcess = class
private
FPackages: TDelphiPackageList;
function GetPackageCount: Integer;
function GetPackages(Index: Integer): TDelphiPackage;
public
constructor Create; virtual;
destructor Destroy; override;
procedure Clear; virtual;
function FindPackage(Handle: HMODULE): TDelphiPackage;
procedure Reload; virtual;
property PackageCount: Integer read GetPackageCount;
property Packages[Index: Integer]: TDelphiPackage read GetPackages;
end;
TDelphiPackageList = class(TObjectList)
protected
function GetItem(Index: Integer): TDelphiPackage;
procedure SetItem(Index: Integer; APackage: TDelphiPackage);
public
function Add(APackage: TDelphiPackage): Integer;
function Extract(APackage: TDelphiPackage): TDelphiPackage;
function Remove(APackage: TDelphiPackage): Integer;
function IndexOf(APackage: TDelphiPackage): Integer;
procedure Insert(Index: Integer; APackage: TDelphiPackage);
function First: TDelphiPackage;
function Last: TDelphiPackage;
property Items[Index: Integer]: TDelphiPackage read GetItem write SetItem; default;
end;
TDelphiPackage = class
private
FHandle: THandle;
FInfoTable: Pointer;
FTypeInfos: TList;
procedure CheckInfoTable;
procedure CheckTypeInfos;
function GetDescription: string;
function GetFileName: string;
function GetInfoName(NameType: TNameType; Index: Integer): string;
function GetShortName: string;
function GetTypeInfoCount(Kinds: TTypeKinds): Integer;
function GetTypeInfos(Kinds: TTypeKinds; Index: Integer): PTypeInfo;
public
constructor Create(AHandle: HMODULE; AInfoTable: Pointer = nil);
destructor Destroy; override;
property Description: string read GetDescription;
property FileName: string read GetFileName;
property Handle: THandle read FHandle;
property ShortName: string read GetShortName;
property TypeInfoCount[Kinds: TTypeKinds]: Integer read GetTypeInfoCount;
property TypeInfos[Kinds: TTypeKinds; Index: Integer]: PTypeInfo read GetTypeInfos;
end;
implementation
uses
RTLConsts, SysConst,
PSAPI, ImageHlp;
{ Package info structures copied from SysUtils.pas }
type
PPkgName = ^TPkgName;
TPkgName = packed record
HashCode: Byte;
Name: array[0..255] of Char;
end;
PUnitName = ^TUnitName;
TUnitName = packed record
Flags : Byte;
HashCode: Byte;
Name: array[0..255] of Char;
end;
PPackageInfoHeader = ^TPackageInfoHeader;
TPackageInfoHeader = packed record
Flags: Cardinal;
RequiresCount: Integer;
{Requires: array[0..9999] of TPkgName;
ContainsCount: Integer;
Contains: array[0..9999] of TUnitName;}
end;
TEnumModulesCallback = function (Module: HMODULE; Data: Pointer = nil): Boolean;
TEnumModulesProc = function (Callback: TEnumModulesCallback; Data: Pointer = nil): Boolean;
const
STypeInfoPrefix = '#$xp$';
var
EnumModules: TEnumModulesProc = nil;
function PackageInfoTable(Module: HMODULE): PPackageInfoHeader; forward;
function AddPackage(Module: HMODULE; Data: {TDelphiPackageList} Pointer): Boolean;
var
InfoTable: Pointer;
begin
Result := False;
if (Module <> HInstance) then
begin
InfoTable := PackageInfoTable(Module);
if Assigned(InfoTable) then
TDelphiPackageList(Data).Add(TDelphiPackage.Create(Module, InfoTable));
end;
end;
function GetPackageDescription(Module: HMODULE): string;
var
ResInfo: HRSRC;
ResData: HGLOBAL;
begin
Result := '';
ResInfo := FindResource(Module, 'DESCRIPTION', RT_RCDATA);
if ResInfo <> 0 then
begin
ResData := LoadResource(Module, ResInfo);
if ResData <> 0 then
try
Result := PWideChar(LockResource(ResData));
UnlockResource(ResData);
finally
FreeResource(ResData);
end;
end;
end;
function EnumModulesPS(Callback: TEnumModulesCallback; Data: Pointer = nil): Boolean;
var
ProcessHandle: THandle;
SizeNeeded: Cardinal;
P, ModuleHandle: PDWORD;
I: Integer;
begin
Result := False;
ProcessHandle := OpenProcess(PROCESS_QUERY_INFORMATION or PROCESS_VM_READ, False, GetCurrentProcessId);
if ProcessHandle = 0 then
RaiseLastOSError;
try
SizeNeeded := 0;
EnumProcessModules(ProcessHandle, nil, 0, SizeNeeded);
if SizeNeeded = 0 then
Exit;
P := AllocMem(SizeNeeded);
try
if EnumProcessModules(ProcessHandle, P, SizeNeeded, SizeNeeded) then
begin
ModuleHandle := P;
for I := 0 to SizeNeeded div SizeOf(DWORD) - 1 do
begin
if Callback(ModuleHandle^, Data) then
Exit;
Inc(ModuleHandle);
end;
Result := True;
end;
finally
FreeMem(P);
end;
finally
CloseHandle(ProcessHandle);
end;
end;
function EnumModulesTH(Callback: TEnumModulesCallback; Data: Pointer = nil): Boolean;
begin
Result := False;
// todo win9x?
end;
function PackageInfoTable(Module: HMODULE): PPackageInfoHeader;
var
ResInfo: HRSRC;
Data: THandle;
begin
Result := nil;
ResInfo := FindResource(Module, 'PACKAGEINFO', RT_RCDATA);
if ResInfo <> 0 then
begin
Data := LoadResource(Module, ResInfo);
if Data <> 0 then
try
Result := LockResource(Data);
UnlockResource(Data);
finally
FreeResource(Data);
end;
end;
end;
{ TDelphiProcess private }
function TDelphiProcess.GetPackageCount: Integer;
begin
Result := FPackages.Count;
end;
function TDelphiProcess.GetPackages(Index: Integer): TDelphiPackage;
begin
Result := FPackages[Index];
end;
{ TDelphiProcess public }
constructor TDelphiProcess.Create;
begin
inherited Create;
FPackages := TDelphiPackageList.Create;
Reload;
end;
destructor TDelphiProcess.Destroy;
begin
FPackages.Free;
inherited Destroy;
end;
procedure TDelphiProcess.Clear;
begin
FPackages.Clear;
end;
function TDelphiProcess.FindPackage(Handle: HMODULE): TDelphiPackage;
var
I: Integer;
begin
Result := nil;
for I := 0 to FPackages.Count - 1 do
if FPackages[I].Handle = Handle then
begin
Result := FPackages[I];
Break;
end;
end;
procedure TDelphiProcess.Reload;
begin
Clear;
if Assigned(EnumModules) then
EnumModules(AddPackage, FPackages);
end;
{ TDelphiPackageList protected }
function TDelphiPackageList.GetItem(Index: Integer): TDelphiPackage;
begin
Result := TDelphiPackage(inherited GetItem(Index));
end;
procedure TDelphiPackageList.SetItem(Index: Integer; APackage: TDelphiPackage);
begin
inherited SetItem(Index, APackage);
end;
{ TDelphiPackageList public }
function TDelphiPackageList.Add(APackage: TDelphiPackage): Integer;
begin
Result := inherited Add(APackage);
end;
function TDelphiPackageList.Extract(APackage: TDelphiPackage): TDelphiPackage;
begin
Result := TDelphiPackage(inherited Extract(APackage));
end;
function TDelphiPackageList.First: TDelphiPackage;
begin
Result := TDelphiPackage(inherited First);
end;
function TDelphiPackageList.IndexOf(APackage: TDelphiPackage): Integer;
begin
Result := inherited IndexOf(APackage);
end;
procedure TDelphiPackageList.Insert(Index: Integer; APackage: TDelphiPackage);
begin
inherited Insert(Index, APackage);
end;
function TDelphiPackageList.Last: TDelphiPackage;
begin
Result := TDelphiPackage(inherited Last);
end;
function TDelphiPackageList.Remove(APackage: TDelphiPackage): Integer;
begin
Result := inherited Remove(APackage);
end;
{ TDelphiPackage private }
procedure TDelphiPackage.CheckInfoTable;
begin
if not Assigned(FInfoTable) then
FInfoTable := PackageInfoTable(Handle);
if not Assigned(FInfoTable) then
raise EPackageError.CreateFmt(SCannotReadPackageInfo, [ExtractFileName(GetModuleName(Handle))]);
end;
procedure TDelphiPackage.CheckTypeInfos;
var
ExportDir: PImageExportDirectory;
Size: DWORD;
Names: PDWORD;
I: Integer;
begin
if not Assigned(FTypeInfos) then
begin
FTypeInfos := TList.Create;
try
Size := 0;
ExportDir := ImageDirectoryEntryToData(Pointer(Handle), True, IMAGE_DIRECTORY_ENTRY_EXPORT, Size);
if not Assigned(ExportDir) then
Exit;
Names := PDWORD(DWORD(Handle) + DWORD(ExportDir^.AddressOfNames));
for I := 0 to ExportDir^.NumberOfNames - 1 do
begin
if StrLIComp(PChar(DWORD(Handle) + Names^), STypeInfoPrefix, StrLen(STypeInfoPrefix)) <> 0 then
Break;
FTypeInfos.Add(GetProcAddress(Handle, PChar(DWORD(Handle) + Names^)));
Inc(Names);
end;
except
FreeAndNil(FTypeInfos);
raise;
end;
end;
end;
function TDelphiPackage.GetDescription: string;
begin
Result := GetPackageDescription(Handle);
end;
function TDelphiPackage.GetFileName: string;
begin
Result := GetModuleName(FHandle);
end;
function TDelphiPackage.GetInfoName(NameType: TNameType; Index: Integer): string;
var
P: Pointer;
Count: Integer;
I: Integer;
begin
Result := '';
CheckInfoTable;
Count := PPackageInfoHeader(FInfoTable)^.RequiresCount;
P := Pointer(Cardinal(FInfoTable) + SizeOf(TPackageInfoHeader));
case NameType of
ntContainsUnit:
begin
for I := 0 to Count - 1 do
P := Pointer(Cardinal(P) + StrLen(PPkgName(P)^.Name) + 2);
Count := Integer(P^);
P := Pointer(Cardinal(P) + SizeOf(Integer));
if (Index >= 0) and (Index < Count) then
begin
for I := 0 to Count - 1 do
P := Pointer(Cardinal(P) + StrLen(PUnitName(P)^.Name) + 3);
Result := PUnitName(P)^.Name;
end;
end;
ntRequiresPackage:
if (Index >= 0) and (Index < Count) then
begin
for I := 0 to Index - 1 do
P := Pointer(Cardinal(P) + StrLen(PPkgName(P)^.Name) + 2);
Result := PPkgName(P)^.Name;
end;
ntDcpBpiName:
if PPackageInfoHeader(FInfoTable)^.Flags and pfPackageModule <> 0 then
begin
for I := 0 to Count - 1 do
P := Pointer(Cardinal(P) + StrLen(PPkgName(P)^.Name) + 2);
Count := Integer(P^);
P := Pointer(Cardinal(P) + SizeOf(Integer));
for I := 0 to Count - 1 do
P := Pointer(Cardinal(P) + StrLen(PUnitName(P)^.Name) + 3);
Result := PPkgName(P)^.Name;
end;
end;
end;
function TDelphiPackage.GetShortName: string;
begin
Result := GetInfoName(ntDcpBpiName, 0);
end;
function TDelphiPackage.GetTypeInfoCount(Kinds: TTypeKinds): Integer;
var
I: Integer;
begin
CheckTypeInfos;
Result := 0;
for I := 0 to FTypeInfos.Count - 1 do
if (Kinds = []) or (PTypeInfo(FTypeInfos[I])^.Kind in Kinds) then
Inc(Result);
end;
function TDelphiPackage.GetTypeInfos(Kinds: TTypeKinds; Index: Integer): PTypeInfo;
var
I, J: Integer;
begin
CheckTypeInfos;
Result := nil;
J := -1;
for I := 0 to FTypeInfos.Count - 1 do
if (Kinds = []) or (PTypeInfo(FTypeInfos[I])^.Kind in Kinds) then
begin
Inc(J);
if J = Index then
begin
Result := FTypeInfos[I];
Break;
end;
end;
end;
{ TDelphiPackage public }
constructor TDelphiPackage.Create(AHandle: HMODULE; AInfoTable: Pointer = nil);
begin
inherited Create;
FHandle := AHandle;
FInfoTable := AInfoTable;
FTypeInfos := nil;
end;
destructor TDelphiPackage.Destroy;
begin
FTypeInfos.Free;
inherited Destroy;
end;
initialization
case Win32Platform of
VER_PLATFORM_WIN32_WINDOWS:
EnumModules := EnumModulesTH;
VER_PLATFORM_WIN32_NT:
EnumModules := EnumModulesPS;
else
EnumModules := nil;
end;
finalization
end.
Unit of the test design package installed in the IDE:
unit Test;
interface
uses
SysUtils, Classes,
ToolsAPI;
type
TTestWizard = class(TNotifierObject, IOTAWizard, IOTAMenuWizard)
private
{ IOTAWizard }
procedure Execute;
function GetIDString: string;
function GetName: string;
function GetState: TWizardState;
{ IOTAMenuWizard }
function GetMenuText: string;
end;
implementation
uses
TypInfo,
PackageUtils;
function AncestryStr(AClass: TClass): string;
begin
Result := '';
if not Assigned(AClass) then
Exit;
Result := AncestryStr(AClass.ClassParent);
if Result <> '' then
Result := Result + '\';
Result := Result + AClass.ClassName;
end;
procedure ShowMessage(const S: string);
begin
with BorlandIDEServices as IOTAMessageServices do
AddTitleMessage(S);
end;
{ TTestWizard }
procedure TTestWizard.Execute;
var
Process: TDelphiProcess;
I, J: Integer;
Package: TDelphiPackage;
PInfo: PTypeInfo;
PData: PTypeData;
begin
Process := TDelphiProcess.Create;
for I := 0 to Process.PackageCount - 1 do
begin
Package := Process.Packages[I];
for J := 0 to Package.TypeInfoCount[[tkClass]] - 1 do
begin
PInfo := Package.TypeInfos[[tkClass], J];
PData := GetTypeData(PInfo);
ShowMessage(Format('%s: %s.%s (%s)', [Package.ShortName, PData^.UnitName, PInfo^.Name, AncestryStr(PData^.ClassType)]));
end;
end;
end;
function TTestWizard.GetIDString: string;
begin
Result := 'TOndrej.TestWizard';
end;
function TTestWizard.GetName: string;
begin
Result := 'Test';
end;
function TTestWizard.GetState: TWizardState;
begin
Result := [wsEnabled];
end;
function TTestWizard.GetMenuText: string;
begin
Result := 'Test';
end;
var
Index: Integer = -1;
initialization
with BorlandIDEServices as IOTAWizardServices do
Index := AddWizard(TTestWizard.Create);
finalization
if Index <> -1 then
with BorlandIDEServices as IOTAWizardServices do
RemoveWizard(Index);
end.
You have to add designide to your requires clause. When you install this design package a new menu item Test should appear under Delphi's Help menu. Clicking it should display all loaded classes in the Messages window.
Have you tried Delphi's own class browser?
The browser gets loaded with shortcut CTRL-SHIFT-B. I believe you can access its options by right clicking in the browser. Here you have the option to show only the classes in your project or all known classes.
I haven't checked but I expect every descendant from TComponent, including installed components to be visible below the TComponent node. Use CTRL-F to search for a particular class.
Edit: according to this Delphi Wiki page, CTRL+SHIFT+B is only available in Delphi5. I don't have Delphi 2007 to check for this but if you can not find a class browser in your version, I'd suspect there isn't any.

Resources