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

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.

user_282848 · Answer

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.)

user_1580348 · Answer

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;
  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;
  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;
  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

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

2 Answers