[CollideE]

Есть куча примеров о там, как создать окно на WinAPI. Захотелось все это запихнуть все в один объект и не париться каждый раз с кодом, вот только с callback'ом возникли проблемы.
За код просьба сильно не пинать...

Код:

{$C +}
program Project1;

uses
  Windows, SysUtils, Messages;

const WndClassName = 'PROJECT1WCN';

type TWinCallback = function(aHandle : THandle; aMsg : Longint; awParam : WPARAM; alParam : LPARAM): Longint of object; stdcall;

type
  TxForm = class(TObject)
    private
    fHandle : THandle;
    fWndClassEx : WNDCLASSEX;
    fWinCallback : TWinCallback;
    function WinCallback(aHandle : THandle; aMsg : Longint; awParam : WPARAM; alParam : LPARAM): Longint; stdcall;
    public
    constructor Create;
    destructor Destroy; override;
    end;

{$R *.res}

{---------------------- TxForm ----------------------------}

constructor TxForm.Create;
begin
inherited Create;
fWinCallback := WinCallback;
ZeroMemory(@fWndClassEx, sizeof(fWndClassEx));
with fWndClassEx do
 begin
 cbSize := sizeof(fWndClassEx);
 lpszClassName := WndClassName;
 lpfnWndProc   := @fWinCallback;
 Style         := CS_VREDRAW or CS_HREDRAW;
 hInstance     := hInstance;
 hIcon         := LoadIcon(hInstance, IDI_APPLICATION);
 hCursor       := LoadCursor(hInstance, IDC_ARROW);
 hbrBackground := COLOR_BTNFACE + 1;
 lpszMenuName  := nil;
 cbClsExtra    := 0;
 cbWndExtra    := 0;
 end;
ASSERT(RegisterClassEx(fWndClassEx)<>0, 'RegisterClassEx');
fHandle := CreateWindowEx(WS_EX_TOPMOST,
                          WndClassName,
                          'Proj1',
                          WS_OVERLAPPED,
                          100,
                          100,
                          200,
                          200,
                          0,
                          0,
                          hInstance,
                          nil);
ASSERT(fHandle <> 0, 'CreateWindowEx');
ShowWindow(fHandle, SW_SHOW);
UpdateWindow(fHandle);
end;

destructor TxForm.Destroy;
begin
  inherited;
end;

function TxForm.WinCallback(aHandle : THandle; aMsg : Longint; awParam : WPARAM; alParam : LPARAM): Longint;
begin
Result := DefWindowProc(aHandle, aMsg, awParam, alParam);
end;

{---------------- End of TxForm ---------------------------}

//==============================================
var xForm : TxForm;
begin
xForm := TxForm.Create;
end.

Как правильно реализовать?

[lmikle]

Не уверен, что можно туда подсовывать метод объекта.
Попробуй подслвывать обычную процедуру.

[CollideE]

Нашел в сети библиотеку WinLight, реализующую необходимый функционал. Выпилил ненужные мне функции и классы, вроде все работает

Код:

program Project1;

uses
  Windows,
  Messages,
  SysUtils;

type
  TWindowParams = record
    Caption     : PChar;
    Style       : DWord;
    ExStyle     : DWord;
    X           : Integer;
    Y           : Integer;
    Width       : Integer;
    Height      : Integer;
    WndParent   : THandle;
    WndMenu     : THandle;
    Param       : Pointer;
    WindowClass : TWndClass;
  end;

type
  TxForm = class(TObject)
    private
  fWndCallback: Pointer;
  fWndHandle  : THandle;
  FWndParams  : TWindowParams;
  function WindowCallback(hWnd: HWnd; Msg, WParam, LParam:Longint):Longint; stdcall;
    protected
  procedure   CreateWindowParams(var WindowParams: TWindowParams); virtual;
    public
  constructor Create;
  destructor  Destroy; override;
  property    WndHandle: THandle read FWndHandle;
  property    WndCallback: Pointer read FWndCallback;
  end;


{ TxForm }

constructor TxForm.Create;
begin
inherited Create;
  FWndCallback := VirtualAlloc(nil,12,MEM_RESERVE or MEM_COMMIT,PAGE_EXECUTE_READWRITE);
  asm
    mov  EAX, Self
    mov  ECX, [EAX].TxForm.FWndCallback
    mov  word  ptr [ECX+0], $6858
    mov  dword ptr [ECX+2], EAX
    mov  word  ptr [ECX+6], $E950
    mov  EAX, OFFSET(TxForm.WindowCallback)
    sub  EAX, ECX
    sub  EAX, 12
    mov  dword ptr [ECX+8], EAX
  end;
  CreateWindowParams(FWndParams);
  RegisterClass(FWndParams.WindowClass);
  with FWndParams do
    CreateWindowEx(ExStyle, WindowClass.lpszClassName, Caption,
      Style, X, Y, Width, Height,
      WndParent, WndMenu, hInstance, Param
    );
end;

procedure TxForm.CreateWindowParams(var WindowParams: TWindowParams);
var
  WndClassName : string;
begin
  Str(DWord(Self), WndClassName);
  WndClassName := ClassName+'_'+WndClassName;
  with FWndParams.WindowClass do
  begin
    style         := CS_DBLCLKS;
    lpfnWndProc   := WndCallback;
    cbClsExtra    := 0;
    cbWndExtra    := 0;
    lpszClassName := PChar(WndClassName);
    hInstance     := hInstance;
    hIcon         := LoadIcon(0, IDI_APPLICATION);
    hCursor       := LoadCursor(0, IDC_ARROW);
    hbrBackground := COLOR_BTNFACE + 1;
    lpszMenuName  := '';
  end;

  with FWndParams do
  begin
    WndParent := 0;
    Caption := 'xForm';
    Style   := WS_OVERLAPPEDWINDOW or WS_VISIBLE;
    ExStyle := 0;
    X       := Integer(CW_USEDEFAULT);
    Y       := Integer(CW_USEDEFAULT);
    Width   := Integer(CW_USEDEFAULT);
    Height  := Integer(CW_USEDEFAULT);
    WndMenu := 0;
    Param   := nil;
  end;
end;

destructor TxForm.Destroy;
begin
   UnregisterClass(FWndParams.WindowClass.lpszClassName, hInstance);
    if IsWindow(FWndHandle) then DestroyWindow(FWndHandle);
    VirtualFree(FWndCallback, 0, MEM_RELEASE);
  inherited;
end;

function TxForm.WindowCallback(hWnd: HWnd; Msg, WParam,
  LParam: Integer): Longint;
var
  WindowMsg : TMessage;
begin
  if FWndHandle = 0 then FWndHandle := hWnd;
  case Msg of
  WM_CLOSE: PostQuitMessage(0);
  end;
  Result := DefWindowProc(hWnd, Msg, WParam,LParam);
end;

{$R *.res}

var xw : TxForm;
    msg : TMsg;
begin
xw := TxForm.Create;
while (getmessage(msg, 0, 0, 0)) do
 begin
 TranslateMessage(msg);
 DispatchMessage(Msg);
 end;
end.

Ссылка на оригинал