VCL 消息循环分析之改进版(可以触发WM_CREATE消息了)

program Project4;

uses
Windows,
Messages;

type
TWndMethod = procedure(var Message: TMessage) of object;
{这句类型声明的意思是：TWndMethod 是一种过程类型，它指向一个接收 TMessage 类型参数的过程，
但它不是一般的静态过程，它是对象相关(object related)的。TWndMethod 在内存中存储为一个指向
过程的指针和一个对象的指针，所以占用8个字节。TWndMethod类型的变量必须使用已实例化的对象来赋值}
TMyApplication = class(TObject)
private
FHandle: HWND;
FWndClass: TWndClass;
FObjectInstance: Pointer;
FMsg: TMsg;
procedure WndProc(var Message: TMessage);
public
constructor Create;
destructor Destroy;override;
function CreateHandle: Boolean;
procedure Show;
procedure Run;
end;

type
PMyObjectInstance = ^TMyObjectInstance;
TMyObjectInstance = packed record
CodeCall: Byte; //1个字节
Offset: Integer; //4个字节
Method: TWndMethod; //8个字节 两个指针，一个是Self指针，一个是函数指针
CodeJmp: array[1..2] of Byte; //2个字节
WndProcPtr: Pointer; //4个字节
end; //共计19个字节

{ Standard window procedure }
{因为对象方法是一个过程，而窗口回调函数是函数要有返回值，所以用它做个包装才可以}
{ In ES:BX = Address of method pointer }
{ Out DX:AX = Result }
function StdWndProc(Window: HWND; Message, WParam: Longint;
LParam: Longint): Longint; stdcall; assembler;
asm
XOR EAX,EAX
PUSH EAX
PUSH LParam
PUSH WParam
PUSH Message
MOV EDX,ESP //;将堆栈中构造的记录TMessage指针传递给EDX
MOV EAX,[ECX].Longint[4] //;传递Self指针给EAX，类中的Self指针也就是指向VMT入口地址
CALL [ECX].Pointer //;调用WndProc方法
ADD ESP,12
POP EAX
end;

function CalcJmpOffset(Src, Dest: Pointer): Longint;
begin
Result := Longint(Dest) - (Longint(Src) + 5);
end;

function MakeObjectInstance(Method: TWndMethod): Pointer;
const
BlockCode: array[1..2] of Byte = (
$59, { POP ECX } //汇编指令 POP ECX
$E9); { JMP StdWndProc } //汇编指令 JMP 长跳转指令
var
PBlock: PMyObjectInstance;
begin
PBlock := VirtualAlloc(nil, SizeOf(TMyObjectInstance), MEM_COMMIT,
PAGE_EXECUTE_READWRITE);
Move(BlockCode, PBlock^.CodeJmp, SizeOf(BlockCode));
PBlock^.WndProcPtr := Pointer(CalcJmpOffset(@PBlock^.CodeJmp[2], @StdWndProc));
PBlock^.CodeCall := $E8; //汇编指令 JMP 短跳转指令
PBlock^.Offset := CalcJmpOffset(PBlock, @PBlock^.CodeJmp);
PBlock^.Method := Method;
Result := PBlock;
end;

procedure FreeObjectInstance(ObjectInstance: Pointer);
begin
VirtualFree(ObjectInstance, 0, MEM_RELEASE);
end;

var
MyCreationControl: TMyApplication;

function InitWndProc(HWindow: HWnd; Message, WParam, LParam: Longint): Longint; stdcall;
begin
MyCreationControl.FHandle := HWindow;
//替换回调函数
SetWindowLong(HWindow, GWL_WNDPROC, LongInt(MyCreationControl.FObjectInstance));
asm //为了可以响应WM_CREATE
PUSH LParam
PUSH WParam
PUSH Message
PUSH HWindow
MOV EAX,MyCreationControl
MOV MyCreationControl,0
CALL [EAX].TMyApplication.FObjectInstance
MOV Result,EAX
end;
end;

{ TMyApplication }

constructor TMyApplication.Create;
begin
//填充数据
FWndClass.style:= CS_VREDRAW or CS_HREDRAW;
FWndClass.lpfnWndProc:= @InitWndProc;
FWndClass.cbClsExtra:= 0;
FWndClass.cbWndExtra:= 0;
FWndClass.hInstance:= HInstance;
FWndClass.hIcon:= LoadIcon(0, IDI_APPLICATION);
FWndClass.hCursor:= LoadCursor(0, IDC_ARROW);
FWndClass.hbrBackground:= GetStockObject(WHITE_BRUSH);
FWndClass.lpszMenuName:= nil;
FWndClass.lpszClassName:= 'TMyApplication';

FObjectInstance:= MakeObjectInstance(WndProc);
end;

function TMyApplication.CreateHandle: Boolean;
begin
//注册
if RegisterClass(FWndClass) = 0 then
begin
MessageBox(0, '这个错误是不应该出现的！', FWndClass.lpszClassName, MB_OK);
Result:= false;
end
else
begin
MyCreationControl:= Self;

FHandle:= CreateWindow(FWndClass.lpszClassName, '我的第一个以面向对象方式撰写的SDK程序!',
WS_OVERLAPPEDWINDOW, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT,
0, 0, HInstance, nil);

Result:= True;
end;
end;

destructor TMyApplication.Destroy;
begin
FreeObjectInstance(FObjectInstance);
inherited;
end;

procedure TMyApplication.Run;
begin
while GetMessage(FMsg, 0, 0, 0) do
begin
TranslateMessage(FMsg);
DispatchMessage(FMsg);
end;
end;

procedure TMyApplication.Show;
begin
ShowWindow(FHandle, CmdShow);
UpdateWindow(FHandle);
end;

procedure TMyApplication.WndProc(var Message: TMessage);
var
ps: PAINTSTRUCT;
dc: HDC;
begin
Message.Result:= 0;
case Message.Msg of
WM_CREATE:
begin
MessageBox(0,'触发了WM_CREATE消息！', 'Object&SDK', MB_OK);
end;
WM_DESTROY:
begin
PostQuitMessage(0);
end;
WM_PAINT:
begin
dc:= BeginPaint(FHandle, ps);
TextOut(dc, 20, 20, 'zwz_good　Project4', 18);
EndPaint(FHandle, ps);
end
else
Message.Result:= DefWindowProc(FHandle, Message.Msg, Message.wParam, Message.lParam);
end;

end;

var
MyApplication: TMyApplication;
begin
MyApplication:= TMyApplication.Create;
if MyApplication.CreateHandle then
begin
MyApplication.Show;
MyApplication.Run;
end;
MyApplication.Free;
end.