VCL中消息分析（自大富翁）

unit MyWindowUnit;

interface

uses Windows, SysUtils, Messages;

type
  TMyCreateParams = record
    Caption: PChar;
    Style: DWORD;
    ExStyle: DWORD;
    X, Y: Integer;
    Width, Height: Integer;
    WndParent: HWnd;
    Param: Pointer;
    WindowClass: TWndClass;
    WinClassName: array[0..63] of Char;
  end;

  TMyMessage = packed record
    Msg: Cardinal;
    case Integer of
      0: (
        WParam: Longint;
        LParam: Longint;
        Result: Longint);
      1: (
        WParamLo: Word;
        WParamHi: Word;
        LParamLo: Word;
        LParamHi: Word;
        ResultLo: Word;
        ResultHi: Word);
  end;
  TMyWndMethod = procedure(var Message: TMyMessage) of object;

  TMyWindow = class
  private
    FHandle: HWnd;
    FDefWndProc: Pointer;
    FObjectInstance: Pointer;

    function GetHandle: HWnd;

  protected
    procedure CreateWindowHandle(const Params: TMyCreateParams); virtual;
    procedure CreateParams(var Params: TMyCreateParams); virtual;
    procedure CreateHandle; virtual;
    procedure CreateWnd; virtual;

    procedure WndProc(var Message: TMyMessage); virtual;
    procedure MainWndProc(var Message: TMyMessage);

  public
    procedure DefaultHandler(var Message); override;

    procedure HandleNeeded;
    procedure ShowWindow;
    procedure UpdateWindow;

    constructor Create; virtual;
    property Handle: HWnd read GetHandle;

  end;

implementation

{ TMyWindow }
type
  PMyObjectInstance = ^TMyObjectInstance;
  TMyObjectInstance = packed record
    CodeCall: Byte;
    Offset: Integer;
    Method: TMyWndMethod;
    CodeJmp: array[1..2] of Byte;
    WndProcPtr: Pointer;
  end;

function MyStdWndProc(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
  MOV     EAX,[ECX].Longint[4]
  CALL    [ECX].Pointer
  ADD     ESP,12
  POP     EAX
end;

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

function MyMakeObjectInstance(Method: TMyWndMethod): Pointer;
const
  BlockCode: array[1..2] of Byte = (
    $59,       { POP ECX }
    $E9);      { JMP MyStdWndProc }
var
  PBlock: PMyObjectInstance;
begin
  PBlock := VirtualAlloc(nil, SizeOf(TMyObjectInstance), MEM_COMMIT,
                         PAGE_EXECUTE_READWRITE);
  Move(BlockCode, PBlock^.CodeJmp, SizeOf(BlockCode));
  PBlock^.WndProcPtr := Pointer(MyCalcJmpOffset(@PBlock^.CodeJmp[2], @MyStdWndProc));
  PBlock^.CodeCall := $E8;
  PBlock^.Offset := MyCalcJmpOffset(PBlock, @PBlock^.CodeJmp);
  PBlock^.Method := Method;
  Result := PBlock;
end;

constructor TMyWindow.Create;
begin
  FObjectInstance := MyMakeObjectInstance(MainWndProc);
end;

procedure TMyWindow.CreateHandle;
begin
  if FHandle = 0 then CreateWnd;
end;

procedure TMyWindow.CreateParams(var Params: TMyCreateParams);
begin
  FillChar(Params, SizeOf(Params), 0);
  with Params do
  begin
    Style := WS_OVERLAPPEDWINDOW;
    WndParent := 0;
    WindowClass.style := CS_VREDRAW + CS_HREDRAW + CS_DBLCLKS;
    WindowClass.lpfnWndProc := @DefWindowProc;
    WindowClass.hCursor := LoadCursor(0, IDC_ARROW);
    WindowClass.hbrBackground := COLOR_3DFACE + 1;
    WindowClass.hIcon := LoadIcon(0, IDI_APPLICATION);
    WindowClass.hInstance := HInstance;
    StrPCopy(WinClassName, Self.ClassName);
  end;
end;

procedure TMyWindow.CreateWindowHandle(const Params: TMyCreateParams);
begin
  with Params do
    FHandle := CreateWindow(WinClassName, Caption, Style,
                            X, Y,
                            Width, Height,
                            WndParent, 0, WindowClass.hInstance, Param);
end;

var
  MyCreationControl: TMyWindow;

function MyInitWndProc(HWindow: HWnd; Message, WParam,
  LParam: Longint): Longint; stdcall;
begin
  MyCreationControl.FHandle := HWindow;
   SetWindowLong(HWindow, GWL_WNDPROC,
    LongInt(MyCreationControl.FObjectInstance));

  asm
        PUSH    LParam
        PUSH    WParam
        PUSH    Message
        PUSH    HWindow
        MOV     EAX,MyCreationControl
        MOV     MyCreationControl,0
        CALL    [EAX].TMyWindow.FObjectInstance
        MOV     Result,EAX
  end;
end;

procedure TMyWindow.CreateWnd;
var
  Params: TMyCreateParams;
  TempClass: TWndClass;
  ClassRegistered: Boolean;
begin
  CreateParams(Params);
  with Params do
  begin
    FDefWndProc := WindowClass.lpfnWndProc;
    ClassRegistered := GetClassInfo(WindowClass.hInstance, WinClassName, TempClass);
    if not ClassRegistered or (TempClass.lpfnWndProc <> @MyInitWndProc) then
    begin
      if ClassRegistered then Windows.UnregisterClass(WinClassName,
        WindowClass.hInstance);
      WindowClass.lpfnWndProc := @MyInitWndProc;
      WindowClass.lpszClassName := WinClassName;
      if Windows.RegisterClass(WindowClass) = 0 then RaiseLastOSError;
    end;
    MyCreationControl := Self;
    CreateWindowHandle(Params);
    if FHandle = 0 then RaiseLastOSError;
  end;
end;

procedure TMyWindow.DefaultHandler(var Message);
begin
  if FHandle <> 0 then
    with TMessage(Message) do
      Result := CallWindowProc(FDefWndProc, FHandle, Msg, WParam, LParam);
end;

function TMyWindow.GetHandle: HWnd;
begin
  HandleNeeded;
  Result := FHandle;
end;

procedure TMyWindow.HandleNeeded;
begin
  if FHandle = 0 then CreateHandle;
end;

procedure TMyWindow.MainWndProc(var Message: TMyMessage);
begin
  WndProc(Message);
end;

procedure TMyWindow.ShowWindow;
begin
  Windows.ShowWindow(FHandle, CmdShow);
end;

procedure TMyWindow.UpdateWindow;
begin
  Windows.UpdateWindow(FHandle);
end;

procedure TMyWindow.WndProc(var Message: TMyMessage);
begin
  if Message.Msg = WM_DESTROY then
    PostQuitMessage(0)
  else
    Dispatch(Message);
end;

end.

program Project1;

uses
  Windows,
  MyWindowUnit in 'MyWindowUnit.pas';

{$R *.res}

var
  MyWindow: TMyWindow;
  hWindow: HWND;
  msg: TMsg;

begin
  MyWindow := TMyWindow.Create;
  hWindow := MyWindow.Handle;
  MyWindow.ShowWindow;
  MyWindow.UpdateWindow;

  while GetMessage(msg, 0, 0, 0) do
  begin
    TranslateMessage(msg);
    DispatchMessage(msg);
  end;

  MyWindow.Free;
end.