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

:: Меню ::
:: На главную ::
:: FAQ ::
:: Заметки ::
:: Практика ::
:: Win API ::
:: Проекты ::
:: Скачать ::
:: Секреты ::
:: Ссылки ::

:: Сервис ::
:: Написать ::

:: MVP ::

:: RSS ::

Яндекс.Метрика

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

// Способ первый
// Второй параметр - класс, на котором следует прервать построение списка.
// Если он навен nil, список строится вплоть до TObject.
function InheritsFromEx(AObject: TObject; AClass: TClass;
  List: TStrings): Pointer;
var
  ClassPtr: Pointer;
  P: Pointer;
begin
  Result := nil;
  List.Clear;
 
  ClassPtr := PPointer(AObject)^;
  while True do
  begin
    if Assigned(List) then
      List.Insert(0, PShortString(PPointer(NativeInt(ClassPtr) + vmtClassName)^)^);
 
    if Assigned(AClass) and (ClassPtr = Pointer(AClass)) then
      Break;
    P := PPointer(NativeInt(ClassPtr) + vmtParent)^;
    if P = nil then
      Break;
    ClassPtr := PPointer(P)^;
  end;
end;
 
procedure TForm1.Button1Click(Sender: TObject);
var
  List: TStrings;
begin
  List := TStringList.Create;
  InheritsFromEx(Form1, nil, List);
  ShowMessage(List.Text);
  List.Free;
end;

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

procedure TForm1.Button1Click(Sender: TObject);
var
  c: TRttiContext;
  t: TRttiType;
  List: TStrings;
begin
  List := TStringList.Create;
  c := TRttiContext.Create;
  try
    t := c.GetType(TForm1);
    List.Add(t.Name);
    while Assigned(t.BaseType) do
    begin
      t := t.BaseType;
      List.Insert(0, t.Name);
    end;
    ShowMessage(List.Text);
  finally
    c.Free;
    List.Free;
  end;
end;

// Способ третий
procedure TForm1.Button1Click(Sender: TObject);
var
  s: string;
  ClassRef: TClass;
begin
  s := '';
  ClassRef := Sender.ClassType;
  while ClassRef <> nil do
  begin
    s := s + ClassRef.ClassName + #13;
    ClassRef := ClassRef.ClassParent;
  end;
  ShowMessage(s);
end;


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

procedure TForm1.Button1Click(Sender: TObject);
var
  m: TMethod;
begin
  m := GetMethodProp(Sender, 'OnClick');
  ShowMessage(TObject(m.Data).MethodName(m.Code));
end;


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

uses
  System.TypInfo;

procedure CheckAllEvents(Comp: TComponent; ssEvents: TStringList);

  procedure CheckEvent(Comp: TComponent);
  var
    i: Integer;
    FList: PPropList;
    FCount: Integer;
    FSize: Integer;
    EventName: string;
  begin
    FCount := GetPropList(Comp.ClassInfo, [tkMethod], nil);
    FSize := FCount * SizeOf(Pointer);
    GetMem(FList, FSize);
    try
      GetPropList(Comp.ClassInfo, [tkMethod], FList);
      for i := 0 to FCount-1 do
        if GetMethodProp(Comp as TObject, FList^[i]).Code <> nil then
        begin
          if Comp is TCustomForm then
            EventName := FList^[i]^.Name
          else
            EventName := Comp.Name + '.' + FList^[i]^.Name;

          ssEvents.Add(EventName);
          //if (Comp.name <> '') and (ssEvents.IndexOf(EventName) = -1) then
          //   raise Exception.Create('Сначала уберите обработчики событий (' + EventName + ')');
        end;
    finally
      FreeMem(FList, FSize);
    end;
  end;

var
  i: Integer;
begin
  CheckEvent(Comp);
  if Comp is TWinControl then
    for i := 0 to (Comp as TWinControl).ControlCount-1 do
      CheckAllEvents((Comp as TWinControl).Controls[i], ssEvents);
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  sl: TStringList;
begin
  sl := TStringList.Create;
  try
    CheckAllEvents(CheckBox1, sl);
    ShowMessage(sl.Text);
  finally
    sl.Free;
  end;
end;

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