在运行时根据需要更改组件类

Question

我的问题类似于这里的想法：在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;

---

注意：为了清楚起见，我想更改一些实例，但不想更改所有，所以interferclass不会这样做。

Answer 1

这更容易（感谢Hallvard的博客-黑客#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;

Answer 2

执行摘要：使用具有运行时行为切换的插入器类。

---

尽管@kobik使用的是Delphi 5，不能做我下面描述的事情，但这个答案丰富了使用TVirtualMethodInterceptor更改实例的VMT的支持方法。梅森的评论启发了我写这篇文章。

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修改的解决方案，否则您将不得不创建新实例（根据Mason的建议）。这意味着，在创建新实例的同时，还必须修改对图像列表实例的所有引用。在我看来，这排除了任何基于实例化替换对象的拟议解决方案。

因此，我的结论是，要全面实现您提出的解决方案，您需要对运行时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;

Answer 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的实现方式，它可能无法正常工作，但您可以在TSuperImageList上覆盖Assign或AssignTo以获得所需的行为。