Изменение класса компонента во время выполнения по требованию

Мой вопрос похож на идею здесь: Замена класса компонента в delphi.
Но мне нужно изменить класс конкретных компонентов по запросу.
Вот какой-то псевдо-демо-код:

unit Unit1;

TForm1 = class(TForm)
  ImageList1: TImageList;
  ImageList2: TImageList;
private
  ImageList3: TImageList;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  ImageList3 := TImageList.Create(Self);
  // all instances of TImageList run as usual
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  Unit2.MakeSuperImageList(ImageList2);
  Unit2.MakeSuperImageList(ImageList3);
  // from now on ONLY ImageList2 and ImageList3 are TSuperImageList
  // ImageList1 is unchanged
end;

unit Unit2;

type
  TSuperImageList = class(Controls.TImageList)
  protected
    procedure DoDraw(Index: Integer; Canvas: TCanvas; X, Y: Integer;
      Style: Cardinal; Enabled: Boolean = True); override;
  end;

procedure TSuperImageList.DoDraw(Index: Integer; Canvas: TCanvas; X, Y: Integer;
  Style: Cardinal; Enabled: Boolean = True);
var
  Icon: TIcon;
begin
  Icon := TIcon.Create;
  try
    Self.GetIcon(Index, Icon);
    Canvas.Draw(X, Y, Icon);
  finally
    Icon.Free;
  end;
end;

procedure MakeSuperImageList(ImageList: TImageList);
begin
  // TImageList -> TSuperImageList
end;

Примечание.. Чтобы быть ясным, я хочу изменить некоторые экземпляры, но не все, поэтому класс интерполятора не будет.

ОТВЕТЫ

Ответ 1

Это проще, чем мысли (благодаря Блог Hallvard - Hack # 14: Изменение класса объекта во время выполнения):

procedure PatchInstanceClass(Instance: TObject; NewClass: TClass);
type
  PClass = ^TClass;
begin
  if Assigned(Instance) and Assigned(NewClass)
    and NewClass.InheritsFrom(Instance.ClassType)
    and (NewClass.InstanceSize = Instance.InstanceSize) then
  begin
    PClass(Instance)^ := NewClass;
  end;
end;

type
  TMyButton = class(TButton)
  public
    procedure Click; override;
  end;

procedure TMyButton.Click;
begin
  ShowMessage('Click!');
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  PatchInstanceClass(Button1, TMyButton);
end;

Ответ 2

Исполнительное резюме. Используйте класс интерполятора с переключением поведения во время выполнения.

Хотя @kobik использует Delphi 5 и не может делать то, что я опишу ниже, это отвечает на вопрос о поддерживаемом способе изменения VMT экземпляра с помощью TVirtualMethodInterceptor. Комментарии Мейсона вдохновили меня написать это.

procedure MakeSuperImageList(ImageList: TImageList);
var
  vmi: TVirtualMethodInterceptor;
begin
  vmi := TVirtualMethodInterceptor.Create(ImageList.ClassType);
  try
    vmi.OnBefore := procedure(Instance: TObject; Method: TRttiMethod;
      const Args: TArray<TValue>; out DoInvoke: Boolean; out Result: TValue)
    var
      Icon: TIcon;
      Canvas: TCanvas;
      Index: Integer;
      X, Y: Integer;
    begin
      if Method.Name<>'DoDraw' then
        exit;

      DoInvoke := False;//don't call TImageList.DoDraw
      Index := Args[0].AsInteger;
      Canvas := Args[1].AsType<TCanvas>;
      X := Args[2].AsInteger;
      Y := Args[3].AsInteger;

      Icon := TIcon.Create;
      try
        ImageList.GetIcon(Index, Icon);
        Canvas.Draw(X, Y, Icon);
      finally
        Icon.Free;
      end;
    end;

    vmi.Proxify(ImageList);
  finally
    vmi.Free;
  end;
end;

Я только скомпилировал это в своей голове, поэтому, без сомнения, потребуется отладка. Что-то подсказывает мне, что захват ImageList может не работать, и в этом случае вам нужно написать Instance as TImageList.

Если вы не используете решение, основанное на изменении VMT, вам придется создавать новые экземпляры (в соответствии с предложением Мейсона). Это означает, что вам также придется модифицировать все ссылки на экземпляры списка изображений одновременно с созданием новых экземпляров. На мой взгляд, это исключает любое предлагаемое решение на основе экземпляров объектов замены.

Итак, мой вывод состоит в том, что для реализации предлагаемого решения в полной общности вам потребуется модификация VMT во время выполнения. И если у вас нет современного Delphi, который обеспечивает такие возможности поддерживаемым способом, вам придется взломать VMT.

Теперь, по-моему, изменение VMT, даже с помощью перехватчиков виртуальных методов, довольно неприятно. Думаю, вы, вероятно, ошибетесь. Я предлагаю вам использовать класс интерполятора (или какой-либо другой метод подкласса) и переключать поведение во время выполнения с помощью свойства подкласса.

type
  TImageList = class(ImgList.TImageList)
  private
    FIsSuper: Boolean;
  protected
    procedure DoDraw(Index: Integer; Canvas: TCanvas; X, Y: Integer;
      Style: Cardinal; Enabled: Boolean = True); override;
  public
    property IsSuper: Boolean read FIsSuper write FIsSuper;
  end;

TImageList.DoDraw(Index: Integer; Canvas: TCanvas; X, Y: Integer;
  Style: Cardinal; Enabled: Boolean = True);
var
  Icon: TIcon;
begin
  if IsSuper then
  begin
    Icon := TIcon.Create;
    try
      Self.GetIcon(Index, Icon);
      Canvas.Draw(X, Y, Icon);
    finally
      Icon.Free;
    end;
  end
  else
    inherited;
end;
....
procedure TForm1.Button1Click(Sender: TObject);
begin
  ImageList2.IsSuper := True;
  ImageList3.IsSuper := True;
end;

Ответ 3

Нет автоматического способа сделать это, но вы можете попробовать что-то вроде этого:

procedure MakeSuperImageList(var ImageList: TImageList);
var
  new: TImageList;
begin
  if ImageList is TSuperImageList then
    Exit;
  new := TSuperImageList.Create(ImageList.Owner);
  new.Assign(ImageList);
  ImageList.Free;
  ImageList := new;
end;

В зависимости от того, как реализован Assign, он может работать не так, как ожидалось, но вы можете переопределить Assign или AssignTo в TSuperImageList, чтобы получить желаемое поведение.