Hello.
I was bored and just put up together a class for creating a window using Windows API. Notice that the window procedure is a member of the class.
STILL WIP
Code:
unit UWindow;
interface
uses
Windows, Messages;
type
{ .: TWindow :. }
TWindow = class sealed(TObject)
private
{ Private declarations }
FWidth: Cardinal;
FHeight: Cardinal;
WndProcPtr: Pointer;
WndHandle: HWND;
h_Instance: HINST;
function WndProc(hWnd: HWND; Msg: UINT; wParam: WPARAM;
lParam: LPARAM): LRESULT; stdcall;
function WinMain(hInstance: HINST; hPrevInstance: HINST;
lpCmdLine: PChar; nCmdShow: Integer): Integer; stdcall;
function CreateWnd(): Boolean;
function FreeWnd(): Boolean;
procedure SetWndParams(const Index: Integer; const Value: Cardinal);
public
{ Public declarations }
constructor Create();
destructor Destroy(); override;
function Run(): Integer;
property Width: Cardinal index 0 read FWidth write SetWndParams;
property Height: Cardinal index 1 read FHeight write SetWndParams;
end;
implementation
type
{ .: TMethodToProc :. }
TMethodToProc = packed record
popEax: Byte;
pushSelf: record
opcode: Byte;
Self: Pointer;
end;
pushEax: Byte;
jump: record
opcode: Byte;
modRm: Byte;
pTarget: ^Pointer;
target: Pointer;
end;
end;
{ .: MethodToProcedure :. }
function MethodToProcedure(self: TObject; methodAddr: Pointer): Pointer;
var
mtp: ^TMethodToProc absolute Result;
begin
New(mtp);
with mtp^ do
begin
popEax := $58;
pushSelf.opcode := $68;
pushSelf.Self := Self;
pushEax := $50;
jump.opcode := $FF;
jump.modRm := $25;
jump.pTarget := @jump.target;
jump.target := methodAddr;
end;
end;
{ TWindow }
constructor TWindow.Create;
begin
inherited Create();
WndProcPtr := MethodToProcedure(Self, @TWindow.WndProc);
h_Instance := GetModuleHandle(nil);
FWidth := 800;
FHeight := 600;
end;
function TWindow.CreateWnd: Boolean;
var
WndClass: TWndClass;
dwStyle, dwExStyle: DWORD;
begin
Result := False;
ZeroMemory(@WndClass, SizeOf(WndClass));
FreeWnd();
with WndClass do
begin
style := CS_HREDRAW or CS_VREDRAW or CS_OWNDC;
lpfnWndProc := WndProcPtr;
hInstance := h_Instance;
hCursor := LoadCursor(0, IDC_ARROW);
lpszClassName := 'BrainerWindow';
end;
if (Windows.RegisterClass(WndClass) = 0) then
exit;
dwStyle := WS_OVERLAPPEDWINDOW or WS_CLIPCHILDREN or WS_CLIPSIBLINGS;
dwExStyle := WS_EX_APPWINDOW or WS_EX_WINDOWEDGE;
WndHandle := CreateWindowEx(dwExStyle, 'BrainerWindow', '', dwStyle, 0, 0,
FWidth, FHeight, 0, 0, h_Instance, nil);
if (WndHandle = 0) then
exit;
ShowWindow(WndHandle, SW_SHOW);
SetForegroundWindow(WndHandle);
SetFocus(WndHandle);
Result := True;
end;
destructor TWindow.Destroy;
begin
Dispose(WndProcPtr);
inherited;
end;
function TWindow.FreeWnd: Boolean;
begin
Result := False;
if ((WndHandle <> 0) and (not DestroyWindow(WndHandle))) then
begin
WndHandle := 0;
exit;
end;
if (not Windows.UnregisterClass('BrainerWindow', h_Instance)) then
begin
h_Instance := 0;
exit;
end;
Result := True;
end;
function TWindow.Run: Integer;
begin
Result := -1;
if (not CreateWnd()) then
exit;
Result := WinMain(h_Instance, hPrevInst, CmdLine, CmdShow);
end;
procedure TWindow.SetWndParams(const Index: Integer; const Value: Cardinal);
var
Changed: Boolean;
begin
Changed := False;
case Index of
0: Changed := (FWidth <> Value);
1: Changed := (FHeight <> Value);
end;
if (Changed) then
SetWindowPos(WndHandle, 0, 0, 0, FWidth, FHeight, SWP_NOREDRAW);
end;
function TWindow.WinMain(hInstance, hPrevInstance: HINST; lpCmdLine: PChar;
nCmdShow: Integer): Integer;
var
IsDone: Boolean;
Msg: TMsg;
begin
IsDone := False;
while (not IsDone) do
if (PeekMessage(msg, 0, 0, 0, PM_REMOVE)) then
begin
if (msg.message = WM_QUIT) then
IsDone := True
else
begin
TranslateMessage(msg);
DispatchMessage(msg);
end;
end;
FreeWnd();
Result := Msg.wParam;
end;
function TWindow.WndProc(hWnd: HWND; Msg: UINT; wParam: WPARAM;
lParam: LPARAM): LRESULT;
begin
case (Msg) of
WM_CLOSE:
begin
PostQuitMessage(0);
Result := 0;
end;
WM_SIZE:
begin
FWidth := LoWord(lParam);
FHeight := HiWord(lParam);
Result := 0;
end;
else
Result := DefWindowProc(hWnd, Msg, WParam, LParam);
end;
end;
end.
Bookmarks