How to transform a class name string to a class object? - class

Question

In a 32-bit VCL Application in Windows 10 in Delphi 11 Alexandria, I am trying to write a small app that finds the list of ANCESTORS from a class name that the user inputs in an Edit box:
procedure TForm1.DoShowAncestors(const aClassName: string);
var
ClassRef: TClass;
begin
lstAncestors.Clear;
// Does not work:
//ClassRef := TClass.Create;
//ClassRef.ClassName := aClassName;
// [dcc32 Error] E2076 This form of method call only allowed for class methods or constructor:
ClassRef := TClass(aClassName).ClassType;
while ClassRef <> nil do
begin
lstAncestors.Items.Add(ClassRef.ClassName);
ClassRef := ClassRef.ClassParent;
end;
end;
procedure TForm1.edtClassNameKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
if Key = VK_RETURN then
begin
DoShowAncestors(Trim(edtClassName.Text));
end;
end;
However, the problem is to transform the input string into a TClass object. See the above error comments.

Answer 1

Since Delphi is a compiled language, obtaining a class (or object) by name is not a natural operation, but requires some kind of framework.
Fortunately, modern RTTI (uses RTTI) can easily handle this for you:
procedure ShowAncestors(const AClass: string);
begin
var Ctx := TRttiContext.Create;
try
var LType := Ctx.FindType(AClass);
if LType is TRttiInstanceType then
begin
var R := TRttiInstanceType(LType).MetaclassType;
while Assigned(R) do
begin
ShowMessage(R.ClassName);
R := R.ClassParent;
end;
end;
finally
Ctx.Free; // actually, just to make the code "look" right!
end;
end;
Try it with
ShowAncestors('Vcl.Forms.TForm')
for instance.
(Of course, this only works for classes actually included in the final EXE.)

Answer 2

Now there is no more need to enter a fully qualified class name, and now there is a visual feedback validation of the class name in the edit:
unit Unit1;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, System.Classes, Vcl.StdCtrls,
Vcl.ExtCtrls;
type
TForm1 = class(TForm)
edtClassName: TEdit;
lstAncestors: TListBox;
pnlEdit: TPanel;
procedure edtClassNameChange(Sender: TObject);
procedure edtClassNameKeyDown(Sender: TObject; var Key: Word; Shift:
TShiftState);
procedure edtClassNameKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);
procedure FormActivate(Sender: TObject);
private
FDontDoIt: Boolean;
function CheckEmptyEdit: Boolean;
procedure DoShowAncestors(const aClassName: string);
function GetMatchingTypeName: string;
procedure SetEditBorder;
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
uses
System.StrUtils,
System.RTTI;
function FindMyClass(const aName: string): TClass;
var
ctx: TRttiContext;
ThisType: TRttiType;
ThisList: TArray<TRttiType>;
FPos: Integer;
begin
Result := nil;
ctx := TRttiContext.Create;
try
ThisList := ctx.GetTypes;
for ThisType in ThisList do
begin
if ThisType.IsInstance and (EndsText(aName, ThisType.Name)) then
begin
Result := ThisType.AsInstance.MetaClassType;
BREAK;
end;
end;
finally
ctx.Free;
end;
end;
procedure TForm1.edtClassNameChange(Sender: TObject);
var
ctx: TRttiContext;
ThisType: TRttiType;
ThisList: TArray<TRttiType>;
InputStr: string;
FPos: Integer;
begin
if CheckEmptyEdit then
EXIT;
if FDontDoIt then
begin
FDontDoIt := False;
EXIT;
end;
FPos := edtClassName.SelStart;
var ThisMatchingTypeName := GetMatchingTypeName;
FDontDoIt := True;
try
if ThisMatchingTypeName <> '' then
edtClassName.Text := ThisMatchingTypeName;
finally
FDontDoIt := False;
end;
SetEditBorder;
if pnlEdit.Color <> clRed then
begin
edtClassName.SelStart := FPos;
edtClassName.SelLength := Length(ThisMatchingTypeName) - FPos;
end;
end;
procedure TForm1.SetEditBorder;
begin
if FindMyClass(Trim(edtClassName.Text)) = nil then
begin
pnlEdit.Color := clRed;
lstAncestors.Clear;
end
else
pnlEdit.Color := clGreen;
end;
function TForm1.GetMatchingTypeName: string;
var
ctx: TRttiContext;
ThisType: TRttiType;
ThisList: TArray<TRttiType>;
InputStr: string;
begin
Result := '';
InputStr := Trim(edtClassName.Text);
if InputStr = '' then EXIT;
ctx := TRttiContext.Create;
try
ThisList := ctx.GetTypes;
for ThisType in ThisList do
begin
if ThisType.IsInstance and (StartsText(InputStr, ThisType.Name)) then
begin
Result := ThisType.Name;
BREAK;
end;
end;
finally
ctx.Free;
end;
end;
procedure TForm1.DoShowAncestors(const aClassName: string);
var
ClassRef: TClass;
begin
lstAncestors.Items.BeginUpdate;
try
lstAncestors.Clear;
ClassRef := FindMyClass(aClassName);
while ClassRef <> nil do
begin
lstAncestors.Items.Add(ClassRef.ClassName);
ClassRef := ClassRef.ClassParent;
end;
finally
lstAncestors.Items.EndUpdate;
end;
end;
procedure TForm1.edtClassNameKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
case Key of
VK_BACK: FDontDoIt := True;
VK_DELETE: FDontDoIt := True;
end;
end;
procedure TForm1.edtClassNameKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
case Key of
VK_RETURN: DoShowAncestors(Trim(edtClassName.Text));
VK_BACK:
begin
FDontDoIt := False;
SetEditBorder;
CheckEmptyEdit;
end;
VK_DELETE:
begin
FDontDoIt := False;
SetEditBorder;
CheckEmptyEdit;
end;
end;
end;
function TForm1.CheckEmptyEdit: Boolean;
begin
Result := False;
if Trim(edtClassName.Text) = '' then
begin
pnlEdit.Color := clGray;
lstAncestors.Clear;
Result := True;
end;
end;
procedure TForm1.FormActivate(Sender: TObject);
begin
edtClassName.SetFocus;
end;
end.
And here is the DFM:
object Form1: TForm1
Left = 0
Top = 0
Caption = 'Show Class Ancestors'
ClientHeight = 300
ClientWidth = 434
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -15
Font.Name = 'Segoe UI'
Font.Style = []
Position = poScreenCenter
ShowHint = True
OnActivate = FormActivate
PixelsPerInch = 120
TextHeight = 20
object lstAncestors: TListBox
AlignWithMargins = True
Left = 16
Top = 55
Width = 402
Height = 229
Margins.Left = 16
Margins.Top = 16
Margins.Right = 16
Margins.Bottom = 16
Align = alClient
ItemHeight = 20
TabOrder = 0
ExplicitTop = 60
ExplicitHeight = 224
end
object pnlEdit: TPanel
AlignWithMargins = True
Left = 16
Top = 16
Width = 402
Height = 23
Margins.Left = 16
Margins.Top = 16
Margins.Right = 16
Margins.Bottom = 0
Align = alTop
BevelOuter = bvNone
Caption = 'pnlEdit'
Color = clGray
ParentBackground = False
TabOrder = 1
object edtClassName: TEdit
AlignWithMargins = True
Left = 1
Top = 1
Width = 400
Height = 21
Hint = 'Enter a known Class Name and then press the Enter/Return key.'
Margins.Left = 1
Margins.Top = 1
Margins.Right = 1
Margins.Bottom = 1
Align = alClient
BorderStyle = bsNone
TabOrder = 0
OnChange = edtClassNameChange
OnKeyDown = edtClassNameKeyDown
OnKeyUp = edtClassNameKeyUp
ExplicitLeft = 0
ExplicitTop = 0
ExplicitWidth = 402
ExplicitHeight = 28
end
end
end