{Font Preview - 1.2 Program Copyright (C) Doug Overmyer 7/8/91}
program PREVIEW;

{$S-}
{$R PREVIEW.RES}
uses WinTypes, WinProcs, WinDos, Strings, WObjects,WOPlus,WFPlus,StdDlgs;

const
  id_But1    = 201;
  id_But2    = 202;
  id_But3    = 203;
  id_But4    = 204;
  id_But5    = 205;
  id_Lb1     = 301;
  id_lb2     = 302;
  id_St1     = 401;
  id_St2     = 402;
  id_St3     = 403;
  id_St4     = 404;

{******************************************************************}
{ Types                                                            }
{******************************************************************}
type
	TPVApplication = object(TApplication)
   	procedure InitMainWindow;virtual;
	end;

PPVDlg1 = ^TPVDlg1;
TPVDlg1 = object(TDialog)
	FontSize: Integer;
	procedure WMInitDialog(var Msg:TMessage);virtual wm_First+wm_InitDialog;
   procedure IDLb1(var Msg:TMessage);virtual id_First+id_Lb1;
	end;

PPVDlg2 = ^TPVDlg2;
TPVDlg2 = object(TDialog)
	procedure WMInitDialog(var Msg:TMessage);virtual wm_First+wm_InitDialog;
	end;

type                          {convert TLogFont records to objects}
PFontItem = ^TFontItem;
TFontItem = object(TObject)
	LogFont:TLogFont;
   FontType:Integer;
   constructor Init(NewItem:TLogFont;NewType:Integer);
   destructor Done;virtual;
end;

PFontCollection = ^TFontCollection;
TFontCollection = object(TSortedCollection)
	function KeyOf(Item:Pointer):Pointer;virtual;
   function Compare(Key1,Key2:Pointer):Integer;virtual;
   function	GetCount:Integer;virtual;
end;

type                            {Child win to display sample text}
  PFontWindow = ^TFontWindow;
  TFontWindow = object(TWindow)
    FontsHeight: LongInt;
    constructor Init(AParent: PWindowsObject; ATitle: PChar);
    procedure Paint(PaintDC: HDC; var PaintInfo: TPaintStruct); virtual;
    procedure Destroy; virtual;
    procedure WMSize(var Msg: TMessage);
      virtual wm_First + wm_Size;
  end;


type                           {MainWindow of Application}
PPVWindow = ^TPVWindow;
TPVWindow = object(TWindow)
	FWin:PFontWindow;
   FBox:PListBox;
   TheIcon:HIcon;
   Bn1,Bn2,Bn3,Bn4,Bn5 :PODButton;
   Dlg1 : PPVDlg1;        {Select font size dialog}
   St1,St2,St3,St4:PStatic;
   TextString:Array[0..80] of Char;    {to display in FWin}
  	FontSelection:Integer;              {Index into Fonts collection}
   FontSize:Integer;         {Current font size desired}
   FontMetrics:TTextMetric;  {Current font metrics}
	constructor Init(AParent:PWindowsObject;ATitle:PChar);
   destructor  Done;virtual;
   procedure 	SetupWindow;virtual;
   procedure 	Paint(PaintDC:HDC;var PaintInfo:TPaintStruct);virtual;
   procedure	LoadFBox;
   procedure	WMDrawItem(var Msg:TMessage);virtual wm_First + wm_DrawItem;
   procedure 	WMSize(var Msg:TMessage);virtual wm_First+wm_Size;
   procedure 	WMSetFocus(var Msg:TMessage);virtual wm_First+wm_SetFocus;
   procedure 	IDBut1(var Msg:TMessage);virtual id_First+id_But1; {About}
	procedure 	IDBut2(var Msg:TMessage);virtual id_First+id_But2; {Size}
   procedure 	IDBut3(var Msg:TMessage);virtual id_First+id_But3; {String}
   procedure	IDBut4(var Msg:TMessage);virtual id_First+id_But4; {Text Metrics}
   procedure 	IDBut5(var Msg:TMessage);virtual id_First+id_But5; {Exit}
   procedure	IDLB2(var Msg:TMessage);virtual  id_First+id_lb2;
   procedure 	EnumerateFaces;virtual;
   function		GetFontSelection:Integer;virtual;
   function		GetFontSize:Integer;virtual;
   function		GetTextString:PChar;virtual;
   procedure	SetFontSize(NewfontSize:Integer);virtual;
end;


{********************************************************************}
{G L O B A L  V A R I A B L E S                                      }
{********************************************************************}
var
  Fonts:PFontCollection; {collection of PFontItem for call-back func}
  Sizes:PStack;    {collection of Strings for call-back func}

{********************************************************************}
{M E T H O D S                                                       }
{********************************************************************}

procedure TPVApplication.InitMainWindow;
begin
	MainWindow := New(PPVWindow,Init(nil,'Font Preview'));
end;

{********************************************************************}
{Init}
constructor TPVWindow.Init(AParent:PWindowsObject;ATitle:PChar);
begin
	TWindow.Init(AParent,ATitle);
   Attr.Menu := 0;
   Attr.X := 20; Attr.Y := 25; Attr.W := 595; Attr.H := 260;
   Bn1 := New(PODButton,Init(@Self,id_But1,'Font Size',0,0,50,50,False,'PV_Bn1'));
   Bn2 := New(PODButton,Init(@Self,id_But2,'Font Size',50,0,50,50,False,'PV_Bn2'));
   Bn3 := New(PODButton,Init(@Self,id_But3,'String',100,0,100,50,False,'PV_Bn3'));
   Bn4 := New(PODButton,Init(@Self,id_But4,'String',200,0,50,50,False,'PV_Bn4'));
   Bn5 := New(PODButton,Init(@Self,id_But5,'Exit',250,0,50,50,False,'PV_Bn5'));
   St1 := New(PStatic,Init(@Self,id_St1,'',315,5,240,18,75));
   St2 := New(PStatic,Init(@Self,id_St2,'',315,26,240,18,75));
   St3 := New(PStatic,Init(@Self,id_ST3,'',310,3,250,44,75));
   St4 := New(PStatic,Init(@Self,id_St4,'',5,55,100,18,75));
   St2^.Attr.Style := St2^.Attr.Style or ss_LeftNoWordWrap;
   St3^.Attr.Style := St3^.Attr.Style or ss_BlackFrame;
   St4^.Attr.Style := St4^.Attr.Style or ss_Left;
   FontSelection := 0;
   FontSize := 48;
   StrCopy(TextString,'');
   Fonts := New(PFontCollection,Init(100,100));
   Fonts^.Duplicates := False;
	Sizes := New(PStack,Init(10,10));
   EnumerateFaces;
   FWin := New(PFontWindow,Init(@Self,ATitle));
   with FWin^.Attr do
   	Style := Style or ws_Child or ws_HScroll or ws_VScroll or ws_Border ;
   FBox := New(PListBox,Init(@Self,id_lb2,0,0,0,0));
   with FBox^.Attr do Style := Style and not lbs_Sort or lbs_nointegralheight  ;
end;

{SetupWindow}
procedure TPVWindow.SetupWindow;
begin
	TWindow.SetupWindow;
	SetClassWord(HWindow,GCW_HIcon,LoadIcon(HInstance,'PV_Icon'));
	LoadFBox;
end;

{Paint}
procedure TPVWindow.Paint(PaintDC:HDC;var PaintInfo:TPaintStruct);
var
	ThePen:HPen;
   TheBrush :HBrush;
   OldBrush :HBrush;
   OldPen:HPen;
   OldBitMap:HBitMap;
   MemDC :HDC;
   CR:TRect;
   W,H:Integer;
   BMRec:TBitMap;
begin
	TheBrush := GetStockObject(LtGray_Brush);
	ThePen := CreatePen(ps_Solid,1,$00000000);
   OldPen := SelectObject(PaintDC,ThePen);
   OldBrush := SelectObject(PaintDC,TheBrush);
   GetClientRect(HWindow,CR);
   Rectangle(PaintDC,CR.left,CR.Top,CR.right,50);
   SelectObject(PaintDC,OldBrush);
   SelectObject(PaintDC,OldPen);
   DeleteObject(ThePen);
end;

{Route the Ownerdraw msgs to correct object}
procedure	TPVWindow.WMDrawItem(var Msg:TMessage);
var
	PDIS : ^TDrawItemStruct;
begin
	PDIS := Pointer(Msg.lParam);
   case PDIS^.CtlType of
   	odt_Button:
      	case PDIS^.CtlID of
   			id_But1 :Bn1^.DrawItem(Msg);
   			id_But2 :Bn2^.DrawItem(Msg);
   			id_But3 :Bn3^.DrawItem(Msg);
				id_But4 :Bn4^.DrawItem(Msg);
      		id_But5 :Bn5^.DrawItem(Msg);
         end;
   end;
end;


{Done}
destructor TPVWindow.Done;
begin
	Dispose(Sizes,Done);
	TWindow.Done;
end;

{WMSize}
procedure TPVWindow.WMSize(var Msg:TMessage);
begin
	SetWindowPos(FBox^.HWindow,0,-1,75,(Msg.LParamLo div 3)+1,
   	((Msg.LParamHi-75)  ),swp_NoZOrder);
	SetWindowPos(FWin^.HWindow,0,(Msg.LParamLo  div 3)-1,49,
   	(Msg.LParamLo * 2 div 3)+1,(Msg.LParamHi-48),swp_NoZOrder);
end;

{WMSetFocus}
procedure TPVWindow.WMSetFocus(var Msg:TMessage);
begin
	SetFocus(FBox^.HWindow);
end;

procedure TPVWindow.IDBut1(var Msg:TMessage);
var
	Dlg : PDialog;
begin

	Dlg :=New(PDialog,Init(@Self,'PV_About'));
	Application^.ExecDialog(Dlg);
end;

{IDBut2} {run font size dialog box}
procedure TPVWindow.IDBut2(var Msg:TMessage);
begin
	Dlg1 := new(PPVDlg1,Init(@Self,'PV_Dlg1'));
   Application^.ExecDialog(Dlg1);
   if (Dlg1^.FontSize) <> 0 then
		InvalidateRect(Fwin^.HWindow,nil,True);
end;

{IDBut3}   {run sample string dialog box}
procedure TPVWindow.IDBut3(var Msg:TMessage);
var
	TotChars:Integer;
begin
   If Application^.ExecDialog(New(PInputdialog,Init(@Self,'Font String',
   	'Enter text:',TextString,SizeOf(TextString)))) = id_OK then
	else StrCopy(TextString,'');
   InvalidateRect(FWin^.HWindow,nil,True);
end;

{IdBut4}  {GetTextMetrics}
procedure TPVWindow.IDBut4(var Msg:TMessage);
var
	Dlg : PPVDlg2;
begin
	Dlg :=New(PPVDlg2,Init(@Self,'PV_Dlg2'));
	Application^.ExecDialog(Dlg);
end;

{IdBut5}  {exit}
procedure TPVWindow.IDBut5(var Msg:TMessage);
begin
   SendMessage(HWindow,wm_Close,0,0);
end;


procedure TPVWindow.LoadFBox;
var
	Indx : Integer;
   Font : PFontItem;
   Buf1 :Array[0..20] of Char;
   Buf2 :Array[0..5] of Char;
begin
	Str(Fonts^.Getcount,Buf2);
	StrECopy(StrECopy(StrECopy(Buf1,'*'),Buf2),' Fonts*');
   St4^.SetText(Buf1);
	for indx := 0 to (Fonts^.GetCount -1) do
   	begin
		Font := Fonts^.At(indx);
   	FBox^.InsertString(Font^.LogFont.lfFaceName,-1);
      end;
end;

procedure TPVWindow.IDLB2(var Msg:TMessage);
var
	szBuffer:Array[0..80] of Char;

   indx:Integer;
begin
	case Msg.lParamHi of
   	lbn_DblClk, lbn_SelChange:
      	begin
      	indx := FBox^.GetSelIndex;
         FontSelection := Indx;
         InvalidateRect(FWin^.HWindow,nil,True);
         Exit;
         end;
   end;
end;

function EnumerateFace(var LogFont: TLogFont; TextMetric: PTextMetric;
  FontType: Integer; Data: PChar): Integer; export;
var
  OldFont: HFont;
begin
  Fonts^.Insert(New(PFontItem,Init(LogFont,FontType)));
  EnumerateFace := 1;
end;


{ Collect all of the system fonts }
procedure TPVWindow.EnumerateFaces;
var
  EnumProc: TFarProc;
  TheDC :HDC;
begin
    TheDC := GetDC(HWindow);
    EnumProc := MakeProcInstance(@EnumerateFace, HInstance);
    EnumFonts(TheDC, nil, EnumProc, nil);
    ReleaseDC(HWindow, TheDC);
end;

function TPVWindow.GetFontSelection:Integer;
begin
	GetFontSelection := FontSelection;
end;

function TPVWindow.GetFontSize:Integer;
begin
	GetFontSize := FontSize;
end;

function TPVWindow.GetTextString:PChar;
begin
	GetTextString := @TextString;
end;

procedure TPVWindow.SetFontSize(NewFontSize:Integer);
begin
	FontSize := NewFontSize;
end;

{***********************************************************************}

{ Initialize object and collect font information }
constructor TFontWindow.Init(AParent: PWindowsObject; ATitle: PChar);

begin
  TWindow.Init(AParent, ATitle);
  Attr.Style := Attr.Style or ws_VScroll or ws_HScroll or ws_Border;
  FontsHeight := 0;
  Scroller := New(PScroller, Init(@Self, 12, 12,0,0));
end;

{ Draw  font name in Window & update static text}
procedure TFontWindow.Paint(PaintDC: HDC; var PaintInfo: TPaintStruct);
var
  I: Integer;
  VPosition: Integer;
  FontItem :PFontItem;
  FontSel:Integer;
  AFont:HFont;
  OldFont:HFont;
  Extent:LongRec;
  Text:Array[0..80] of Char;
  Buf:Array[0..80] of Char;
  szFH:Array[0..4] of Char;
begin
	FontItem := Fonts^.At(PPVWindow(Parent)^.GetFontSelection);
   FontItem^.LogFont.lfHeight := PPVWindow(Parent)^.GetFontSize;
   FontsHeight := PPVWindow(Parent)^.GetFontSize;
   FontItem^.LogFont.lfWidth := 0;
   FontItem^.LogFont.lfWeight := 0;
   FontItem^.LogFont.lfQuality := Proof_Quality;
   VPosition := 5;
   if StrComp(PPVWindow(Parent)^.GetTextString,'') = 0
   	then StrCopy(Text,FontItem^.LogFont.lfFaceName)
   	else StrCopy(Text,PPVWindow(Parent)^.GetTextString);
   AFont := CreateFontIndirect(FontItem^.LogFont);
   OldFont := SelectObject(PaintDC, AFont);
	GetTextMetrics(PaintDC,PPVWindow(Parent)^.FontMetrics);
   LongInt(Extent) := GetTextExtent(PaintDC,Text,
   	StrLen(Text));
   Scroller^.SetRange(Extent.lo div 12, Extent.Hi div 12);
   TextOut(PaintDC, 10,VPosition, Text,
      StrLen(Text));
   StrCopy(Buf,'Face: ');
	PPVWindow(Parent)^.St1^.SetText(StrCat(Buf,FontItem^.LogFont.lfFaceName));
   Str(PPVWindow(Parent)^.FontMetrics.tmHeight:3,szFH);
   StrECopy(StrECopy(Buf,'Size:'),szFH);
   PPVWindow(Parent)^.St2^.SetText(Buf);
   SelectObject(PaintDC,OldFont);
   DeleteObject(AFont);
end;

procedure TFontWindow.Destroy;
begin
  TWindow.Destroy;
end;

procedure TFontWindow.WMSize(var Msg: TMessage);
begin
  TWindow.WMSize(Msg);
end;

{***********************************************************************}
constructor TFontItem.Init(NewItem:TLogFont;NewType:Integer);
begin
	LogFont := NewItem;
   FontType := NewType;
end;

destructor TFontItem.Done;
begin
end;


{***********************************************************************}
function TFontCollection.KeyOf(Item:Pointer):Pointer;
var
   Ptr :PChar;
begin
	Ptr := PFontItem(Item)^.LogFont.lfFaceName;
	KeyOf := Ptr;
end;


function TFontCollection.Compare(Key1,Key2:Pointer):Integer;
begin
	Compare := StrIComp(PChar(Key1),PChar(Key2));
end;


function TFontCollection.GetCount:Integer;
begin
	GetCount := Count;
end;

{***********************************************************************}
procedure TPVDlg1.IDLb1(var Msg:TMessage);
var
	Idx : Integer;
   Buf:Array[0..5] of Char;
   Ptr : PChar;
   ErrCode:Integer;
begin
	case Msg.lParamHi of
    lbn_SelChange,lbn_DblClk:
   	begin
      Ptr := Buf;
      Idx := SendDlgItemMsg(id_Lb1,lb_GetCurSel,0,0);
      SendDlgItemMsg(id_Lb1,lb_GetText,word(Idx),LongInt(Ptr));
       val(Ptr,FontSize,ErrCode);
      PPVWindow(Parent)^.SetFontSize(FontSize);
      EndDlg(Idx);
      Exit;
      end;
   end;
end;


function EnumerateSize(var LogFont: TLogFont; TextMetric: PTextMetric;
  FontType: Integer; Data: PChar): Integer; export;
var
	FHeight:Array[0..6] of Char;
begin
	Str(LogFont.lfHeight:3,FHeight);
	Sizes^.Push(New(PStackStr,Init(FHeight)));
	EnumerateSize := 1;
end;



procedure TPVDlg1.WMInitDialog(var Msg:TMessage);
var
	pTextItem:PChar;
   Buf:Array[0..3] of Char;
	Indx:Integer;
   DSN,ErrCode :Integer;
   EnumProc:TFarProc;
   TheDC:HDc;
   FontItem:PFontItem;
   Item:PStackStr;
begin
	TDialog.WMInitDialog(Msg);
   Sizes^.DeleteAll;
   FontItem := Fonts^.At(PPVWindow(Parent)^.GetFontSelection);

   TheDC := GetDC(HWindow);
   EnumProc := MakeProcInstance(@EnumerateSize, HInstance);
   EnumFonts(TheDC, FontItem^.LogFont.lfFaceName, EnumProc, nil);
   ReleaseDC(HWindow, TheDC);

   Indx := 12;
   pTextItem := Buf;

   if FontItem^.FontType <> 1 then
   	begin
   	Str(Indx:3,Buf);
   	while Indx < 200 do
   		begin
   		SendDlgItemMsg(id_Lb1,lb_AddString,word(0),LongInt(pTextItem));
			Indx := Indx + 12;
      	Str(Indx:3,Buf);
   		end;
   	end
   else
   	while Sizes^.Count > 0 do
      	begin
         Item := Sizes^.Pop;
  			StrCopy(Buf,Item^.StackStr);
  			Dispose(Item,Done);
   		SendDlgItemMsg(id_Lb1,lb_AddString,word(0),LongInt(pTextItem));
      	end;
end;

{***********************************************************************}

procedure TPVDlg2.WMInitDialog(var Msg:TMessage);
const
	FontFamily : Array[0..5,0..11] of Char = ('Don''t Care', '     Roman',
   				'     Swiss','    Modern', '    Script', 'Decorative');
var
	FontItem:PFontItem;
	TextItem:PChar;
   Buf:Array[0..3] of Char;
   FontMetrics:TTextMetric;

begin
	FontMetrics :=PPVWindow(Parent)^.FontMetrics;
	TDialog.WMInitDialog(Msg);
	FontItem := Fonts^.At(PPVWindow(Parent)^.GetFontSelection);
   SetDlgItemText(HWindow,601,FontItem^.LogFont.lfFaceName);

   Str(FontMetrics.tmHeight:3,Buf); SetDlgItemText(HWindow,612,Buf);
   Str(FontMetrics.tmAscent:3,Buf); SetDlgItemText(HWindow,613,Buf);
   Str(FontMetrics.tmDescent:3,Buf); SetDlgItemText(HWindow,614,Buf);
   Str(FontMetrics.tmInternalLeading:3,Buf); SetDlgItemText(HWindow,615,Buf);
   Str(FontMetrics.tmExternalLeading:3,Buf); SetDlgItemText(HWindow,616,Buf);
   Str(FontMetrics.tmAveCharWidth:3,Buf); SetDlgItemText(HWindow,617,Buf);
   Str(FontMetrics.tmMaxCharWidth:3,Buf); SetDlgItemText(HWindow,618,Buf);
   Str(FontMetrics.tmWeight:3,Buf); SetDlgItemText(HWindow,619,Buf);
   Str(FontMetrics.tmItalic:3,Buf); SetDlgItemText(HWindow,620,Buf);
   Str(FontMetrics.tmUnderlined:3,Buf); SetDlgItemText(HWindow,621,Buf);

   Str(FontMetrics.tmStruckOut:3,Buf); SetDlgItemText(HWindow,632,Buf);
   Str(FontMetrics.tmFirstChar:3,Buf); SetDlgItemText(HWindow,633,Buf);
   Str(FontMetrics.tmLastChar:3,Buf); SetDlgItemText(HWindow,634,Buf);
   Str(FontMetrics.tmDefaultChar:3,Buf); SetDlgItemText(HWindow,635,Buf);
   if FontMetrics.tmPitchandFamily and 1 > 0 then SetDlgItemText(HWindow,636,'Variable')
   	else SetDlgItemText(HWindow,636,'Fixed');
	SetDlgItemText(HWindow,637,FontFamily[FontMetrics.tmPitchAndFamily shr 4] );
   if FontMetrics.tmCharSet = ANSI_CharSet  then SetDlgItemText(HWindow,638,'Ansi')
   else if FontMetrics.tmCharSet = OEM_CharSet  then SetDlgItemText(HWindow,638,'OEM')
   else if FontMetrics.tmCharSet = Symbol_CharSet  then SetDlgItemText(HWindow,638,'Symbol')
   else if FontMetrics.tmCharSet = ShiftJis_CharSet  then SetDlgItemText(HWindow,638,'ShiftJis')
   else SetDlgItemText(HWindow,638,' ');
   Str(FontMetrics.tmOverHang:3,Buf); SetDlgItemText(HWindow,639,Buf);
   Str(FontMetrics.tmDigitizedAspectX:3,Buf); SetDlgItemText(HWindow,640,Buf);
   Str(FontMetrics.tmDigitizedAspectY:3,Buf); SetDlgItemText(HWindow,641,Buf);
end;



{*********************************************************************}
{*** M A I N L I N E                                                  }
{*********************************
***********************************}
var
	PVApp : TPVApplication;
begin
    PVApp.Init('A Font Preview');
   PVApp.Run;
    PVApp.Done;
end.