[FreePascal] Fenstercallback in einer Klasse

[Mithrandir]

Und so gehts:

Delphi-Quellcode:

{$mode objfpc}
{$ASMMODE intel}

interface

uses
  Windows;
Type
  { TstMainWindow }

  TstMainWindow = class
    private
      {* Window Class *}
      fwc : TWndClass;
      {* Flags *}
      fWndExFlags,
      fWndFlags: DWORD;
      fWnd: HWND;
      fwndClassName: String;
      fAppName: String;
      {* Pointer to the main window callback *}
      fMainWindowProc: Pointer;
      {* Public: Height and Width *}
      fWindowHeight,
      fWindowWidth: LongInt;
      {* OS Version *}
      fOSVersion : TOSVERSIONINFO;
      {* Helpers *}
      function MakeProcInstance(M: TMethod): Pointer;
      procedure FreeProcInstance(ProcInstance: Pointer);

      function FWndProc(wnd: HWND; uMsg: UINT; wp: WPARAM; lp: LPARAM): LResult; stdcall;
    public
      property OSVersion : TOSVERSIONINFO read fOSVersion write fOSVersion;
      property wndClassName : String read fwndClassName write fwndClassName;
      property AppName : String read fAppName write fAppName;
      property WindowHeight : LongInt read fWindowHeight write fWindowHeight;
      property WindowWidth : LongInt read fWindowWidth write fWindowWidth;

      procedure CreateWindow;

      Constructor Create;
      Destructor Destroy; override;
  end;

implementation

{ TstMainWindow }

function TstMainWindow.MakeProcInstance(M: TMethod): Pointer;
begin
  // Speicher alloziieren fü 15 Byte an Code
  //GetMem(Result, 15);
  VirtualAlloc(nil, $15, MEM_COMMIT, PAGE_EXECUTE_READWRITE);
  asm
    // MOV ECX,
    MOV BYTE PTR [EAX], $B9
    MOV ECX, M.Data
    MOV DWORD PTR [EAX+$1], ECX
    // POP EDX (bisherige Rücksprungadresse nach edx)
    MOV BYTE PTR [EAX+$5], $5A
    // PUSH ECX (self als Parameter 0 anfügen)
    MOV BYTE PTR [EAX+$6], $51
    // PUSH EDX (Rücksprungadresse zurück auf den Stack)
    MOV BYTE PTR [EAX+$7], $52
    // MOV ECX, (Adresse nach ecx laden)
    MOV BYTE PTR [EAX+$8], $B9
    MOV ECX, M.Code
    MOV DWORD PTR [EAX+$9], ECX
    // JMP ECX (Sprung an den ersten abgelegten Befehl und Methode aufrufen)
    MOV BYTE PTR [EAX+$D], $FF
    MOV BYTE PTR [EAX+$E], $E1
    // hier kein Call, ansonsten würde noch eine Rücksprungadresse auf den Stack gelegt
  end;
end;

procedure TstMainWindow.FreeProcInstance(ProcInstance: Pointer);
begin
  // free memory
  VirtualFree(ProcInstance, 0, MEM_RELEASE);
  //FreeMem(ProcInstance, 15);
end;

function TstMainWindow.FWndProc(wnd: HWND; uMsg: UINT; wp: WPARAM; lp: LPARAM
  ): LResult; stdcall;
begin
  FWndProc := 0;
  case uMsg of
    WM_DESTROY: PostQuitMessage(0);
    else FWndProc := DefWindowProc(wnd,uMsg,wp,lp);
  end;
end;

procedure TstMainWindow.CreateWindow;
begin
  (* You use a version below XP? Sorry, wont work... *)
  if (fOSVersion.dwMajorVersion < 5) or (fOSVersion.dwMajorVersion = 5) and (fOSVersion.dwMinorVersion = 0) then
  begin
    exit;
  end;

  {* Set the Window Flags *}
  fWndFlags   :=  WS_POPUP or WS_THICKFRAME;
  {...}
  fWndExFlags := 0;

  (* Init WndClass struct *)
  ZeroMemory(@fwc, sizeof(TWndClass));
  With fwc do
  begin
    Style         := CS_HREDRAW or CS_VREDRAW;
    lpfnWndProc   := WNDPROC(fMainWindowProc);
    cbClsExtra    := 0;
    cbWndExtra    := 0;
    hInstance     := system.MainInstance;
    lpszMenuName  := nil;
    lpszClassName := @fwndClassName[0];
    hIcon         := LoadIcon(hInstance, MAKEINTRESOURCE(1));
    hCursor       := LoadCursor(0, IDC_ARROW);
    hbrBackground := GetSysColorBrush(COLOR_3DFACE);
  end;

  (* Register Window class *)
  if(RegisterClass(fwc) = 0) then exit;

  (* Create Window Class, but dont set size *)
  fWnd := CreateWindowEx(fWndExFlags, @fwndClassname[0], @fAppName[0],
    fWndFlags, integer(CW_USEDEFAULT), integer(CW_USEDEFAULT),
    fWindowWidth, fWindowHeight, 0, 0 , system.MainInstance, nil);

  UpdateWindow(fwnd);
  SetForegroundWindow(fwnd);
  ShowWindow(fwnd, SW_SHOW);
end;

destructor TstMainWindow.Destroy;
begin
  FreeProcInstance(fMainWindowProc);
  inherited Destroy;
end;

constructor TstMainWindow.Create;
var
  Method: TMethod;
begin
  Method.Code := @TstMainWindow.FWndProc;
  Method.Data := Self;
  fMainWindowProc := MakeProcInstance(Method);
end;

end.