Program Text2

uses WinTypes, WinProcs, WObjects, Strings;

type
 PDemoWin = ^TDemoWin;
 TDemoWin = object(TWindow)
  Family : byte;
  constructor Init(AParent : PWindowsObject; ATitle : PChar);
  procedure Paint(PaintDC : HDC;
	var PaintInfo : TPaintStruct); virtual;
  procedure WMLButtonDown(var Msg : TMessage);
	virtual wm_First + wm_LButtonDown;
  procedure ShowFont(PaintDC : HDC);
end;

TText2App = object(TApplication)
procedure InitMainWindow;virtual;
end;

const
 FontFamilies : array [0..3] of byte = 
  (ff_Roman, ff_Swiss, ff_Script, ff_Modern);
 NormalText : TLogFont =
 (lfHeight : 10;
 lfWidth : 0;
 lfEscapement : 0;
 lfOrientation : 0;
 lfWeight : fw_Normal;
 lfItalic : 0;
 lfUnderline : 0;
 lfStrikeOut : 0;
 lfCharSet : ANSI_CharSet;
 lfOutPrecision : Out_Default_Precis;
 lfClipPrecision : Clip_Default_Precis;
 lfQuality : Default_Quality;
 lfPitchAndFamily : Default_Pitch or ff_Script);

constructor TDemoWin.Init;
begin
 inherited Init(AParent, ATitle);
 Family := 0;
end;

procedure TDemoWin.ShowFont(PaintDC : HDC);
const
 ShowString : PChar = 'Changing Font Pascal Demo';
var
 Bounds : TRect;
 MyFont : HFont;
 LogFont : TLogFont;
 X,Y : integer;
begin
 GetClientRect(HWindow, Bounds);
 Y := 6;
 for X :=1 to 10 do
  begin
   LogFont := NormalText;
   LogFont.lfHeight := 10 + Y*2;
   LogFont.lfPitchAndFamily := DefaultPitch or FontFamilies[Family];
   MyFont := CreateFontIndirect(LogFont);
   SelectObject(PaintDC, MyFont);
   TextOut(PaintDC, X*20, Y, ShowString, StrLen(ShowString));
   Y := Y + Hiword(GetTextExtent(PaintDC, 'T', 1)) + 4;
   DeleteObject(MyFont);
 end;
end;

procedure TDemoWin.Paint;
begin
 ShowFont(PaintDC);
end;

procedure TDemoWin.WMLButtonDown;
var
 PaintDC : HDC;
 Region : HRgn;
 Bounds : TRect;
begin
 PaintDC := GetDC(HWindow);
 GetClientRect(HWindow, Bounds);
 Region := CreateRectRgnIndirect(Bounds);
 PaintRgn(PaintDC, Region);
 Family := (Family + 1) mod 4;
 ShowFont(PaintDC);
ReleaseDC(HWindow,PaintDC);
end;

procedure TText2App.InitMainWindow;
begin
 MainWindow := New(PTextWindow, Init(nil, 'Text2'));
end;

var
 Text2App: TText2App;

begin
 Text2App.Init('Text2');
 Text2App.Run;
 Text2App.Done;
end.