在运行时按需更改组件类

Posted 2023-02-23

【中文标题】在运行时按需更改组件类

【英文标题】：Changing component class at run-time on demand

【发布时间】：2012-04-10 06:52:50

【问题描述】：

我的问题与这里的想法相似：Replacing a component class in 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;

---

注意：为了清楚起见，我想更改一些实例，但不是全部，所以interposer class 不会这样做。

【问题讨论】：

您是否考虑过使用插入器类？

@David：这将在创建表单时更改表单上的所有实例。他想做的是改变一些个实例，但不是全部，以后再按需改变。

@DavidHeffernan，我会编辑 Q，这样会更清楚。

@kobik 我仍然认为插入器是正确的解决方案。您只需要以有区别的方式切换行为。查看我的最新更新。

只要你需要扩展（替换）的方法都是虚拟的，继承自 ImageList 的东西是不是不够好？

【参考方案1】：

这比想象的要容易（感谢Hallvard's Blog - Hack#14: Changing the class of an object at run-time）：

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;

【讨论】：

+1。看起来正是我所希望的！ Hallvard 的出色解决方案。谢谢:)

我会添加一个检查 NewClass 是否继承自它要替换的类。当然 NewClass 不应该有它的方法正在访问的任何字段，因为没有分配内存。

我只想说，在未来的某个时候，你破解 VMT 的决定会回来咬你。这可能非常狡猾和狡猾，但通常最好的解决方案是简单透明的解决方案。

@StefanGlienke 我认为问题更多在于您可能会无意中将数据成员添加到新类中，这可能会在一段时间内正常工作，但随后会以非常难以重现的方式失败。或者确实有很多其他的方式可以让这种黑客攻击你。如果没有其他好的解决方案，那么它可能有优点，但事实并非如此。

我在 PatchInstanceClass 中添加了一些检查，以防止修补不兼容的类和可能具有未分配内存的字段的类。

【参考方案2】：

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

---

虽然@kobik 使用的是Delphi 5，并且无法执行我在下面描述的操作，但这个答案充实了使用TVirtualMethodInterceptor 更改实例的VMT 的受支持方式。 Mason 的 cmets 启发了我写这篇文章。

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;

【讨论】：

@kobik 对你来说太糟糕了，但也许与其他人有关。

如果我有 XE2，我一开始就不需要这个...sigh。不过看起来很酷。无法测试它，但我确信它有效。 +1

@Mason 在这种情况下不需要取消代理。

@David，关于您上次的编辑，这是我首先想到的。考虑一下我有无数个单位的事实。他们中的许多人在运行时创建了一个TImageList。我认为修改每个可能使用TSuperImageList 的单元太机械化了。我想有一个集中的非干预方法。此外，这更有趣和有趣;）

非常时髦。 Kobik 在 D5 上是他的选择。为 Kewl Hackage +1。

【参考方案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 以获得所需的行为。

【讨论】：

“有一个更老套的方法……”把它给我宝贝！ :D

@Kobik：不，我是认真的。这不是应该放弃的东西。如果您想了解，请研究 Delphi 对象模型如何工作的低级细节。你最终会弄明白的，就像我做的那样，并了解为什么这样做是一个非常糟糕的主意，就像我做的那样。 :P

@Mason 您的代码将创建一个正确类型的新对象。但是，它也会删除原始图像列表。引用该图像列表的所有其他组件都将丢失其图像列表。您还需要修复任何参考。我担心答案中的代码无法完成工作。我已经删除了我的赞成票（至少现在是这样）。

@DavidHeffernan，实际上这不会删除原始图像列表，因为Assign 会复制图像。但最大的问题是它会删除引用该图像列表的所有其他组件，这对我来说是一个主要问题。

@kobik ImageList.Free 对我来说看起来很完美。破坏原始图像列表对象。复制图像不是重点。您的菜单、工具栏等将删除其图像列表。那是你的杀手锏。你没有说的是为什么你必须在运行时这样做。