{Preview - 1.0 Program Copyright (C) Doug Overmyer 7/1/91}
program FList;

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

const
  id_But1    = 201;
  id_But2    = 202;
  id_But3    = 203;
  id_But4    = 204;
  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;

PPVDialog = ^TPVDialog;
TPVDialog = 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;

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

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

var
  Fonts:PFontCollection; {Global collection of PFontItem to for call-back func}

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;
   TheButton,TheLogo:HBitmap;{button = About button}
   Bn1,Bn2,Bn3,Bn4 : PButton;
   Dlg1 : PPVDialog;        {Select font size dialog}
   St1,St2,St3,St4:PStatic;
   TextString:Array[0..50] of Char;    {to display in FWin}
  	FontSelection:Integer;              {Index into Fonts collection}
   FontSize:Integer;         {Current font size desired}
	constructor Init(AParent:PWindowsObject;ATitle:PChar);
   destructor  Done;virtual;
   procedure 	SetupWindow;virtual;
   procedure 	Paint(PaintDC:HDC;var PaintInfo:TPaintStruct);virtual;
   procedure	LoadFBox;
   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; {Drive}
	procedure 	IDBut2(var Msg:TMessage);virtual id_First+id_But2; {Clipboard}
   procedure 	IDBut3(var Msg:TMessage);virtual id_First+id_But3; {not used}
   procedure 	IDBut4(var Msg:TMessage);virtual id_First+id_But4; {Exit}
   procedure	IDLB2(var Msg:TMessage);virtual  id_First+id_lb2;
   procedure 	WMLButtonUp(var Msg:TMessage);virtual wm_First+wm_LButtonUp;
   procedure 	EnumerateFonts;virtual;
   function		GetFontSelection:Integer;virtual;
   function		GetFontSize:Integer;virtual;
   function		GetTextString:PChar;virtual;
   procedure	SetFontSize(NewfontSize:Integer);virtual;
end;


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

procedure TPVApplication.InitMainWindow;
begin
	MainWindow := New(PPVWindow,Init(nil,'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 := 325;
   Fonts := New(PFontCollection,Init(100,100));
   Fonts^.Duplicates := True;
  	EnumerateFonts;
   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
   	begin
   	Style := Style and not lbs_Sort  ;
      end;
   Bn1 := New(PButton,Init(@Self,id_But1,'Font Size',0,0,0,0,False));
   Bn2 := New(PButton,Init(@Self,id_But2,'String',0,0,0,0,False));
   Bn3 := New(PButton,Init(@Self,id_But3,'File',0,0,0,0,False));
   Bn4 := New(PButton,Init(@Self,id_But4,'Exit',0,0,0,0,False));
   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));
   TheButton := LoadBitmap(HInstance,'PV_BUTTON');
   TheLogo   := LoadBitmap(HInstance,'PV_BMP');
   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,'');
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);
   Rectangle(PaintDC,0,0,1024,50);
   SelectObject(PaintDC,OldBrush);
   SelectObject(PaintDC,OldPen);
   DeleteObject(ThePen);
   MemDC := CreateCompatibleDC(PaintDC);
   OldBitMap := SelectObject(MemDC,TheButton);
   BitBlt(PaintDC,0,0,50,50,MemDC,0,0,SrcCopy);
   SelectObject(MemDC,OldBitMap);
   DeleteDC(MemDC);

   GetObject(TheLogo,sizeOf(BMRec),@BMRec);;
   GetClientRect(HWindow,CR);
   W := CR.Right-CR.Left;H := CR.Bottom-CR.Top;
   MemDC := CreateCompatibleDC(PaintDC);
   OldBitMap := SelectObject(MemDC,TheLogo);
   BitBlt(PaintDC,((W div 3) - BMRec.bmWidth) div 2,
   	50+ ((H -50) div 2)+ abs((((H -50) div 2)-BMRec.bmHeight)div 2) ,
   	W div 3,H div 2,
      MemDC,0,0,SrcCopy);
   SelectObject(MemDC,OldBitMap);
   DeleteDC(MemDC);
end;

{Done}
destructor TPVWindow.Done;
begin
	DeleteObject(TheButton);
   DeleteObject(TheLogo);
	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) div 2 - 0),swp_NoZOrder);
	SetWindowPos(FWin^.HWindow,0,(Msg.LParamLo  div 3)-1,49,
   	(Msg.LParamLo * 2 div 3)+1,(Msg.LParamHi-48),swp_NoZOrder);
   SetWindowPos(Bn1^.HWindow,0,50,0,100,50,swp_NoZOrder);
   SetWindowPos(Bn2^.HWindow,0,150,0,100,50,swp_NoZOrder);
  {SetWindowPos(Bn3^.HWindow,0,200,0,50,50,swp_NoZOrder);}
   SetWindowPos(Bn4^.HWindow,0,250,0,50,50,swp_NoZOrder);
end;

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

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

{IDBut2}   {run sample string dialog box}
procedure TPVWindow.IDBut2(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,'');
end;

{IdBut3}{not used}
procedure TPVWindow.IDBut3(var Msg:TMessage);
begin

end;

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

{WMLButtonDown} {hit test for bitmapped button}
procedure TPVWindow.WMLButtonUp(var Msg:TMessage);
var
	Dlg : PDialog;
begin
	if (Msg.lParamLo < 50) and (Msg.lParamHi < 50) then
   	begin
      Dlg :=New(PDialog,Init(@Self,'PV_About'));
      Application^.ExecDialog(Dlg);
      end;
end;

procedure TPVWindow.LoadFBox;
var
	Indx : Integer;
   Font : PFontItem;
   Buf1 :Array[0..20] of Char;
   Buf2 :Array[0..5] of Char;
begin
	Str(Fonts^.Count,Buf2);
	StrECopy(StrECopy(StrECopy(Buf1,'*'),Buf2),' Fonts*');
   St4^.SetText(Buf1);
	for indx := 0 to (Fonts^.Count -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 EnumerateFont(var LogFont: TLogFont; TextMetric: PTextMetric;
  FontType: Integer; Data: PChar): Integer; export;
var
  OldFont: HFont;
begin
  Fonts^.Insert(New(PFontItem,Init(LogFont)));
  EnumerateFont := 1;
end;


{ Collect all of the system fonts }
procedure TPVWindow.EnumerateFonts;
var
  EnumProc: TFarProc;
  TheDC :HDC;

begin
    TheDC := GetDC(HWindow);
    EnumProc := MakeProcInstance(@EnumerateFont, 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);
var
  I: Integer;

function Max(I, J: LongInt): LongInt;
begin
  if I > J then Max := I else Max := J;
end;

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 each font name in it's font in the Display context.  Each
  line is incremented by the height of the font }
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);
   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(FontsHeight:3,szFH);
   StrCat(StrCopy(Buf,'Size: '),szFH);
   PPVWindow(Parent)^.St2^.SetText(Buf);
   SelectObject(PaintDC,OldFont);
   DeleteObject(AFont);
end;

procedure TFontWindow.Destroy;
var
  I: Integer;
begin
  TWindow.Destroy;
end;

procedure TFontWindow.WMSize(var Msg: TMessage);
begin
  TWindow.WMSize(Msg);
{  if Scroller <> nil then
    Scroller^.SetRange(FontsWidth div 12,
      FontsHeight div 12);   }
end;

{***********************************************************************}
constructor TFontItem.Init(NewItem:TLogFont);
begin
	LogFont := NewItem;
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;

{***********************************************************************}
procedure TPVDialog.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;

procedure TPVDialog.WMInitDialog(var Msg:TMessage);
var
	TextItem:PChar;
   Buf:Array[0..3] of Char;
	Indx:Integer;
   DSN,ErrCode :Integer;
begin
	TDialog.WMInitDialog(Msg);
   DosError := 0;
   {$I-}
   Indx := 12;
   TextItem := Buf;
   Str(Indx:2,Buf);
   while Indx < 200 do
   begin
   	SendDlgItemMsg(id_Lb1,lb_InsertString,word(-1),LongInt(TextItem));
		Indx := Indx + 12;
      Str(Indx:2,Buf);
   end;
end;


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

end.