Undocumented: How to change class inheritance during runtime

Problem/Question/Abstract:

Can the inheritance of a class be changed during runtime?
Yes, it can be! Here is how...

Answer:

This demo replaces the standard TPanel with a TMyPanel class. Part of this code is from the book "Delphi Win32 Losungen" written by Andreas Kosch.

This code is just a demo to show what kind of fun stuff you can do with the runtime type information (RTTI). Learn from it, play with it, have fun with it, impress your friends, etc. But: you must NEVER use this code in commercial or otherway important programs!

A good designed class hierarchy does not need runtime changes to the inheritance structure.

unit main;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, extCtrls;

type
  TClassReplaceDemo = class(TForm)
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
    FPanel: TPanel;
  public
    { Public declarations }
  end;

  TMyPanel = class(TCustomControl)
  protected
    procedure WMSize(var Message: TWMSize); message WM_Size;
  end;

var
  ClassReplaceDemo: TClassReplaceDemo;

implementation

{$R *.DFM}

procedure ReplaceParentClass(DelphiClass, OldParent, NewParent: TClass);
var
  AClassPointer: ^Byte;
  pVCl, pNew: ^Pointer;
  Protect: DWord;

begin
  // check if parameters are legal
  if Assigned(NewParent) and Assigned(DelphiClass) then
  begin
    // Find the correct parent
    while (DelphiClass.ClassParent <> OldParent) do
    begin
      with DelphiClass do
      begin
        // Is the class parent ok?
        if (ClassParent = nil) or (ClassParent = NewParent) then
          raise Exception.Create('Illegal class parent');
        // move one up in
        DelphiClass := ClassParent;
      end;
    end;

    // Get the classpointer of the delphi class
    AClassPointer := Pointer(DelphiClass);
    Inc(AClassPointer, vmtParent);
    pVCL := Pointer(AClassPointer);

    // get the classpointer of the new class
    AClassPointer := Pointer(NewParent);
    Inc(AClassPointer, vmtSelfPtr);
    pNew := Pointer(AClassPointer);

    // insert the new class
    VirtualProtect(pVCL, SizeOf(Pointer), PAGE_READWRITE, @Protect);
    try
      pVCL^ := pNEW;
    finally
      VirtualProtect(pVCL, SizeOf(Pointer), Protect, @Protect);
    end;
  end;
end;

{ TMyPanel }

procedure TMyPanel.WMSize(var Message: TWMSize);
begin
  Caption := Format('Width: %d  Height: %d', [Width, Height]);
end;

{ TForm1 }

procedure TClassReplaceDemo.Button1Click(Sender: TObject);
begin
  if FPanel = nil then
  begin
    // Create a 'normal' panel
    FPanel := TPanel.Create(Self);

    // put it on the form
    FPanel.Parent := Self;

    // define it's size
    FPanel.BoundsRect := Rect(10, 50, 150, 100);

    // You will now see the caption is automagicly set
  end;
end;

initialization
  // Replace the normal TPanel with our own TMyPanel
  ReplaceParentClass(TPanel, TCustomControl, TMyPanel);
finalization
  // cleanup the mess we made
  ReplaceParentClass(TPanel, TMyPanel, TCustomControl);
end.