WinAPI window class

[Brainer]

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


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.

[arthurprs]

Clever, generating a function on the fly :)

[Ñuño Martínez]

Nice. I remember I did something like this in C++ for Windows 3.11 a long time ago.

I think it should raise some exceptions (and define its own Exception class) instead of just "exit". I hope I can remember this post when I start the Allegro.pas 4.5 version because I'll need it for sure.

[JSoftware]

What's wrong with the good old SetWindowLong with GWL_USERDATA trick? I realize that you save one function, but in the reliability section it certainly takes a hit :P

Nice hack though

[Brainer]

What's wrong with the good old SetWindowLong with GWL_USERDATA trick?
Nothing - I just wanted it done like that. :) The purpose was to show that there are different ways of doing the same thing. Of course, the above is a rough sketch, still waiting for improvements. I just wanted to show you a concept you could possibly use to build your own class.

[chronozphere]

LOL, that's quite clever indeed. I know this problem. WndProc can be hard to use when you're writing OOP code. This is the hakish solution. :D Nice one.

[Brainer]

29th of December, 2010
* OpenGL 3.x context initialization added
* Added events to react to the execution flow
The code contains classes from my engine, but I think it's easy to replace them with your code or even completely get rid of them.


unit UOpenGL3xWindow;

interface

uses
Windows, Messages, Classes,
UGlobal, dglOpenGL;

type
{ .: TResizeEvent :. }
TResizeEvent = procedure(const NewX, NewY: Cardinal) of object;

{ .: TOpenGL3xWindow :. }
TOpenGL3xWindow = class sealed(TDaguObject)
private
{ Private declarations }
FWidth: Cardinal;
FHeight: Cardinal;
FCaption: String;
FFullScreen: Boolean;
FX: Cardinal;
FY: Cardinal;
FOnResize: TResizeEvent;
FOnMove: TResizeEvent;
FOnDestroy: TEvent;
FOnCreate: TEvent;
FOnIdle: TEvent;

procedure SetWndParams(const Index: Integer; const Value: Cardinal);
procedure SetCaption(const Value: String);
private
{ Private declarations }
WndProcPtr: Pointer;
WndHandle: HWND;
h_Instance: HINST;
DC: HDC;
RC: HGLRC;
IsMinimized: Boolean;
IsOGLInit: Boolean;

function CreateWnd(): Boolean;
function FreeWnd(): Boolean;
function WndProc(hWnd: HWND; Msg: UINT; wParam: WPARAM;
lParam: LPARAM): LRESULT; stdcall;
function MainFunction(): Integer;
public
{ Public declarations }
constructor Create(const AFullScreen: Boolean = False);
destructor Destroy(); override;

procedure CenterWindow();
procedure VerticalSync(const Activate: Boolean);

function Run(): Integer;

procedure Assign(const Source: TDaguObject); override;
procedure SaveToStream(const S: TStream); override;
procedure LoadFromStream(const S: TStream); override;

property Width: Cardinal index 0 read FWidth write SetWndParams;
property Height: Cardinal index 1 read FHeight write SetWndParams;
property X: Cardinal index 2 read FX write SetWndParams;
property Y: Cardinal index 3 read FY write SetWndParams;
property Caption: String read FCaption write SetCaption;
property FullScreen: Boolean read FFullScreen;

property OpenGLInitialized: Boolean read IsOGLInit;

property OnCreate: TEvent read FOnCreate write FOnCreate;
property OnDestroy: TEvent read FOnDestroy write FOnDestroy;
property OnResize: TResizeEvent read FOnResize write FOnResize;
property OnMove: TResizeEvent read FOnMove write FOnMove;
property OnIdle: TEvent read FOnIdle write FOnIdle;
end;

implementation

uses
SysUtils;

{ TOpenGL3xWindow }

procedure TOpenGL3xWindow.Assign(const Source: TDaguObject);
var
S: TOpenGL3xWindow;
begin
inherited Assign(Source);

if ((Assigned(Source)) and (Source is TOpenGL3xWindow)) then
begin
S := TOpenGL3xWindow(Source as TOpenGL3xWindow);

Self.SetWndParams(0, S.Width);
Self.SetWndParams(1, S.Height);
Self.SetWndParams(2, S.X);
Self.SetWndParams(3, S.Y);
FCaption := S.Caption;
FFullScreen := S.FullScreen;
IsOGLInit := S.OpenGLInitialized;
WndHandle := S.WndHandle;
WndProcPtr := S.WndProcPtr;
DC := S.DC;
RC := S.RC;
h_Instance := S.h_Instance;

FOnResize := S.OnResize;
FOnMove := S.OnMove;
FOnCreate := S.OnCreate;
FOnDestroy := S.OnDestroy;
FOnIdle := S.OnIdle;
end;
end;

procedure TOpenGL3xWindow.CenterWindow;
var
ScreenWidth, ScreenHeight: Cardinal;
begin
ScreenWidth := GetSystemMetrics(SM_CXSCREEN);
ScreenHeight := GetSystemMetrics(SM_CYSCREEN);

SetWndParams(2, (ScreenWidth - FWidth) div 2);
SetWndParams(3, (ScreenHeight - FHeight) div 2);
end;

constructor TOpenGL3xWindow.Create(const AFullScreen: Boolean);
begin
inherited Create();

WndProcPtr := MethodToProcedure(Self, @TOpenGL3xWindow.WndProc);
h_Instance := GetModuleHandle(nil);
FWidth := 800;
FHeight := 600;
CenterWindow();
WndHandle := 0;
FCaption := BrainEngineString;
FFullScreen := AFullScreen;
RC := 0;
DC := 0;

IsMinimized := False;
IsOGLInit := False;
FOnResize := nil;
FOnMove := nil;
FOnCreate := nil;
FOnDestroy := nil;
FOnIdle := nil;
end;

function TOpenGL3xWindow.CreateWnd: Boolean;
var
WndClass: TWndClass;
dwStyle, dwExStyle: DWORD;
dmScreenSettings: DEVMODE;
PixelFormat: Cardinal;
PFD: TPIXELFORMATDESCRIPTOR;
TempRC: HGLRC;
OGLAttr: array[0..6] of Cardinal;
begin
Result := False;

{$IFDEF DEBUG}
Log(SystemInformation());
{$ENDIF}

if (not InitOpenGL()) then
begin
{$IFDEF DEBUG}
ThrowAndLog('Unable to initialize OpenGL');
{$ELSE IFDEF RELEASE}
ThrowException('Unable to initialize OpenGL');
{$ENDIF}
exit;
end;

ZeroMemory(@WndClass, SizeOf(WndClass));
FreeWnd();

// Window class creation
with WndClass do
begin
style := CS_HREDRAW or CS_VREDRAW or CS_OWNDC;
lpfnWndProc := WndProcPtr;
hInstance := h_Instance;
hCursor := LoadCursor(0, IDC_ARROW);
lpszClassName := 'BrainEngineWnd';
end;

if (Windows.RegisterClass(WndClass) = 0) then
exit;

// Fullscreen setup
if (FFullScreen) then
begin
ZeroMemory(@dmScreenSettings, SizeOf(dmScreenSettings));
with dmScreenSettings do
begin
dmSize := SizeOf(dmScreenSettings);
dmPelsWidth := FWidth;
dmPelsHeight := FHeight;
dmBitsPerPel := 32;
dmFields := DM_PELSWIDTH or DM_PELSHEIGHT or DM_BITSPERPEL;
end;

if (ChangeDisplaySettings(dmScreenSettings,
CDS_FULLSCREEN) = DISP_CHANGE_FAILED) then
begin
FFullScreen := False;
{$IFDEF DEBUG}
ThrowAndLog('Unable to switch to fullscreen');
{$ELSE IFDEF RELEASE}
ThrowException('Unable to switch to fullscreen');
{$ENDIF}
end;
end;

// Window properties setup
if (FFullScreen) then
begin
dwStyle := WS_POPUP or WS_CLIPCHILDREN or WS_CLIPSIBLINGS;
dwExStyle := WS_EX_APPWINDOW;
FX := 0;
FY := 0;
end else
begin
dwStyle := WS_OVERLAPPEDWINDOW or WS_CLIPCHILDREN or WS_CLIPSIBLINGS;
dwExStyle := WS_EX_APPWINDOW or WS_EX_WINDOWEDGE;
end;

// Window handle creation
WndHandle := CreateWindowEx(dwExStyle, 'BrainEngineWnd', PChar(FCaption),
dwStyle, FX, FY, FWidth, FHeight, 0, 0, h_Instance, nil);

if (WndHandle = 0) then
exit;

// Getting a DC
DC := GetDC(WndHandle);
if (DC = 0) then
begin
{$IFDEF DEBUG}
ThrowAndLog('Unable to get a device context');
{$ELSE IFDEF RELEASE}
ThrowException('Unable to get a device context');
{$ENDIF}
exit;
end;

// Setting the pixel format
with PFD do
begin
nSize := SizeOf(TPIXELFORMATDESCRIPTOR);
nVersion := 1;
dwFlags := PFD_DRAW_TO_WINDOW or PFD_SUPPORT_OPENGL or PFD_DOUBLEBUFFER;
iPixelType := PFD_TYPE_RGBA;
cColorBits := 32;
cRedBits := 0;
cRedShift := 0;
cGreenBits := 0;
cGreenShift := 0;
cBlueBits := 0;
cBlueShift := 0;
cAlphaBits := 0;
cAlphaShift := 0;
cAccumBits := 0;
cAccumRedBits := 0;
cAccumGreenBits := 0;
cAccumBlueBits := 0;
cAccumAlphaBits := 0;
cDepthBits := 32;
cStencilBits := 0;
cAuxBuffers := 0;
iLayerType := PFD_MAIN_PLANE;
bReserved := 0;
dwLayerMask := 0;
dwVisibleMask := 0;
dwDamageMask := 0;
end;

PixelFormat := ChoosePixelFormat(DC, @PFD);
if (PixelFormat = 0) then
begin
{$IFDEF DEBUG}
ThrowAndLog('Unable to find a suitable pixel format');
{$ELSE IFDEF RELEASE}
ThrowException('Unable to find a suitable pixel format');
{$ENDIF}
exit;
end;

if (not SetPixelFormat(DC, PixelFormat, @PFD)) then
begin
{$IFDEF DEBUG}
ThrowAndLog('Unable to set the pixel format');
{$ELSE IFDEF RELEASE}
ThrowException('Unable to set the pixel format');
{$ENDIF}
exit;
end;

// Creating a temporary RC
TempRC := wglCreateContext(DC);
if (TempRC = 0) then
begin
{$IFDEF DEBUG}
ThrowAndLog('Unable to create a temporary RC');
{$ELSE IFDEF RELEASE}
ThrowException('Unable to create a temporary RC');
{$ENDIF}
exit;
end;

if (not wglMakeCurrent(DC, TempRC)) then
begin
{$IFDEF DEBUG}
ThrowAndLog('Unable to activate the temporary RC');
{$ELSE IFDEF RELEASE}
ThrowException('Unable to activate the temporary RC');
{$ENDIF}
exit;
end;

// Known to throw AVs, that's why they're put in a try-except
try
ReadExtensions();
ReadImplementationProperties();
except
{$IFDEF DEBUG}
ThrowAndLog('Unable to read implementation properties of OpenGL');
{$ELSE IFDEF RELEASE}
ThrowException('Unable to read implementation properties of OpenGL');
{$ENDIF}
exit;
end;

if (not dglCheckExtension('WGL_ARB_create_context')) then
begin
{$IFDEF DEBUG}
ThrowAndLog('OpenGL 3.x not present');
{$ELSE IFDEF RELEASE}
ThrowException('OpenGL 3.x not present');
{$ENDIF}
exit;
end;

OGLAttr[0] := WGL_CONTEXT_MAJOR_VERSION_ARB;
OGLAttr[1] := OPENGL_MAJOR_VERSION;
OGLAttr[2] := WGL_CONTEXT_MINOR_VERSION_ARB;
OGLAttr[3] := OPENGL_MINOR_VERSION;
OGLAttr[4] := WGL_CONTEXT_FLAGS_ARB;
OGLAttr[5] := WGL_CONTEXT_FORWARD_COMPATIBLE_BIT_ARB;
OGLAttr[6] := 0;
RC := wglCreateContextAttribsARB(DC, 0, @OGLAttr);

if (RC = 0) then
begin
{$IFDEF DEBUG}
ThrowAndLog('Unable to initialize OpenGL 3.2 context');
{$ELSE IFDEF RELEASE}
ThrowException('Unable to initialize OpenGL 3.2 context');
{$ENDIF}
exit;
end;

wglMakeCurrent(0, 0);
wglDeleteContext(TempRC);

if (not wglMakeCurrent(DC, RC)) then
begin
{$IFDEF DEBUG}
ThrowAndLog('Unable to activate OpenGL 3.2 context');
{$ELSE IFDEF RELEASE}
ThrowException('Unable to activate OpenGL 3.2 context');
{$ENDIF}
exit;
end else
IsOGLInit := True;

ShowWindow(WndHandle, SW_SHOW);
SetForegroundWindow(WndHandle);
SetFocus(WndHandle);
if (FFullScreen) then
ShowCursor(False);

{$IFDEF DEBUG}
Log('Graphic card vendor: ' + glGetString(GL_VENDOR));
Log('Graphic card: ' + glGetString(GL_RENDERER));
Log('OpenGL version used: ' + glGetString(GL_VERSION));
Log('OpenGL context initialization successful.');
{$ENDIF}

if Assigned(FOnResize) then
FOnResize(FWidth, FHeight);
if Assigned(FOnMove) then
FOnMove(FX, FY);

// "And all is well, that ends ok"
Result := True;
end;

destructor TOpenGL3xWindow.Destroy;
begin
Dispose(WndProcPtr);

inherited Destroy();
end;

function TOpenGL3xWindow.FreeWnd: Boolean;
begin
Result := False;

if ((WndHandle <> 0) and (not DestroyWindow(WndHandle))) then
begin
WndHandle := 0;
exit;
end;

if (not Windows.UnregisterClass('BrainEngineWnd', h_Instance)) then
begin
h_Instance := 0;
exit;
end;

Result := True;
end;

procedure TOpenGL3xWindow.LoadFromStream(const S: TStream);
begin
inherited LoadFromStream(S);

if (Assigned(S)) then
begin
FWidth := S.ReadCardinal();
FHeight := S.ReadCardinal();
FCaption := S.ReadString();
FFullScreen := S.ReadBoolean();
FX := S.ReadCardinal();
FY := S.ReadCardinal();
end;
end;

function TOpenGL3xWindow.MainFunction: 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 else
begin
if (not IsMinimized) then
if Assigned(FOnIdle) then
FOnIdle();

SwapBuffers(DC);
end;
FreeWnd();
if Assigned(FOnDestroy) then
FOnDestroy();

Result := Msg.wParam;
end;

function TOpenGL3xWindow.Run: Integer;
begin
Result := -1;

if (not CreateWnd()) then
begin
{$IFDEF DEBUG}
ThrowAndLog('Unable to create window');
{$ELSE IFDEF RELEASE}
Self.ThrowException('Unable to create window');
{$ENDIF}
exit;
end else
begin
if Assigned(FOnCreate) then
FOnCreate();
{$IFDEF DEBUG}
Log('Window created');
{$ENDIF}
end;

Result := MainFunction();
end;

procedure TOpenGL3xWindow.SaveToStream(const S: TStream);
begin
inherited SaveToStream(S);

if (Assigned(S)) then
begin
S.WriteCardinal(FWidth);
S.WriteCardinal(FHeight);
S.WriteString(FCaption);
S.WriteBoolean(FFullScreen);
S.WriteCardinal(FX);
S.WriteCardinal(FY);
end;
end;

procedure TOpenGL3xWindow.SetCaption(const Value: String);
begin
if (Value <> FCaption) then
begin
FCaption := Value;
if (WndHandle <> 0) then
SetWindowText(WndHandle, PChar(FCaption));
end;
end;

procedure TOpenGL3xWindow.SetWndParams(const Index: Integer;
const Value: Cardinal);
var
Changed: Boolean;
begin
Changed := False;
case Index of
0: begin
Changed := (FWidth <> Value);
if (Changed) then
FWidth := Value;
end;
1: begin
Changed := (FHeight <> Value);
if (Changed) then
FHeight := Value;
end;
2: begin
Changed := (FX <> Value);
if (Changed) then
FX := Value;
end;
3: begin
Changed := (FY <> Value);
if (Changed) then
FY := Value;
end;
end;

if ((Changed) and (WndHandle <> 0)) then
begin
SetWindowPos(WndHandle, 0, FX, FY, FWidth, FHeight, SWP_NOREDRAW);
if Assigned(FOnResize) then
FOnResize(FWidth, FHeight);
if Assigned(FOnMove) then
FOnMove(FX, FY);
end;
end;

procedure TOpenGL3xWindow.VerticalSync(const Activate: Boolean);
begin
if (not IsOGLInit) then
exit;

if dglCheckExtension('WGL_EXT_swap_control') then
begin
wglSwapIntervalEXT(Integer(Activate));
{$IFDEF DEBUG}
Log('VSync -> ' + BoolToStr(Activate, True));
{$ENDIF}
end else
{$IFDEF DEBUG}
Log('WGL_EXT_swap_control not present');
{$ENDIF}
end;

function TOpenGL3xWindow.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);
if Assigned(FOnResize) then
FOnResize(FWidth, FHeight);

IsMinimized := (wParam = SIZE_MINIMIZED);
Result := 0;
end;
WM_MOVE:
begin
FX := LoWord(lParam);
FY := HiWord(lParam);
if Assigned(FOnMove) then
FOnMove(FX, FY);
Result := 0;
end
else
Result := DefWindowProc(hWnd, Msg, WParam, LParam);
end;
end;

end.