home *** CD-ROM | disk | FTP | other *** search
/ Windows Shareware GOLD / NuclearComputingVol3No1.cdr / _bbs2 / f1499.zip / PREVIEW.PAS < prev    next >
Pascal/Delphi Source File  |  1991-07-29  |  30KB  |  956 lines
  1.  
  2. {Font Preview - 1.3 Program Copyright (C) Doug Overmyer 7/26/91}
  3. program FList;
  4.  
  5. {$S-}
  6. {$R PREVIEW.RES}
  7. {$R-}
  8. uses WinTypes, WinProcs, WinDos, Strings, WObjects,WOPlus,WFPlus,StdDlgs,
  9.                     printer,pDevice;
  10.  
  11. const
  12.   id_OKPrt   = 521;        {OK button in Dlg3}
  13.   id_Ec1         = 506;     {Edit control element in Dlg3}
  14.   id_But1    = 201;     {User defined button 1}
  15.   id_But2    = 202;     {      "             2}
  16.   id_But3    = 203;     {      "             3}
  17.   id_But4    = 204;     {      "             3}
  18.   id_But5    = 205;     {      "             5}
  19.   id_Lb1     = 301;     {List box control in Dlg1}
  20.   id_lb2     = 302;     {id of FBox list box control}
  21.   id_Setup   = 501;     {Setup button in  Dlg3}
  22.   id_St1     = 401;     {Static text 1        }
  23.   id_St2     = 402;     {Static text 2        }
  24.   id_St3     = 403;     {Static text 3        }
  25.   id_St4     = 404;     {Static text 4        }
  26.   idm_About  = 801;     {menu id for PV_About menu}
  27.   idm_RunCP  = 802;     {menu id for run control panel}
  28.   um_FilePrint = 802;   {User defined message }
  29.  
  30. {******************************************************************}
  31. { Types                                                            }
  32. {******************************************************************}
  33. type
  34.     TPVApplication = object(TApplication)
  35.        procedure InitMainWindow;virtual;
  36.     end;
  37.  
  38. PPVDlg1 = ^TPVDlg1;                     {Font Sizes Dialog}
  39. TPVDlg1 = object(TDialog)
  40.     FontSize: Integer;
  41.     procedure WMInitDialog(var Msg:TMessage);virtual wm_First+wm_InitDialog;
  42.    procedure IDLb1(var Msg:TMessage);virtual id_First+id_Lb1;
  43.     end;
  44.  
  45. PPVDlg2 = ^TPVDlg2;                     {String Dialog}
  46. TPVDlg2 = object(TDialog)
  47.     DCType:Char;
  48.     procedure WMInitDialog(var Msg:TMessage);virtual wm_First+wm_InitDialog;
  49.     end;
  50.  
  51. PPVDlg3 = ^TPVDlg3;
  52. TPVDlg3 = object(TDialog)              {Print setup dialog}
  53.     PFontSize: Integer;
  54.     procedure WMInitDialog(var Msg:TMessage);virtual wm_First+wm_InitDialog;
  55.    procedure IDSetup(var Msg:TMessage);virtual id_First+id_Setup;
  56.    procedure IDOKPrt(var Msg:TMessage);virtual id_First+id_OKPrt;
  57.    procedure IDEc1(var Msg:TMessage);virtual id_First+id_Ec1;
  58.     end;
  59.  
  60.  
  61. type                          {convert TLogFont records to objects}
  62. PFontItem = ^TFontItem;
  63. TFontItem = object(TObject)
  64.     LogFont:TLogFont;
  65.    FontType:Integer;
  66.    constructor Init(NewItem:TLogFont;NewType:Integer);
  67.    destructor Done;virtual;
  68. end;
  69.  
  70. PFontCollection = ^TFontCollection;   {Collection of printer TLOGFont recs}
  71. TFontCollection = object(TSortedCollection)
  72.     function KeyOf(Item:Pointer):Pointer;virtual;
  73.    function Compare(Key1,Key2:Pointer):Integer;virtual;
  74.    function    GetCount:Integer;virtual;
  75. end;
  76.  
  77. type                            {Child win to display sample text}
  78.   PFontWindow = ^TFontWindow;
  79.   TFontWindow = object(TWindow)
  80.     FontsHeight: LongInt;
  81.     constructor Init(AParent: PWindowsObject; ATitle: PChar);
  82.     procedure Paint(PaintDC: HDC; var PaintInfo: TPaintStruct); virtual;
  83.     procedure Destroy; virtual;
  84.     procedure WMSize(var Msg: TMessage);
  85.       virtual wm_First + wm_Size;
  86.   end;
  87.  
  88. type                               {Printer object support for margins,fonts}
  89. PPVPrinter = ^TPVPrinter;
  90. TPVPrinter = object(tPrinter)
  91.     MarginL:Integer; {left horiz margin value in Pixels}
  92.    MarginT:Integer; {top vert margin value in Pixels}
  93.    MarginR:Integer; {right horiz margin value in Pixels}
  94.    MarginB:Integer; {bottom vert margin value in Pixels}
  95.    function Start(dName:pChar;hw:HWnd):Boolean;virtual;
  96.    procedure SetMarginL(NewMargin:Integer);virtual;
  97.    procedure SetMarginT(NewMargin:Integer);virtual;
  98.    procedure SetMarginR(NewMargin:Integer);virtual;
  99.    procedure SetMarginB(NewMargin:Integer);virtual;
  100.     function SetFont(NewFont:hFont):hFont;virtual;
  101.    function NewLine:Boolean; virtual;
  102.    function resetPos:Boolean;virtual;
  103.    function CheckNewPage:Boolean; virtual;
  104.    function Print(aStr:pChar):Boolean;virtual;
  105.     function     prnDeviceMode(Wnd:HWnd):Integer;virtual;
  106. end;
  107.  
  108. type                           {MainWindow of Application}
  109. PPVWindow = ^TPVWindow;
  110. TPVWindow = object(TWindow)
  111.     FWin:PFontWindow;     {child window displaying typeface sample}
  112.    FBox:PListBox;        {List box of available type faces}
  113.    TheIcon:HIcon;
  114.    Bn1,Bn2,Bn3,Bn4,Bn5 :PODButton;
  115.    Dlg1 : PPVDlg1;        {Select font size dialog}
  116.    St1,St2,St3,St4:PStatic;
  117.    TextString:Array[0..80] of Char;    {to display in FWin}
  118.       FontSelection:Integer;              {Index into Faces collection}
  119.    FontSize:Integer;         {Current font size desired for FWin}
  120.    PFontSize:Integer;        {Current font size for printed text}
  121.    LogPixX,LogPixY:Integer; {LogPixelsX & Y for current Printer}
  122.     constructor Init(AParent:PWindowsObject;ATitle:PChar);
  123.    destructor  Done;virtual;
  124.    procedure     SetupWindow;virtual;
  125.    procedure     Paint(PaintDC:HDC;var PaintInfo:TPaintStruct);virtual;
  126.    procedure    LoadFBox;
  127.    procedure    WMDrawItem(var Msg:TMessage);virtual wm_First + wm_DrawItem;
  128.    procedure     WMSize(var Msg:TMessage);virtual wm_First+wm_Size;
  129.    procedure     WMSetFocus(var Msg:TMessage);virtual wm_First+wm_SetFocus;
  130.    procedure     IDBut1(var Msg:TMessage);virtual id_First+id_But1; {About}
  131.     procedure     IDBut2(var Msg:TMessage);virtual id_First+id_But2; {Size}
  132.    procedure     IDBut3(var Msg:TMessage);virtual id_First+id_But3; {String}
  133.    procedure    IDBut4(var Msg:TMessage);virtual id_First+id_But4; {Text Metrics}
  134.    procedure     IDBut5(var Msg:TMessage);virtual id_First+id_But5; {Exit}
  135.    procedure    IDLB2(var Msg:TMessage);virtual  id_First+id_lb2;
  136.    procedure     EnumerateFaces;virtual;
  137.    procedure    EnumerateSizes;virtual;
  138.    function        GetFontSelection:Integer;virtual;
  139.    function        GetFontSize:Integer;virtual;
  140.    function        GetTextString:PChar;virtual;
  141.    function        GetLogPixX:Integer;virtual;
  142.    function        GetLogPixY:Integer;virtual;
  143.    procedure    SetFontSize(NewfontSize:Integer);virtual;
  144.    procedure    SetPFontSize(NewfontSize:Integer);virtual;
  145.    procedure    UMFilePrint(var Msg:TMessage);virtual wm_User+um_FilePrint;
  146.    procedure    WMSysCommand(var Msg:TMessage);virtual wm_First+wm_SysCommand;
  147. end;
  148.  
  149.  
  150. {********************************************************************}
  151. {G L O B A L  V A R I A B L E S                                      }
  152. {********************************************************************}
  153. var
  154.   Faces:PFontCollection; {collection of PFontItem for call-back func}
  155.   Sizes:PCollection;    {collection of stacks for call-back func}
  156.  
  157. {********************************************************************}
  158. {M E T H O D S                                                       }
  159. {********************************************************************}
  160.  
  161. procedure TPVApplication.InitMainWindow;
  162. begin
  163.     MainWindow := New(PPVWindow,Init(nil,'Font Preview'));
  164. end;
  165.  
  166. {********************************************************************}
  167. {Init}
  168. constructor TPVWindow.Init(AParent:PWindowsObject;ATitle:PChar);
  169. begin
  170.     TWindow.Init(AParent,ATitle);
  171.    Attr.Menu := 0; {LoadMenu(HInstance,'PV_Menu');}
  172.    Attr.X := 20; Attr.Y := 25; Attr.W := 595; Attr.H := 260;
  173.    Bn1 := New(PODButton,Init(@Self,id_But1,'Font Size',0,0,50,50,False,'PV_Bn1'));
  174.    Bn2 := New(PODButton,Init(@Self,id_But2,'Font Size',50,0,50,50,False,'PV_Bn2'));
  175.    Bn3 := New(PODButton,Init(@Self,id_But3,'String',100,0,100,50,False,'PV_Bn3'));
  176.    Bn4 := New(PODButton,Init(@Self,id_But4,'String',200,0,50,50,False,'PV_Bn4'));
  177.    Bn5 := New(PODButton,Init(@Self,id_But5,'Exit',250,0,50,50,False,'PV_Bn5'));
  178.    St1 := New(PStatic,Init(@Self,id_St1,'',315,5,240,18,75));
  179.    St2 := New(PStatic,Init(@Self,id_St2,'',315,26,240,18,75));
  180.    St3 := New(PStatic,Init(@Self,id_ST3,'',310,3,250,44,75));
  181.    St4 := New(PStatic,Init(@Self,id_St4,'',5,55,140,18,75));
  182.    St2^.Attr.Style := St2^.Attr.Style or ss_LeftNoWordWrap;
  183.    St3^.Attr.Style := St3^.Attr.Style or ss_BlackFrame;
  184.    St4^.Attr.Style := St4^.Attr.Style or ss_Left;
  185.    LogPixY := 1;
  186.    FontSelection := 0;
  187.    FontSize := 48;
  188.    PFontsize := 14;
  189.    StrCopy(TextString,'');
  190.    Faces := New(PFontCollection,Init(100,100));
  191.    Faces^.Duplicates := False;
  192.     Sizes := New(PCollection,Init(10,10));
  193.    EnumerateFaces;
  194.    EnumerateSizes;
  195.    FWin := New(PFontWindow,Init(@Self,ATitle));
  196.    with FWin^.Attr do
  197.        Style := Style or ws_Child or ws_HScroll or ws_VScroll or ws_Border ;
  198.    FBox := New(PListBox,Init(@Self,id_lb2,0,0,0,0));
  199.    with FBox^.Attr do
  200.         begin
  201.         Style := Style and not lbs_Sort  ;
  202.         end;
  203. end;
  204.  
  205. {SetupWindow}
  206. procedure TPVWindow.SetupWindow;
  207. var
  208.     SysMenu:hMenu;
  209. begin
  210.     TWindow.SetupWindow;
  211.     SetClassWord(HWindow,GCW_HIcon,LoadIcon(HInstance,'PV_Icon'));
  212.    Sysmenu := GetSystemMenu(hWindow,false);
  213.    AppendMenu(SysMenu,MF_Separator,0,nil);
  214.    AppendMenu(SysMenu,0,idm_RunCP,'Run Control Panel');
  215.    AppendMenu(Sysmenu,0,idm_About,'About...');
  216.     LoadFBox;
  217. end;
  218.  
  219. {Paint}
  220. procedure TPVWindow.Paint(PaintDC:HDC;var PaintInfo:TPaintStruct);
  221. var
  222.     ThePen:HPen;
  223.    TheBrush :HBrush;
  224.    OldBrush :HBrush;
  225.    OldPen:HPen;
  226. begin
  227.     TheBrush := GetStockObject(LtGray_Brush);
  228.     ThePen := CreatePen(ps_Solid,1,$00000000);
  229.    OldPen := SelectObject(PaintDC,ThePen);
  230.    OldBrush := SelectObject(PaintDC,TheBrush);
  231.    Rectangle(PaintDC,0,0,1024,50);
  232.    SelectObject(PaintDC,OldBrush);
  233.    SelectObject(PaintDC,OldPen);
  234.    DeleteObject(ThePen);
  235. end;
  236.  
  237. {Route the Ownerdraw msgs to correct object}
  238. procedure    TPVWindow.WMDrawItem(var Msg:TMessage);
  239. var
  240.     PDIS : ^TDrawItemStruct;
  241. begin
  242.     PDIS := Pointer(Msg.lParam);
  243.    case PDIS^.CtlType of
  244.        odt_Button:
  245.           case PDIS^.CtlID of
  246.                id_But1 :Bn1^.DrawItem(Msg);
  247.                id_But2 :Bn2^.DrawItem(Msg);
  248.                id_But3 :Bn3^.DrawItem(Msg);
  249.                 id_But4 :Bn4^.DrawItem(Msg);
  250.               id_But5 :Bn5^.DrawItem(Msg);
  251.          end;
  252.    end;
  253. end;
  254.  
  255.  
  256. {Done}
  257. destructor TPVWindow.Done;
  258. begin
  259.     Dispose(Sizes,Done);
  260.     TWindow.Done;
  261. end;
  262.  
  263. {WMSize}
  264. procedure TPVWindow.WMSize(var Msg:TMessage);
  265. begin
  266.     SetWindowPos(FBox^.HWindow,0,-1,75,(Msg.LParamLo div 3)+1,
  267.        ((Msg.LParamHi-70)  ),swp_NoZOrder);
  268.     SetWindowPos(FWin^.HWindow,0,(Msg.LParamLo  div 3)-1,49,
  269.        (Msg.LParamLo * 2 div 3)+1,(Msg.LParamHi-48),swp_NoZOrder);
  270. end;
  271.  
  272. {WMSetFocus}
  273. procedure TPVWindow.WMSetFocus(var Msg:TMessage);
  274. begin
  275.     SetFocus(FBox^.HWindow);
  276. end;
  277.  
  278. procedure TPVWindow.IDBut1(var Msg:TMessage);
  279. var
  280.     Dlg : PDialog;
  281. begin
  282.     Dlg :=New(PPVDlg3,Init(@Self,'PV_Dlg3'));
  283.     Application^.ExecDialog(Dlg);
  284. end;
  285.  
  286. {IDBut2} {run font size dialog box}
  287. procedure TPVWindow.IDBut2(var Msg:TMessage);
  288. begin
  289.     Dlg1 := new(PPVDlg1,Init(@Self,'PV_Dlg1'));
  290.    Application^.ExecDialog(Dlg1);
  291.    if (Dlg1^.FontSize) <> 0 then
  292.         InvalidateRect(Fwin^.HWindow,nil,True);
  293. end;
  294.  
  295. {IDBut3}   {run sample string dialog box}
  296. procedure TPVWindow.IDBut3(var Msg:TMessage);
  297. var
  298.     TotChars:Integer;
  299. begin
  300.    If Application^.ExecDialog(New(PInputdialog,Init(@Self,'Font String',
  301.        'Enter text:',TextString,SizeOf(TextString)))) = 1 then
  302.     else StrCopy(TextString,'');
  303.    InvalidateRect(FWin^.HWindow,nil,True);
  304. end;
  305.  
  306. {IdBut4}  {GetTextMetrics}
  307. procedure TPVWindow.IDBut4(var Msg:TMessage);
  308. var
  309.     Dlg : PPVDlg2;
  310. begin
  311.     Dlg :=New(PPVDlg2,Init(@Self,'PV_Dlg2'));
  312.    Dlg^.DCType := 'S';
  313.     Application^.ExecDialog(Dlg);
  314.     Dlg :=New(PPVDlg2,Init(@Self,'PV_Dlg2'));
  315.    Dlg^.DCType := 'P';
  316.     Application^.ExecDialog(Dlg);
  317. end;
  318.  
  319. {IdBut5}  {exit}
  320. procedure TPVWindow.IDBut5(var Msg:TMessage);
  321. begin
  322.    SendMessage(HWindow,wm_Close,0,0);
  323. end;
  324.  
  325.  
  326. procedure TPVWindow.LoadFBox;
  327. var
  328.     Indx : Integer;
  329.    Font : PFontItem;
  330.    Buf1 :Array[0..20] of Char;
  331.    Buf2 :Array[0..5] of Char;
  332. begin
  333.     Str(Faces^.Getcount,Buf2);
  334.     StrECopy(StrECopy(StrECopy(Buf1,'*'),Buf2),' Type Faces*');
  335.    St4^.SetText(Buf1);
  336.     for indx := 0 to (Faces^.GetCount -1) do
  337.        begin
  338.         Font := Faces^.At(indx);
  339.        FBox^.InsertString(Font^.LogFont.lfFaceName,-1);
  340.       end;
  341. end;
  342.  
  343. procedure TPVWindow.IDLB2(var Msg:TMessage);
  344. var
  345.     szBuffer:Array[0..80] of Char;
  346.    indx:Integer;
  347. begin
  348.     case Msg.lParamHi of
  349.        lbn_DblClk, lbn_SelChange:
  350.           begin
  351.           indx := FBox^.GetSelIndex;
  352.          FontSelection := Indx;
  353.          InvalidateRect(FWin^.HWindow,nil,True);
  354.          Exit;
  355.          end;
  356.    end;
  357. end;
  358.  
  359. function EnumerateFace(var LogFont: TLogFont; TextMetric: PTextMetric;
  360.       FontType: Integer; Data: PChar): Integer; export;
  361.  function DupF(Item:PFontItem):Boolean;far;
  362.       begin
  363.        DupF := (StrIComp(Item^.LogFont.lfFaceName, LogFont.lfFacename)= 0);
  364.    end;
  365. var
  366.   OldFont: HFont;
  367.   Result:PFontItem;
  368. begin
  369.    Result := Faces^.FirstThat(@DupF);
  370.    if Result = nil then Faces^.Insert(New(PFontItem,Init(LogFont,FontType)));
  371.       EnumerateFace := 1;
  372. end;
  373.  
  374.  
  375. function EnumerateSize(var LogFont: TLogFont; TextMetric: PTextMetric;
  376.           FontType: Integer; Data: PChar): Integer; export;
  377.  function DupS(Item:PStackInt):Boolean;far;
  378.       begin
  379.        DupS := (Item^.StackInt = LogFont.lfHeight);
  380.    end;
  381. var
  382.     FHeight:Array[0..6] of Char;
  383.    PStk :PStack;
  384.    Result :PStackInt;
  385. begin
  386.     PStk :=Sizes^.At(Sizes^.Count-1);
  387.    Result := PStk^.FirstThat(@DupS);
  388.    if Result = nil then PStk^.Push(New(PStackInt,Init(LogFont.lfHeight))) ;
  389.     EnumerateSize := 1;
  390. end;
  391.  
  392.  
  393. { Collect all of faces of current system printer }
  394. procedure TPVWindow.EnumerateFaces;
  395. var
  396.   EnumProc: TFarProc;
  397.   ThePrinter:pPVPrinter;
  398. begin
  399.     ThePrinter := New(pPVPrinter,Init(hInstance,@Self));
  400.     ThePrinter^.GetPrinterParms;
  401.     ThePrinter^.DCCreated;
  402.     EnumProc := MakeProcInstance(@EnumerateFace, HInstance);
  403.     EnumFonts(ThePrinter^.hPrintDC, nil, EnumProc,nil);
  404.     LogPixY := GetDeviceCaps(ThePrinter^.hPrintDC,LogPixelsY);
  405.     LogPixX := GetDeviceCaps(ThePrinter^.hPrintDC,LogPixelsX);
  406.     ThePrinter^.DeleteContext;
  407.     Dispose(ThePrinter,Done);
  408. end;
  409.  
  410. { Collect all of sizes for each face of current system printer }
  411. procedure TPVWindow.EnumerateSizes;
  412. var
  413.   EnumProc: TFarProc;
  414.   ThePrinter:pPVPrinter;
  415.   FontItem :PFontItem;
  416.   Indx : Integer;
  417. begin
  418.     ThePrinter := New(pPVPrinter,Init(hInstance,@Self));
  419.     ThePrinter^.GetPrinterParms;
  420.     ThePrinter^.DCCreated;
  421.     EnumProc := MakeProcInstance(@EnumerateSize, HInstance);
  422.     for Indx := 0 to Faces^.Count -1 do
  423.         begin
  424.       FontItem := Faces^.At(Indx);
  425.       Sizes^.Insert(New(PStack,Init(10,10)));
  426.         EnumFonts(ThePrinter^.hPrintDC, FontItem^.LogFont.lfFaceName,
  427.            EnumProc,nil);
  428.       end;
  429.     ThePrinter^.DeleteContext;
  430.     Dispose(ThePrinter,Done);
  431. end;
  432.  
  433. function TPVWindow.GetFontSelection:Integer;
  434. begin
  435.     GetFontSelection := FontSelection;
  436. end;
  437.  
  438. function TPVWindow.GetFontSize:Integer;
  439. begin
  440.     GetFontSize := FontSize;
  441. end;
  442.  
  443. function TPVWindow.GetTextString:PChar;
  444. begin
  445.     GetTextString := @TextString;
  446. end;
  447.  
  448. procedure TPVWindow.SetFontSize(NewFontSize:Integer);
  449. begin
  450.     FontSize := NewFontSize;
  451. end;
  452.  
  453. procedure TPVWindow.SetPFontSize(NewFontSize:Integer);
  454. begin
  455.     PFontSize := NewFontSize;
  456. end;
  457.  
  458. function TPVWindow.GetLogPixX:Integer;
  459. begin
  460.     GetLogPixX := LogPixX;
  461. end;
  462.  
  463.  
  464. function TPVWindow.GetLogPixY:Integer;
  465. begin
  466.     GetLogPixY := LogPixY;
  467. end;
  468.  
  469.  
  470. procedure TPVWindow.UMFilePrint(var Msg:TMessage);
  471. var
  472.     aPtr : pPVPrinter;
  473.    indx : Integer;
  474.    FI : PFontItem;
  475.    OldFont,NewFont:hFont;
  476.    szSize:Array[0..7] of Char;
  477.    LogFont:TLogFont;
  478.    TM:TTextMetric;
  479.    Buf1:Array[0..60] of Char;
  480. begin
  481.     aPtr := New(pPVPrinter,Init(hInstance,@Self));
  482.    indx := 0;
  483.    if aPtr^.Start('PreView',hWindow) then
  484.        begin
  485.       aPtr^.SetMarginB(LogPixY div 3);
  486.       aPtr^.SetMarginL(LogPixX+LogPixX); {Indent 2 inches}
  487.       aptr^.ResetPos;
  488.       StrECopy(StrECopy(Buf1,'Printer Font Samples: '),aPtr^.DeviceName);
  489.       aPtr^.printLine(Buf1);
  490.       aPtr^.SetMarginL(LogPixX); {Set margin = 1 inch}
  491.       aPtr^.NewLine;
  492.       for indx := 0 to  (Faces^.GetCount-1) do
  493.           begin
  494.          FI := Faces^.At(Indx);
  495.          FI^.LogFont.lfHeight := PFontsize * LogPixY div 72;
  496.          FI^.LogFont.lfWidth := 0;
  497.          FI^.LogFont.lfWeight := fw_Normal;
  498.          FI^.LogFont.lfQuality := Proof_Quality;
  499.          NewFont := CreateFontIndirect(FI^.LogFont);
  500.          OldFont := aPtr^.SetFont(NewFont);
  501.              getTextMetrics(aPtr^.hPrintDC,TM);
  502.          Str(TM.tmHeight * 72 / LogPixY:3:0,szSize);
  503.          StrCat(StrCat(StrCopy(Buf1,FI^.LogFont.lfFaceName),szSize),
  504.          '  ABCDEFG!@#$%^&* abcdefg()_+\<>? 123456789');
  505.          aPtr^.printLine(Buf1);
  506.          OldFont := aPtr^.SetFont(OldFont);
  507.          DeleteObject(NewFont);
  508.          end;
  509.       aPtr^.Finish;
  510.       Dispose(aPtr,Done);
  511.       end;
  512. end;
  513.  
  514. procedure    TPvWindow.WMSysCommand(var Msg:TMessage);
  515. begin
  516.     case Msg.Wparam of
  517.         idm_About:Application^.ExecDialog(New(PDialog,Init(@Self,'PV_About')));
  518.       idm_RunCP:begin
  519.           WinExec('Control',1);
  520.          EnumerateFaces;
  521.          EnumerateSizes;
  522.          end;
  523.    else
  524.        DefWndProc(Msg);
  525.    end;
  526. end;
  527.  
  528.  
  529. {***********************************************************************}
  530.  
  531. { Initialize object and collect font information }
  532. constructor TFontWindow.Init(AParent: PWindowsObject; ATitle: PChar);
  533.  
  534. begin
  535.   TWindow.Init(AParent, ATitle);
  536.   Attr.Style := Attr.Style or ws_VScroll or ws_HScroll or ws_Border;
  537.   FontsHeight := 0;
  538.   Scroller := New(PScroller, Init(@Self, 12, 12,0,0));
  539. end;
  540.  
  541. { Draw  font name in Window & update static text}
  542. procedure TFontWindow.Paint(PaintDC: HDC; var PaintInfo: TPaintStruct);
  543. var
  544.   I: Integer;
  545.   VPosition: Integer;
  546.   FontItem :PFontItem;
  547.   FontSel:Integer;
  548.   AFont:HFont;
  549.   OldFont:HFont;
  550.   Extent:LongRec;
  551.   Text:Array[0..80] of Char;
  552.   Buf:Array[0..80] of Char;
  553.   FH:Real;
  554.   szFH:Array[0..5] of Char;
  555.   LPY:Integer;
  556.   FontMetrics:TTextMetric;
  557. begin                                             {build text display}
  558.     LPY := GetDeviceCaps(PaintDC,LogPixelsY);
  559.     FontItem := Faces^.At(PPVWindow(Parent)^.GetFontSelection);
  560.    FontsHeight := PPVWindow(Parent)^.GetFontSize * LPY div 72;
  561.    FontItem^.LogFont.lfHeight := FontsHeight;
  562.    FontItem^.LogFont.lfWidth := 0;
  563.    FontItem^.LogFont.lfWeight := 0;
  564.    FontItem^.LogFont.lfQuality := Proof_Quality;
  565.    VPosition := 5;
  566.    if StrComp(PPVWindow(Parent)^.GetTextString,'') = 0
  567.        then StrCopy(Text,FontItem^.LogFont.lfFaceName)
  568.        else StrCopy(Text,PPVWindow(Parent)^.GetTextString);
  569.    AFont := CreateFontIndirect(FontItem^.LogFont);
  570.    OldFont := SelectObject(PaintDC, AFont);
  571.     GetTextMetrics(PaintDC,FontMetrics);
  572.    LongInt(Extent) := GetTextExtent(PaintDC,Text,
  573.        StrLen(Text));
  574.    Scroller^.SetRange(Extent.lo div 12, Extent.Hi div 12);
  575.    TextOut(PaintDC, 10,VPosition, Text,
  576.       StrLen(Text));
  577.                                                     {Set static text}
  578.    StrCopy(Buf,'Face: ');
  579.     PPVWindow(Parent)^.St1^.SetText(StrCat(Buf,FontItem^.LogFont.lfFaceName));
  580.    FH :=(FontMetrics.tmHeight)*72 / LPY;
  581.    Str(FH:5:1,szFH);
  582.    StrECopy(StrECopy(Buf,'Actual :'),szFH);
  583.    if FontItem^.FontType and Raster_FontType = 0 then
  584.         StrCat(Buf,'  Type:Vector,') else StrCat(Buf,'  Type:Raster,');
  585.    if FontItem^.FontType and Device_FontType = 0 then
  586.         StrCat(Buf,'GDI') else StrCat(Buf,'Device');
  587.    PPVWindow(Parent)^.St2^.SetText(Buf);
  588.    SelectObject(PaintDC,OldFont);
  589.    DeleteObject(AFont);
  590. end;
  591.  
  592. procedure TFontWindow.Destroy;
  593. begin
  594.   TWindow.Destroy;
  595. end;
  596.  
  597. procedure TFontWindow.WMSize(var Msg: TMessage);
  598. begin
  599.   TWindow.WMSize(Msg);
  600. end;
  601.  
  602. {***********************************************************************}
  603. constructor TFontItem.Init(NewItem:TLogFont;NewType:Integer);
  604. begin
  605.     LogFont := NewItem;
  606.    FontType := NewType;
  607. end;
  608.  
  609. destructor TFontItem.Done;
  610. begin
  611. end;
  612.  
  613. {***********************************************************************}
  614. function TFontCollection.KeyOf(Item:Pointer):Pointer;
  615. var
  616.    Ptr :PChar;
  617. begin
  618.     Ptr := PFontItem(Item)^.LogFont.lfFaceName;
  619.     KeyOf := Ptr;
  620. end;
  621.  
  622.  
  623. function TFontCollection.Compare(Key1,Key2:Pointer):Integer;
  624. begin
  625.     Compare := StrIComp(PChar(Key1),PChar(Key2));
  626. end;
  627.  
  628. function TFontCollection.GetCount:Integer;
  629. begin
  630.     GetCount := Count;
  631. end;
  632.  
  633. {***********************************************************************}
  634. procedure TPVDlg1.IDLb1(var Msg:TMessage);
  635. var
  636.     Idx : Integer;
  637.    Buf:Array[0..5] of Char;
  638.    Ptr : PChar;
  639.    ErrCode:Integer;
  640. begin
  641.     case Msg.lParamHi of
  642.     lbn_SelChange,lbn_DblClk:
  643.        begin
  644.       Ptr := Buf;
  645.       Idx := SendDlgItemMsg(id_Lb1,lb_GetCurSel,0,0);
  646.       SendDlgItemMsg(id_Lb1,lb_GetText,word(Idx),LongInt(Ptr));
  647.        val(Ptr,FontSize,ErrCode);
  648.       PPVWindow(Parent)^.SetFontSize(FontSize);
  649.       EndDlg(Idx);
  650.       Exit;
  651.       end;
  652.    end;
  653. end;
  654.  
  655. procedure TPVDlg1.WMInitDialog(var Msg:TMessage);
  656. var
  657.     pTextItem:PChar;
  658.    Buf:Array[0..5] of Char;
  659.     Indx:Integer;
  660.    DSN,ErrCode :Integer;
  661.    EnumProc:TFarProc;
  662.    TheDC:HDc;
  663.    FontItem:PFontItem;
  664.    Item:PStackInt;
  665.    Flag:PChar;
  666.    ThePrinter:pPVPrinter;
  667.    LPY : Integer;
  668.    PStk :PStack;
  669.    Height:Integer;
  670.    Indx2:Integer;
  671.    Res,Res2:Integer;
  672. begin
  673.     TDialog.WMInitDialog(Msg);
  674.  
  675.    FontItem := Faces^.At(PPVWindow(Parent)^.GetFontSelection);
  676.     PStk := Sizes^.At(PPVWindow(Parent)^.GetFontSelection);
  677.    Indx2 := 0;
  678.    Indx := 12;
  679.    pTextItem := Buf;
  680.  
  681.    Res := FontItem^.FontType and Raster_FontType; {0 = vector font}
  682.    Res2 := FontItem^.FontType and Device_FontType; {0 = GDI font}
  683.    if Res = 0 then
  684.        begin
  685.        Str(Indx:3,Buf);
  686.        while Indx < 200 do
  687.            begin
  688.            SendDlgItemMsg(id_Lb1,lb_AddString,word(0),LongInt(pTextItem));
  689.             Indx := Indx + 12;
  690.           Str(Indx:3,Buf);
  691.            end;
  692.        end
  693.    else
  694.        for Indx2 := 0 to PStk^.Count-1  do
  695.           begin
  696.          Item := PStk^.At(Indx2);
  697.          Height := Item^.StackInt;
  698.          Str(Height * 72 div PPVWindow(Parent)^.GetLogPixY:3,Buf);
  699.            SendDlgItemMsg(id_Lb1,lb_AddString,word(0),LongInt(pTextItem));
  700.           end;
  701. end;
  702.  
  703. {***********************************************************************}
  704. procedure TPVDlg2.WMInitDialog(var Msg:TMessage);
  705. const
  706.     FontFamily : Array[0..5,0..11] of Char = ('Don''t Care', '     Roman',
  707.                    '     Swiss','    Modern', '    Script', 'Decorative');
  708. var
  709.     FontItem:PFontItem;
  710.     TextItem:PChar;
  711.    Buf:Array[0..3] of Char;
  712.    Buf60:Array[0..60] of Char;
  713.    FontMetrics:TTextMetric;
  714.    aPtr:pPVPrinter;
  715.    OldFont,NewFont:hFont;
  716.    LogFont:TLogFont;
  717.    DeviceName:Array[0..30] of Char;
  718.    ScreenDC:hDC;
  719. begin
  720.  FontItem := Faces^.At(PPVWindow(Parent)^.GetFontSelection);
  721.  if DCType = 'P' then
  722.      begin
  723.    aPtr := New(pPVPrinter,Init(hInstance,@Self));
  724.    aPtr^.GetPrinterParms;
  725.    aPtr^.DCCreated;
  726.    StrCopy(DeviceName,aPtr^.DeviceName);
  727.     FontItem^.LogFont.lfHeight := PPVWindow(Parent)^.GetFontSize *
  728.        GetDeviceCaps(aPtr^.hPrintDC,LogPixelsY) div 72;
  729.    FontItem^.LogFont.lfQuality := Proof_Quality;
  730.    FontItem^.LogFont.lfWeight := fw_Normal;
  731.    NewFont := CreateFontIndirect(FontItem^.LogFont);
  732.    OldFont := aPtr^.SetFont(NewFont);
  733.    GetTextMetrics(aPtr^.hPrintDC,FontMetrics);
  734.    aPtr^.SetFont(OldFont);
  735.    DeleteObject(NewFont);
  736.    aPtr^.DeleteContext;
  737.    Dispose(aPtr,Done);
  738.    end
  739.   else
  740.       begin
  741.    StrCopy(DeviceName,'Screen Display');
  742.    ScreenDC :=GetDC(PPVWindow(Parent)^.HWindow);
  743.     FontItem^.LogFont.lfHeight := PPVWindow(Parent)^.GetFontSize *
  744.        GetDeviceCaps(ScreenDC,LogPixelsY) div 72;
  745.    FontItem^.LogFont.lfQuality := Proof_Quality;
  746.    FontItem^.LogFont.lfWeight := fw_Normal;
  747.    NewFont := CreateFontIndirect(FontItem^.LogFont);
  748.    OldFont := SelectObject(ScreenDC,Newfont);
  749.    GetTextMetrics(ScreenDC,FontMetrics);
  750.    SelectObject(ScreenDC,OldFont);
  751.    DeleteObject(NewFont);
  752.    ReleaseDC(PPVWindow(Parent)^.HWindow,ScreenDC);
  753.   end;
  754.  
  755.     TDialog.WMInitDialog(Msg);
  756.    StrECopy(StrECopy(StrECopy(Buf60,FontItem^.LogFont.lfFaceName),' - '),DeviceName);
  757.    SetDlgItemText(HWindow,601,Buf60);
  758.  
  759.    Str(FontMetrics.tmHeight:3,Buf); SetDlgItemText(HWindow,612,Buf);
  760.    Str(FontMetrics.tmAscent:3,Buf); SetDlgItemText(HWindow,613,Buf);
  761.    Str(FontMetrics.tmDescent:3,Buf); SetDlgItemText(HWindow,614,Buf);
  762.    Str(FontMetrics.tmInternalLeading:3,Buf); SetDlgItemText(HWindow,615,Buf);
  763.    Str(FontMetrics.tmExternalLeading:3,Buf); SetDlgItemText(HWindow,616,Buf);
  764.    Str(FontMetrics.tmAveCharWidth:3,Buf); SetDlgItemText(HWindow,617,Buf);
  765.    Str(FontMetrics.tmMaxCharWidth:3,Buf); SetDlgItemText(HWindow,618,Buf);
  766.    Str(FontMetrics.tmWeight:3,Buf); SetDlgItemText(HWindow,619,Buf);
  767.    Str(FontMetrics.tmItalic:3,Buf); SetDlgItemText(HWindow,620,Buf);
  768.    Str(FontMetrics.tmUnderlined:3,Buf); SetDlgItemText(HWindow,621,Buf);
  769.  
  770.    Str(FontMetrics.tmStruckOut:3,Buf); SetDlgItemText(HWindow,632,Buf);
  771.    Str(FontMetrics.tmFirstChar:3,Buf); SetDlgItemText(HWindow,633,Buf);
  772.    Str(FontMetrics.tmLastChar:3,Buf); SetDlgItemText(HWindow,634,Buf);
  773.    Str(FontMetrics.tmDefaultChar:3,Buf); SetDlgItemText(HWindow,635,Buf);
  774.    if FontMetrics.tmPitchandFamily and 1 > 0 then SetDlgItemText(HWindow,636,'Variable')
  775.        else SetDlgItemText(HWindow,636,'Fixed');
  776.     SetDlgItemText(HWindow,637,FontFamily[FontMetrics.tmPitchAndFamily shr 4] );
  777.    if FontMetrics.tmCharSet = ANSI_CharSet  then SetDlgItemText(HWindow,638,'Ansi')
  778.    else if FontMetrics.tmCharSet = OEM_CharSet  then SetDlgItemText(HWindow,638,'OEM')
  779.    else if FontMetrics.tmCharSet = Symbol_CharSet  then SetDlgItemText(HWindow,638,'Symbol')
  780.    else if FontMetrics.tmCharSet = ShiftJis_CharSet  then SetDlgItemText(HWindow,638,'ShiftJis')
  781.    else SetDlgItemText(HWindow,638,' ');
  782.    Str(FontMetrics.tmOverHang:3,Buf); SetDlgItemText(HWindow,639,Buf);
  783.    Str(FontMetrics.tmDigitizedAspectX:3,Buf); SetDlgItemText(HWindow,640,Buf);
  784.    Str(FontMetrics.tmDigitizedAspectY:3,Buf); SetDlgItemText(HWindow,641,Buf);
  785. end;
  786.  
  787. {*********************************************************************}
  788. procedure TPVDlg3.WMInitDialog(var Msg:TMessage);
  789. var
  790.   ThePrinter:pPVPrinter;
  791.   DeviceName:Array[0..40] of Char;
  792. begin
  793.      TDialog.WMInitDialog(Msg);
  794.     ThePrinter := New(pPVPrinter,Init(hInstance,@Self));
  795.     ThePrinter^.GetPrinterParms;
  796.     ThePrinter^.DCCreated;
  797.     StrCopy(DeviceName,ThePrinter^.deviceName);
  798.     ThePrinter^.DeleteContext;
  799.     Dispose(ThePrinter,Done);
  800.     SetDlgItemText(HWindow,503,DeviceName);
  801. end;
  802.  
  803. procedure TPVDlg3.IDSetup(var Msg:TMessage);
  804. var
  805.     ThePrinter:pPVPrinter;
  806. begin
  807.     ThePrinter := New(pPVPrinter,Init(hInstance,@Self));
  808.    ThePrinter^.prnDeviceMode(hWindow);
  809.    dispose(ThePrinter,Done);
  810.    pPVWindow(Parent)^.EnumerateFaces;
  811.    pPVWindow(Parent)^.EnumerateSizes;
  812. end;
  813.  
  814.  procedure TPVDlg3.IDOKPrt(var Msg:TMessage);
  815. begin
  816.    EndDlg(1);
  817.     SendMessage(PPVWindow(Parent)^.HWindow,wm_User+um_FilePrint,Msg.wParam,Msg.LParam);
  818. end;
  819.  
  820. procedure TPVDlg3.IDEC1(var Msg:TMessage);
  821. var
  822.     Idx : Integer;
  823.    Buf:Array[0..5] of Char;
  824.    Ptr : PChar;
  825.    ErrCode:Integer;
  826.    FontSize:Integer;
  827.    return:Integer;
  828. begin
  829.     case Msg.lParamHi of
  830.     en_Change:
  831.        begin
  832.       Ptr := Buf;
  833.       Idx := 5;
  834.       Return := SendDlgItemMsg(id_Ec1,wm_GetText,word(Idx),LongInt(Ptr));
  835.       val(Ptr,FontSize,ErrCode);
  836.       PPVWindow(Parent)^.SetPFontSize(FontSize);
  837.       Exit;
  838.       end;
  839.    end;
  840. end;
  841. {*********************************************************************}
  842. function TPVPrinter.SetFont(NewFont:hFont):hFont;
  843. var
  844.     MM:Integer;
  845.    LogFont:TLogFont;
  846. begin
  847.     SetFont := SelectObject(hPrintDC,NewFont);
  848.    getTextMetrics(hPrintDC,Metrics);
  849.    MM := GetMapMode(hPrintDC);
  850.    GetObject(NewFont,sizeof(LogFont),@LogFont);
  851. end;
  852.  
  853. function TPVPrinter.Start(dName:pChar;hw:HWnd):Boolean;
  854. begin
  855.     MarginL := 0;
  856.    MarginT := 0;
  857.    MarginR := 0;
  858.    MarginB := 0;
  859.    Start := tPrinter.Start(dName,hw);   {ancestor call}
  860. end;
  861.  
  862. procedure TPVPrinter.SetMarginL(NewMargin:Integer);
  863. begin
  864.     MarginL := NewMargin;
  865. end;
  866.  
  867. procedure TPVPrinter.SetMarginT(NewMargin:Integer);
  868. begin
  869.     MarginT := NewMargin;
  870. end;
  871.  
  872. procedure TPVPrinter.SetMarginR(NewMargin:Integer);
  873. begin
  874.     MarginR := NewMargin;
  875. end;
  876.  
  877. procedure TPVPrinter.SetMarginB(NewMargin:Integer);
  878. begin
  879.     MarginB := NewMargin;
  880. end;
  881.  
  882.  
  883. function TPVPrinter.NewLine:Boolean;
  884. Begin
  885.     posX := MarginL;
  886.    posY := posY + height;
  887.    checkNewPage;
  888. end;
  889.  
  890. function TPVPrinter.ResetPos:Boolean;
  891. Begin
  892.     posX := MarginL;
  893.    posY := MarginT;
  894. end;
  895.  
  896. function TPVPrinter.CheckNewPage:Boolean;
  897. begin
  898.     if (posY + MarginB > maxY ) then newPage;
  899. end;
  900.  
  901. function TPVPrinter.Print(aStr:pchar):Boolean;
  902. var
  903.     Extent:Integer;
  904. begin
  905.     Extent := lineWidth(aStr);
  906.    if ((PosX + Extent + MarginR) > maxX) then
  907.        newLine;
  908.    if printString(aStr) then
  909.        begin
  910.       PosX := PosX + Extent;
  911.       Print := True;
  912.       end
  913.    else
  914.        Print := False;
  915. end;
  916.  
  917.  
  918. function     TPVPrinter.prnDeviceMode(Wnd:HWnd):Integer;
  919.  var
  920.   dHandle: tHandle;     {handle of the load library for the current printer}
  921.   drvName: pChar;       {name of the driver used to get dHandle}
  922.   pAddr:   tFarProc;    {address of the function in the DLL we want to EXEC}
  923.  
  924.  
  925. Begin
  926.   if getPrinterParms then begin            {retrieve printer info from windows}
  927.     drvName := driver;
  928.     strCat(drvName,'.drv');             {make a file name out of the driver}
  929.     dHandle := LoadLibrary(drvName);    {load the DLL for the printer}
  930.     pAddr := getProcAddress(dHandle,'ExtDeviceMode');
  931.     if (pAddr <> nil) then begin
  932.       tGetExtDevMode(pAddr)(wnd,dHandle,dMode,drvName,prnPort,dMode,nil,
  933.               dm_prompt  OR dm_Update);
  934.     end else begin
  935.       pAddr := GetProcAddress(dHandle,'DEVICEMODE');
  936.       if (pAddr <> nil) then begin
  937.         tGetDevMode(pAddr)(wnd,dHandle,drvName,prnPort);
  938.       End;
  939.     End;
  940.     FreeLibrary(dHandle);   {the library is freed when we are done with it}
  941.   End;
  942. end;
  943.  
  944.  
  945. {*********************************************************************}
  946. {*** M A I N L I N E                                                  }
  947. {*********************************************************************}
  948. var
  949.     PVApp : TPVApplication;
  950. begin
  951.     PVApp.Init('Font Preview');
  952.     PVApp.Run;
  953.     PVApp.Done;
  954.  
  955. end.
  956.