Question

I’m trying to write a simple unit containing a class TMainWindow to improve my knowledge about the native Windows API.

I’d like to use this class like this:

var
  MainWindow: TMainWindow;
begin
  MainWindow := TMainWindow.Create;
  try
    MainWindow.ShowModal;
  finally
    MainWindow.Free;
  end;
end.

I got an almost working prototype, but I can’t find the problem, here is the code I have written so far:

unit NT.Window;

interface

uses
  Windows, Messages, Classes, SysUtils;

type
  PObject = ^TObject;

  TMainWindow = class(TObject)
  private
    FChild  : HWND;                          { Optional child window }
    FHandle : HWND;
    procedure WMCreate      (var Msg: TWMCreate);      message WM_CREATE;
    procedure WMDestroy     (var Msg: TWMDestroy);     message WM_DESTROY;
    procedure WMNcCreate    (var Msg: TWMNCCreate);    message WM_NCCREATE;
    procedure WMPaint       (var Msg: TWMPaint);       message WM_PAINT;
    procedure WMPrintClient (var Msg: TWMPrintClient); message WM_PRINTCLIENT;
    procedure WMSize        (var Msg: TWMSize);        message WM_SIZE;
    procedure PaintContent(const APaintStruct: TPaintStruct);
    function HandleMessage(var Msg: TMessage): Integer;
  public
    constructor Create;
    procedure DefaultHandler(var Message); override;
    function ShowModal: Boolean;
  end;

implementation

var
  WindowByHwnd: TStringList;

function PointerToStr(APointer: Pointer): string;
begin
  Result := IntToStr(NativeInt(APointer));
end;

function StrToPointerDef(AString: string; ADefault: Pointer): Pointer;
begin
  Result := Pointer(StrToIntDef(AString, Integer(ADefault)));
end;

function GetWindowByHwnd(hwnd: HWND): TMainWindow;
begin
  Result := TMainWindow(StrToPointerDef(WindowByHwnd.Values[IntToStr(hwnd)], nil));
end;

procedure StoreWindowByHwnd(hwnd: HWND; AWindow: TMainWindow);
begin
  AWindow.FHandle := hwnd;
  WindowByHwnd.Add(IntToStr(hwnd) + '=' + PointerToStr(Pointer(AWindow)));
end;

function WndProc(hwnd: HWND; uiMsg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall;
var
  Msg    : TMessage;
  Window : TMainWindow;
begin
  Msg.Msg    := uiMsg;
  Msg.WParam := wParam;
  Msg.LParam := lParam;
  Msg.Result := 0;
  if uiMsg = WM_NCCREATE then begin
    StoreWindowByHwnd(hwnd, TMainWindow(TWMNCCreate(Msg).CreateStruct.lpCreateParams))
  end;
  Window := GetWindowByHwnd(hwnd);
  if Window = nil then begin
    Result := DefWindowProc(hwnd, Msg.Msg, Msg.WParam, Msg.LParam);
  end else begin
    Result := Window.HandleMessage(Msg);
  end;
end;

{ TMainWindow }

constructor TMainWindow.Create;
var
  wc: WNDCLASS;
begin
  inherited Create;
  wc.style         := 0;
  wc.lpfnWndProc   := @WndProc;
  wc.cbClsExtra    := 0;
  wc.cbWndExtra    := 0;
  wc.hInstance     := HInstance;
  wc.hIcon         := 0;
  wc.hCursor       := LoadCursor(0, IDC_ARROW);
  wc.hbrBackground := HBRUSH(COLOR_WINDOW + 1);
  wc.lpszMenuName  := nil;
  wc.lpszClassName := 'Scratch';
  if Windows.RegisterClass(wc) = 0 then begin
    raise Exception.Create('RegisterClass failed: ' + SysErrorMessage(GetLastError));
  end;
  if CreateWindow(
    'Scratch',                   { Class Name }
    'Scratch',                   { Title }
    WS_OVERLAPPEDWINDOW,         { Style }
    Integer(CW_USEDEFAULT),
    Integer(CW_USEDEFAULT),      { Position }
    Integer(CW_USEDEFAULT),
    Integer(CW_USEDEFAULT),      { Size }
    0,                           { Parent }
    0,                           { No menu }
    HInstance,                   { Instance }
    @Self                        { No special parameters }
  ) = 0 then begin
    raise Exception.Create('CreateWindow failed: ' + SysErrorMessage(GetLastError));
  end;
end;

procedure TMainWindow.DefaultHandler(var Message);
var
  Msg: TMessage;
begin
  Msg := TMessage(Message);
  Msg.Result := DefWindowProc(FHandle, Msg.Msg, Msg.WParam, Msg.LParam);
end;

function TMainWindow.HandleMessage(var Msg: TMessage): Integer;
begin
  // Dispatch(Msg);
  case Msg.Msg of
    WM_CREATE      : WMCreate(     TWMCreate(Msg));
    WM_DESTROY     : WMDestroy(    TWMDestroy(Msg));
    WM_NCCREATE    : WMNcCreate(   TWMNCCreate(Msg));
    WM_PAINT       : WMPaint(      TWMPaint(Msg));
    WM_PRINTCLIENT : WMPrintClient(TWMPrintClient(Msg));
    WM_SIZE        : WMSize(       TWMSize(Msg));
  else
    // DefaultHandler(Msg);
    Msg.Result := DefWindowProc(FHandle, Msg.Msg, Msg.WParam, Msg.LParam);
  end;

  Result := Msg.Result;
end;

procedure TMainWindow.PaintContent(const APaintStruct: TPaintStruct);
begin

end;

function TMainWindow.ShowModal: Boolean;
var
  msg_  : MSG;
begin
  ShowWindow(FHandle, CmdShow);
  while GetMessage(msg_, 0, 0, 0) do begin
    TranslateMessage(msg_);
    DispatchMessage(msg_);
  end;
  Result := True;
end;

procedure TMainWindow.WMCreate(var Msg: TWMCreate);
begin
  Msg.Result := 0;
end;

procedure TMainWindow.WMDestroy(var Msg: TWMDestroy);
begin
  PostQuitMessage(0);
end;

procedure TMainWindow.WMNcCreate(var Msg: TWMNCCreate);
begin
  Msg.Result := Ord(True);
end;

procedure TMainWindow.WMPaint(var Msg: TWMPaint);
var
  ps: PAINTSTRUCT;
begin
  BeginPaint(FHandle, ps);
  PaintContent(ps);
  EndPaint(FHandle, ps);
end;

procedure TMainWindow.WMPrintClient(var Msg: TWMPrintClient);
var
  ps: PAINTSTRUCT;
begin
  ps.hdc := Msg.DC;
  GetClientRect(FHandle, ps.rcPaint);
  PaintContent(ps);
end;

procedure TMainWindow.WMSize(var Msg: TWMSize);
begin
  if FChild <> 0 then begin
    MoveWindow(FChild, 0, 0, Msg.Width, Msg.Height, True);
  end;
end;

initialization
  WindowByHwnd := TStringList.Create;

finalization
  WindowByHwnd.Free;

end.

The code is partially based on the scratch program by Raymond Chen:
http://blogs.msdn.com/b/oldnewthing/archive/2003/07/23/54576.aspx

I’m using a TStringList to look up the instance of TMainWindow in the WndProc function which is pretty inefficient, but should work.

The program crashes as is and also crashes when I use Dispatch in the HandleMessage function.

Why does it crash right after leaving the constructor or in the modified version in the Dispatch call?

Answer 1

You call CreateWindow like this:

CreateWindow(
  'Scratch',                   { Class Name }
  'Scratch',                   { Title }
  WS_OVERLAPPEDWINDOW,         { Style }
  Integer(CW_USEDEFAULT),
  Integer(CW_USEDEFAULT),      { Position }
  Integer(CW_USEDEFAULT),
  Integer(CW_USEDEFAULT),      { Size }
  0,                           { Parent }
  0,                           { No menu }
  HInstance,                   { Instance }
  @Self                        { No special parameters }
)

In addition to the comment on the final parameter being wrong, the value is wrong. The expression @Self is a pointer to the local Self variable. A pointer to a local variable. That’s bound to turn out badly. You thought you were passing a pointer to the object being created, but that’s given by the value of Self directly. Remove the @.

---

There are a few more direct ways of associating an object reference with a window handle instead of converting both the handle and the reference to strings and doing name=value lookups.

• For starters, you could use a more type-safe associative container, like a TDictionary<HWnd, TMainWindow>. That at least gets you away from all the string conversions.

• You can associate the object reference directly with the window handle using SetWindowLongPtr and GetWindowLongPtr. You could modify your code as follows:

  constructor TMainWindow.Create;
    // ...
    wc.cbWndExtra := SizeOf(Self);
  
  function GetWindowByHwnd(hwnd: HWnd): TMainWindow;
  begin
    Result := TMainWindow(GetWindowLongPtr(hwnd, 0));
  end;
  
  procedure StoreWindowByHwnd(hwnd: HWND; AWindow: TMainWindow);
  begin
    AWindow.FHandle := hwnd;
    SetWindowLongPtr(hwnd, 0, IntPtr(AWindow));
  end;
  

  Since you’re use the “extra window bytes,” you need to make sure that descendants of your window class don’t try to use the same space for something else. You’d want to provide some sort of mechanism for descendants to “register” that they want space, add up all the descendants’ requests, and put the total in the cbWndExtra field. Then have a way for descendants to load and store data at the slots they reserved.

• You can use window properties. Store the object reference in a property value with SetProp in the wm_NCCreate message, and remove it with RemoveProp in the wm_NCDestroy message.

  Pick a property name unlikely to be used by descendant classes.

• Finally, you could do what the VCL does, which is to allocate a new “stub” window procedure for every object. It has a template procedure jumps to the address of the regular window procedure; it allocates memory for a new stub, fills in the template with the current object reference, and then uses that stub pointer when it calls RegisterClassEx.