Скачать: CL | DM;

Занятно.   Найти похожие ветки 

← →
MBo ©   (2002-03-11 13:41) [0]

SwissDelphiCenter
replace controls at run-time ?
Author: Motzi

TForm1 = class(TForm)
Panel1: TPanel;
procedure FormDestroy(Sender: TObject);
procedure FormCreate(Sender: TObject);
...
TExtPanel = class(TCustomControl)
protected
procedure WMSize(var Message: TWMSize); message WM_Size;
end;
...
procedure TExtPanel.WMSize;
begin
Caption:="Size:"+IntToStr(Width)+"*"+IntToStr(Height);
Color:=clGray;
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
//Search ClassParent Pointer
while (DelphiClass.ClassParent <> OldParent) do
begin
with DelphiClass do
begin
if (ClassParent = nil) or
(ClassParent = NewParent) then Exit;
// Set DelphiClass.ClassParent
DelphiClass := ClassParent;
end
end;
// 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);
// Set write permission, swap pointers
VirtualProtect(pVCL, SizeOf(Pointer), PAGE_READWRITE, @dwProtect);
pVCL^ := pNEW;
// activate old access right
VirtualProtect(pVCL, SizeOf(Pointer), dwProtect, @dwProtect);
end
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
ReplaceParentClass(TPanel, TCustomControl, TExtPanel);
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
ReplaceParentClass(TPanel, TExtPanel, TCustomControl);
end;

---

← →
Alx2 ©   (2002-03-11 13:56) [1]

Нифига себе.

---

← →
Алексей Петров ©   (2002-03-11 14:13) [2]

Известный трюк :)
Но его неосторожное применение черевато жестокими Access Violation-ами.

---

Страницы: 1 вся ветка

Скачать: CL | DM;



Память: 0.45 MB
Время: 0.007 c