Tips (1541)

Tip Bewertung (2):

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Panel1: TPanel;
  private
    { Private-Deklarationen }
  public
    { Public-Deklarationen }
  end;

  (* Neue Komponente mit eigenen Eigenschaften ersetzt erst
     zur Programmlaufzeit das Verhalten von TPanel        *)

  (* The new component replace at runtime TPanel *)

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

var
  Form1: TForm1;

implementation

{$R *.DFM}


procedure TExtPanel.WMSize;
begin
  Caption := 'Width: ' + IntToStr(Width) +
    ', Height: ' + IntToStr(Height);
end;


procedure ReplaceParentClass(DelphiClass,
  OldParent,
  NewParent: TClass);
var
  aClassPointer: ^Byte;
  pVCL, pNew: ^Pointer;
  dwProtect: DWORD;
begin
  if Assigned(NewParent) then
    if Assigned(DelphiClass) then
    begin
      // ClassParent-Zeiger suchen
      //Search ClassParent Pointer
      while (DelphiClass.ClassParent <> OldParent) do
      begin
        with DelphiClass do
        begin
          if (ClassParent = nil) or
            (ClassParent = NewParent) then Exit;
          // DelphiClass.ClassParent zuweisen
          // Set DelphiClass.ClassParent
          DelphiClass := ClassParent;
        end
      end;
      // Parent-Zeiger der originalen VCL-Klasse suchen
      // Search Parent-Pointer of original VCL-Class
      aClassPointer := Pointer(DelphiClass);
      Inc(aClassPointer, vmtParent);
      pVCL          := Pointer(aClassPointer);
      aClassPointer := Pointer(NewParent);
      Inc(aClassPointer, vmtSelfPtr);
      pNew := Pointer(aClassPointer);
      // Schreibberechtigung holen, Zeigerwerte tauschen
      // Set write permission, swap pointers
      VirtualProtect(pVCL, SizeOf(Pointer), PAGE_READWRITE, @dwProtect);
      pVCL^ := pNEW;
      // alte Zugriffsrechte aktivieren
      // avtivate old access right
      VirtualProtect(pVCL, SizeOf(Pointer), dwProtect, @dwProtect);
    end
  end;



initialization
  ReplaceParentClass(TPanel, TCustomControl, TExtPanel);

finalization
  ReplaceParentClass(TPanel, TExtPanel, TCustomControl);
end.