program SimpleTest3;
{$mode objfpc}{$H+}
uses
Classes, Windows, Messages, SysUtils ;
const
MyClassName = 'JustAnotherWindow';
DefFntSize=12;
type
Tsem =(dflt,dbg,key_prw);
var
{test specif. vars} i: integer;
mb_Ok: LongWord;
ic: integer;
hWindow: HWnd;
TheFont1: HFont;
TheColor: DWORD;
function WindowProc(Window: HWnd; AMessage, WParam,
LParam: Longint): Longint; stdcall; export;
var
dc : hdc;
ps : Tpaintstruct;
r : rect;
bres, speckey:boolean;
si:integer;
as2:ansistring;
sem: Tsem;
begin
WindowProc := 0; ic:=succ(ic); sem:=dbg;
case AMessage of
wm_paint:
begin
InvalidateRgn(Window,0,false);
dc:=BeginPaint(Window,ps);
case sem of
dflt:;
dbg:
begin
GetClientRect(Window,@r);
DrawText(dc,'Hello world by Free Pascal',-1,@r,
DT_SINGLELINE or DT_CENTER or DT_VCENTER);
writeln('Best wishes from FP')
end {dbg};
key_prw:;
end {case sem};
EndPaint(Window,ps);
Exit;
end;
wm_Destroy:
begin
PostQuitMessage(0);
Exit;
end;
end {case};
WindowProc := DefWindowProc(Window, AMessage, WParam, LParam);
end;
{ Register the Window Class }
function WinRegister: Boolean;
var
WindowClass: WndClass;
begin
WindowClass.Style := cs_hRedraw or cs_vRedraw;
WindowClass.lpfnWndProc := WndProc(@WindowProc);
WindowClass.cbClsExtra := 0;
WindowClass.cbWndExtra := 0;
WindowClass.hInstance := system.MainInstance;
WindowClass.hIcon := LoadIcon(0, idi_Application);
WindowClass.hCursor := LoadCursor(0, idc_Arrow);
WindowClass.hbrBackground := GetStockObject(WHITE_BRUSH);
WindowClass.lpszMenuName := pchar('');
WindowClass.lpszClassName := pchar(MyClassName);
{Result} WinRegister := RegisterClass(WindowClass) <> 0;
end;
procedure FontSize(var TLF:TLOGFONT;Height:integer; bold:boolean);
begin
with TLF do
begin
lfHeight := Height; // Default logical height of font
lfWidth := 0; // Default logical average character width
lfEscapement := 0; // angle of escapement
lfOrientation := 0; // base-line orientation angle
if bold then lfWeight:=800 else lfWeight:= FW_NORMAL; // font weight
lfItalic := 0; // italic attribute flag
lfUnderline := 0; // underline attribute flag
lfStrikeOut := 0; // strikeout attribute flag
lfCharSet := DEFAULT_CHARSET; // character set identifier
lfOutPrecision := OUT_DEFAULT_PRECIS; // output precision
lfClipPrecision := CLIP_DEFAULT_PRECIS; // clipping precision
lfQuality := DEFAULT_QUALITY; // output quality
lfPitchAndFamily := DEFAULT_PITCH; // pitch and family
Strcopy(lfFaceName,'Courier New'); // pointer to typeface name string
end;
{==}
end {FontSize};
function WinCreate: HWnd;
var
hWaux: HWnd; TheLogFont:TLogFont;
emsg:msg;
begin
hWaux := CreateWindow(
MyClassName, {Defined in WinRegister}
'aWindow', {Name of window}
ws_OverlappedWindow, {Style}
cw_UseDefault, {X}
cw_UseDefault, {Y}
cw_UseDefault, {width}
cw_UseDefault, {heighth}
0, {Parent}
0, {Menu}
system.MainInstance, {hInstance}
nil); {lpVOID}
if hWaux <> 0 then
begin
{Selectfont;} FontSize(TheLogFont,DefFntSize,false);
TheColor := GetSysColor(COLOR_WINDOWTEXT);
TheFont1 := CreateFontIndirect(TheLogFont);
SendMessage(hWaux,WM_SETFONT,TheFont1,1);
ShowWindow(hWaux, CmdShow);
UpdateWindow(hWaux);
end;
{Result} WinCreate := hWaux;
While (GetMessage(@eMsg, 0, 0, 0) <> FALSE) do
begin
TranslateMessage(@eMsg);
DispatchMessage(@eMsg);
end;
end;
Procedure DestroyWindow;
var cont: boolean;
begin
DeleteObject(TheFont1);
sendmessage(hWindow,wm_Destroy,0,0);
end {destroywindow};
begin
mb_Ok := 0;
if Winregister then
hWindow:=WinCreate;
sendmessage(hWindow,wm_paint,0,0);
DestroyWindow;
end.