Программирование на Delphi

FAQ VCL
Компилятор, RTTI

:: Меню ::

:: На главную ::

:: FAQ ::

:: Заметки ::

:: Практика ::

:: Win API ::

:: Проекты ::

:: Скачать ::

:: Секреты ::

:: Ссылки ::

:: Сервис ::

:: Написать ::

:: MVP ::

:: RSS ::

Как получить список свойств объекта с их значениями?


// Способ первый
uses
  TypInfo;

procedure TForm1.Button1Click(Sender: TObject);
var
  Count: integer;
  Data: PTypeData;
  i: Integer;
  Info: PTypeInfo;
  PropList: PPropList;
  PropInfo: PPropInfo;
  PropName: string;
  PropVal: variant;
  TmpS: string;
begin
  Info := Button1.ClassInfo;
  Data := GetTypeData(Info);
  GetMem(PropList, Data^.PropCount * SizeOf(PPropInfo));
  try
    Count := GetPropList(Info, tkAny, PropList);
    ListBox1.Clear;
    for i := 0 to Count-1 do
    begin
       PropName := PropList^[i]^.Name;
       PropInfo := GetPropInfo(Info, PropName);
       if PropInfo <> nil then
       begin
         case PropInfo^.PropType^.Kind of
           tkClass, tkMethod:
             PropVal := '$' + IntToHex(GetOrdProp(Button1, PropInfo), 8);
           tkFloat:
             PropVal := GetFloatProp(Button1, PropInfo);
           tkInteger:
             PropVal := GetOrdProp(Button1, PropInfo);
           tkString, tkLString, tkWString:
             PropVal := GetStrProp(Button1, PropInfo);
           tkEnumeration:
             PropVal := GetEnumProp(Button1, PropInfo);
           else
             PropVal := '...';
         end;
         TmpS := PropVal;
         ListBox1.Items.Add(Format('%s: %s [default: %s]',
           [PropName, TmpS, '$' + IntToHex(PropInfo.default, 8)]));
       end;
     end;
  finally
    FreeMem(PropList, Data^.PropCount * SizeOf(PPropInfo));
  end;
end;

// Способ второй
uses
  TypInfo;

procedure GetPropertyValues(AObj: TObject; AValues: TStrings);
var
  Count: Integer;
  Data: PTypeData;
  Default: string;
  i: Integer;
  Info: PTypeInfo;
  PropList: PPropList;
  PropInfo: PPropInfo;
  PropName: string;
  Value: Variant;
begin
  Info := AObj.ClassInfo;
  Data := GetTypeData(Info);
  GetMem(PropList, Data^.PropCount * SizeOf(PPropInfo));
  try
    Count := GetPropList(Info, tkAny, PropList);
    for i := 0 to Count-1 do
    begin
      PropName := PropList^[i]^.Name;
      PropInfo := GetPropInfo(Info, PropName);
      if PropInfo <> nil then
      begin
        case PropInfo^.PropType^.Kind of
          tkClass, tkMethod:
            Value := '$' + IntToHex(GetOrdProp(AObj, PropInfo), 8);
          tkFloat:
            Value := GetFloatProp(AObj, PropInfo);
          tkInteger:
            Value := GetOrdProp(AObj, PropInfo);
          tkString, tkLString, tkWString:
            Value := GetStrProp(AObj, PropInfo);
          tkEnumeration:
            Value := GetEnumProp(AObj, PropInfo);
          else
            Value := '???';
        end;
        if PropInfo.Default = LongInt($80000000) then
          Default := 'none'
        else
          Default := IntToStr(PropInfo.Default);
        AValues.Add(Format('%s: %s [default: %s]', [PropName, Value, Default]));
      end;
    end;
  finally
    FreeMem(PropList, Data^.PropCount * SizeOf(PPropInfo));
  end;
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  ListBox1.Clear;
  GetPropertyValues(Button1, ListBox1.Items);
end;

Как присвоить событие через TMethod в runtime?


type
  TForm1 = class(TForm)
    Button1: TButton;
    procedure FormCreate(Sender: TObject);
  private
    procedure ButtonClick(Sender: TObject);
  end;

implementation

uses
  TypInfo;

procedure AssignEventToComponent(C: TComponent; MethodName: string;
  const Evt: TNotifyEvent; OnlyIfNil: Boolean = True);
var
  M: TMethod;
begin
  M := GetMethodProp(C, MethodName);
  if not OnlyIfNil or (M.Code = nil) then
  begin
    TNotifyEvent(M) := Evt;
    SetMethodProp(C, MethodName, M);
  end;
end;

procedure TForm1.ButtonClick(Sender: TObject);
begin
  ShowMessage('ButtonClick');
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  AssignEventToComponent(Button1, 'OnClick', ButtonClick);
end;

Как узнать владельца метода?


procedure TForm1.Button1Click(Sender: TObject);
var
  Method: TMethod;
  P: Pointer;
begin
  Method := TMethod(Form1.OnCreate);
  P := @Method;
  P := Pointer(Integer(P) + SizeOf(Pointer));
  // Или проще (в одну строчку)
  // P := Pointer(Integer(@TMethod(Form1.OnCreate)) + SizeOf(Pointer));

  ShowMessage(TObject(P^).ClassName); // P^ = Data
end;

Как определить имя выполняемого метода?


// Определить имя метода можно при условии что метод содержится в RTTI
// (т.е для версий ниже d2010, в секции published). Например, пробежать
// по vmtMethodTable, в поисках наибольшего адреса, меньшего адреса вызова.
function CalledMethName(Obj: TObject): string;
var
  CallAddr, MethAddr, MaxAddr: Cardinal;
  pb, methEnd: PAnsiChar;
  i, Count: Integer;
begin
  CallAddr := Integer(Obj) + SizeOf(Pointer);
  MaxAddr := 0;
  CallAddr := PCardinal(CallAddr)^;
  pb := PAnsiChar(Obj.ClassType) + vmtMethodTable;
  pb := PPointer(pb)^;

  if Assigned(pb) then
  begin
    Count := PWord(pb)^;
    Inc(pb, SizeOf(Word));
    for i := 1 to Count do
    begin
      methEnd := pb + PWord(pb)^; // Len
      Inc(pb, SizeOf(Word));
      MethAddr := PCardinal(pb)^; // CodeAddress
      if (MethAddr < CallAddr) and (MethAddr > MaxAddr) then
      begin
        MaxAddr := MethAddr;
        if MaxAddr <= MethAddr then
          Result := Obj.MethodName(Pointer(MethAddr));
      end;
      pb := methEnd;
    end;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  ShowMessage(CalledMethName(Self));
end;

Как получить доступ к приватным полям?


// Способ первый
unit Unit2;

interface

type
  TTest = class
  private
    FPrivInt: Integer;
  public
    constructor Create;
  end;

implementation

{ TTest }

constructor TTest.Create;
begin
  FPrivInt := 10;
end;

end.

// =============================

uses
  Unit2, Rtti;

procedure TForm1.Button1Click(Sender: TObject);
var
  t: TTest;
  v: TValue;
begin
  t := TTest.Create;

  v := TRttiContext.Create.GetType(TTest).GetField('FPrivInt').GetValue(t);
  ShowMessage(IntToStr( v.AsInteger ));
end;

// Способ второй
unit Unit2;

interface

uses
  SysUtils, Dialogs;

type
  TBase = class(TObject)
  private
    FMemberVar: Integer;
  public
    constructor Create;
  end;

implementation

{ TBase }

constructor TBase.Create;
begin
  FMemberVar := 10;
end;

end.

// =============================

uses
  Unit2;

type
  THackBase = class(TObject)
  private
    FMemberVar: Integer;
  end;

procedure TForm1.Button1Click(Sender: TObject);
var
  obj: TBase;
  MemberVar: Integer;
begin
  obj := TBase.Create;
  ShowMessage(IntToStr(THackBase(obj).FMemberVar));
end;

Как получить доступ к приватным методам?


// Способ первый
unit Unit2;

interface

uses
  SysUtils, Dialogs;

type
  THoge = class
  private
    procedure PrivateMethod (Arg1, Arg2, Arg3 : Integer);
  end;

implementation

{ THoge }

procedure THoge.PrivateMethod(Arg1, Arg2, Arg3: Integer);
begin
  ShowMessage(IntToStr(Arg1 + Arg2 + Arg3));
end;

end.

// =============================

uses
  Unit2;

type
  THogePrivateProc = procedure (Self: THoge; Arg1, Arg2, Arg3: Integer);

  THogeHelper = class helper for THoge
    function GetMethodAddr: Pointer;
  end;

function THogeHelper.GetMethodAddr: Pointer;
asm
  {$IFDEF CPUX86}
  LEA EAX, THoge.PrivateMethod
  {$ELSE}
  LEA RAX, THoge.PrivateMethod
  {$ENDIF}
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  hoge: THoge;
  proc: THogePrivateProc;
begin
  @proc := hoge.GetMethodAddr;
  proc(hoge, 1, 2, 3);
end;

// Способ второй
unit Unit2;

interface

uses
  SysUtils, Dialogs;

type
  THoge = class
  private
    procedure PrivateMethod (Arg1, Arg2, Arg3 : Integer);
  end;

implementation

{ THoge }

procedure THoge.PrivateMethod(Arg1, Arg2, Arg3: Integer);
begin
  ShowMessage(IntToStr(Arg1 + Arg2 + Arg3));
end;

end.

// =============================

uses
  Unit2;

type
  THogePrivateMethod = procedure (Arg1, Arg2, Arg3: Integer) of object;

  THogeHelper = class helper for THoge
    function GetMethodAddr: Pointer;
  end;

function THogeHelper.GetMethodAddr: Pointer;
asm
  {$IFDEF CPUX86}
  LEA EAX, THoge.PrivateMethod
  {$ELSE}
  LEA RAX, THoge.PrivateMethod
  {$ENDIF}
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  hoge: THoge;
  method: THogePrivateMethod;
begin
  TMethod(method).Code := hoge.GetMethodAddr;
  TMethod(method).Data := hoge;
  method(1, 2, 3);
end;

Как получить список реализуемых классом интерфейсов?


procedure DumpInterfaces(AClass: TClass; sl: TStrings);
var
  i: Integer;
  InterfaceTable: PInterfaceTable;
  InterfaceEntry: PInterfaceEntry;
begin
  while Assigned(AClass) do
  begin
    InterfaceTable := AClass.GetInterfaceTable;
    if Assigned(InterfaceTable) then
    begin
      for i := 0 to InterfaceTable.EntryCount-1 do
      begin
        InterfaceEntry := @InterfaceTable.Entries[i];
        sl.Add(Format('%d. GUID = %s',
               [i, GUIDToString(InterfaceEntry.IID)]));
      end;
    end;
    AClass := AClass.ClassParent;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  sl: TStrings;
begin
  sl := TStringList.Create;
  DumpInterfaces(TComponent, sl);
  //DumpInterfaces(Form1.ClassType, sl);
  ShowMessage(sl.Text);
  sl.Free;
end;

Как получить RTTI из ссылки интерфейса?


uses
  System.Rtti;

type
  ITest1 = interface
  ['{5AB029F5-31B0-4054-A70D-75BF8278716E}']
    procedure Test1;
  end;

  ITest2 = interface
  ['{AAC18D39-465B-4706-9DC8-7B1FBCC05B2B}']
    procedure Test1;
  end;

  TTest = class(TInterfacedObject, ITest1, ITest2)
  public
    procedure Test1;
    procedure Test2;
  end;

// Это работает только в том случае, если интерфейс реализован классом и имеет GUID
function GetRttiFromInterface(AIntf: IInterface; out RttiType: TRttiType): Boolean;
var
  obj: TObject;
  IntfType: TRttiInterfaceType;
  ctx: TRttiContext;
  tmpIntf: IInterface;
begin
  Result := False;

  // Delphi 2010 и старше
  obj := AIntf as TObject;

  for IntfType in (ctx.GetType(obj.ClassType) as TRttiInstanceType).GetImplementedInterfaces do
  begin
    if obj.GetInterface(IntfType.GUID, tmpIntf) then
    begin
      if AIntf = tmpIntf then
      begin
        RttiType := IntfType;
        Result := True;
        Exit;
      end;
      tmpIntf := nil;
    end;
  end;
end;

{ TTest }

procedure TTest.Test1;
begin
end;

procedure TTest.Test2;
begin
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  Intf1: ITest1;
  Intf2: ITest2;
  RttiType: TRttiType;
begin
  Intf1 := TTest.Create as ITest1;
  Intf2 := TTest.Create as ITest2;
  if GetRttiFromInterface(Intf1, RttiType) then
    ShowMessage(RttiType.Name); // shows 'ITest1'
  if GetRttiFromInterface(Intf2, RttiType) then
    ShowMessage(RttiType.Name); // shows 'ITest2'
end;

Как получить объект по его Handle?


var
  RM_GetObjectInstance: DWORD;

function ObjectFromHWnd(Handle: HWnd): TWinControl;
var
  OwningProcess: DWORD;
  ProcessId: DWORD;
begin
  ProcessId := GetCurrentProcessId;
  if (GetWindowThreadProcessId(Handle, OwningProcess) <> 0) and
    (OwningProcess = ProcessId) then
    Result := Pointer(SendMessage(Handle, RM_GetObjectInstance, ProcessId, 0))
  else
    Result := nil;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  wc: TWinControl;
begin
  wc := ObjectFromHWnd(Handle);
end;

initialization
  RM_GetObjectInstance := RegisterWindowMessage(PChar('DelphiRM_GetObjectInstance'));

Как узнать, есть ли в списке наследования объекта определенный класс?


procedure TForm1.Button1Click(Sender: TObject);
begin
  if Button1.InheritsFrom(TButtonControl) then
    ShowMessage('Да, эта кнопка наследуется от TButtonControl');
end;

При использовании материала - ссылка на сайт обязательна