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?
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.