home *** CD-ROM | disk | FTP | other *** search
/ Borland Programmer's Resource / Borland_Programmers_Resource_CD_1995.iso / fonts / previe / preview.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1995-05-19  |  14.0 KB  |  495 lines
  1. {Preview - 1.0 Program Copyright (C) Doug Overmyer 7/1/91}
  2. program FList;
  3.  
  4. {$S-}
  5. {$R PREVIEW.RES}
  6. uses WinTypes, WinProcs, WinDos, Strings, WObjects,StdDlgs;
  7.  
  8. const
  9.   id_But1    = 201;
  10.   id_But2    = 202;
  11.   id_But3    = 203;
  12.   id_But4    = 204;
  13.   id_Lb1     = 301;
  14.   id_lb2     = 302;
  15.   id_St1     = 401;
  16.   id_St2     = 402;
  17.   id_St3     = 403;
  18.   id_St4     = 404;
  19.  
  20. {******************************************************************}
  21. { Types                                                            }
  22. {******************************************************************}
  23. type
  24.     TPVApplication = object(TApplication)
  25.        procedure InitMainWindow;virtual;
  26.     end;
  27.  
  28. PPVDialog = ^TPVDialog;
  29. TPVDialog = object(TDialog)
  30.     FontSize: Integer;
  31.     procedure WMInitDialog(var Msg:TMessage);virtual wm_First+wm_InitDialog;
  32.    procedure IDLb1(var Msg:TMessage);virtual id_First+id_Lb1;
  33.     end;
  34.  
  35. type                          {convert TLogFont records to objects}
  36. PFontItem = ^TFontItem;
  37. TFontItem = object(TObject)
  38.     LogFont:TLogFont;
  39.    constructor Init(NewItem:TLogFont);
  40.    destructor Done;virtual;
  41. end;
  42.  
  43. PFontCollection = ^TFontCollection;
  44. TFontCollection = object(TSortedCollection)
  45.     function KeyOf(Item:Pointer):Pointer;virtual;
  46.    function Compare(Key1,Key2:Pointer):Integer;virtual;
  47. end;
  48.  
  49. var
  50.   Fonts:PFontCollection; {Global collection of PFontItem to for call-back func}
  51.  
  52. type                            {Child win to display sample text}
  53.   PFontWindow = ^TFontWindow;
  54.   TFontWindow = object(TWindow)
  55.     FontsHeight: LongInt;
  56.     constructor Init(AParent: PWindowsObject; ATitle: PChar);
  57.     procedure Paint(PaintDC: HDC; var PaintInfo: TPaintStruct); virtual;
  58.     procedure Destroy; virtual;
  59.     procedure WMSize(var Msg: TMessage);
  60.       virtual wm_First + wm_Size;
  61.   end;
  62.  
  63. type                           {MainWindow of Application}
  64. PPVWindow = ^TPVWindow;
  65. TPVWindow = object(TWindow)
  66.     FWin:PFontWindow;
  67.    FBox:PListBox;
  68.    TheIcon:HIcon;
  69.    TheButton,TheLogo:HBitmap;{button = About button}
  70.    Bn1,Bn2,Bn3,Bn4 : PButton;
  71.    Dlg1 : PPVDialog;        {Select font size dialog}
  72.    St1,St2,St3,St4:PStatic;
  73.    TextString:Array[0..50] of Char;    {to display in FWin}
  74.       FontSelection:Integer;              {Index into Fonts collection}
  75.    FontSize:Integer;         {Current font size desired}
  76.     constructor Init(AParent:PWindowsObject;ATitle:PChar);
  77.    destructor  Done;virtual;
  78.    procedure     SetupWindow;virtual;
  79.    procedure     Paint(PaintDC:HDC;var PaintInfo:TPaintStruct);virtual;
  80.    procedure    LoadFBox;
  81.    procedure     WMSize(var Msg:TMessage);virtual wm_First+wm_Size;
  82.    procedure     WMSetFocus(var Msg:TMessage);virtual wm_First+wm_SetFocus;
  83.    procedure     IDBut1(var Msg:TMessage);virtual id_First+id_But1; {Drive}
  84.     procedure     IDBut2(var Msg:TMessage);virtual id_First+id_But2; {Clipboard}
  85.    procedure     IDBut3(var Msg:TMessage);virtual id_First+id_But3; {not used}
  86.    procedure     IDBut4(var Msg:TMessage);virtual id_First+id_But4; {Exit}
  87.    procedure    IDLB2(var Msg:TMessage);virtual  id_First+id_lb2;
  88.    procedure     WMLButtonUp(var Msg:TMessage);virtual wm_First+wm_LButtonUp;
  89.    procedure     EnumerateFonts;virtual;
  90.    function        GetFontSelection:Integer;virtual;
  91.    function        GetFontSize:Integer;virtual;
  92.    function        GetTextString:PChar;virtual;
  93.    procedure    SetFontSize(NewfontSize:Integer);virtual;
  94. end;
  95.  
  96.  
  97. {********************************************************************}
  98. {M E T H O D S                                                       }
  99. {********************************************************************}
  100.  
  101. procedure TPVApplication.InitMainWindow;
  102. begin
  103.     MainWindow := New(PPVWindow,Init(nil,'Preview'));
  104. end;
  105.  
  106. {********************************************************************}
  107. {Init}
  108. constructor TPVWindow.Init(AParent:PWindowsObject;ATitle:PChar);
  109. begin
  110.     TWindow.Init(AParent,ATitle);
  111.    Attr.Menu := 0;
  112.    Attr.X := 20; Attr.Y := 25; Attr.W := 595; Attr.H := 325;
  113.    Fonts := New(PFontCollection,Init(100,100));
  114.    Fonts^.Duplicates := True;
  115.       EnumerateFonts;
  116.    FWin := New(PFontWindow,Init(@Self,ATitle));
  117.    with FWin^.Attr do
  118.        Style := Style or ws_Child or ws_HScroll or ws_VScroll or ws_Border ;
  119.    FBox := New(PListBox,Init(@Self,id_lb2,0,0,0,0));
  120.    with FBox^.Attr do
  121.        begin
  122.        Style := Style and not lbs_Sort  ;
  123.       end;
  124.    Bn1 := New(PButton,Init(@Self,id_But1,'Font Size',0,0,0,0,False));
  125.    Bn2 := New(PButton,Init(@Self,id_But2,'String',0,0,0,0,False));
  126.    Bn3 := New(PButton,Init(@Self,id_But3,'File',0,0,0,0,False));
  127.    Bn4 := New(PButton,Init(@Self,id_But4,'Exit',0,0,0,0,False));
  128.    St1 := New(PStatic,Init(@Self,id_St1,'',315,5,240,18,75));
  129.    St2 := New(PStatic,Init(@Self,id_St2,'',315,26,240,18,75));
  130.    St3 := New(PStatic,Init(@Self,id_ST3,'',310,3,250,44,75));
  131.    St4 := New(PStatic,Init(@Self,id_St4,'',5,55,100,18,75));
  132.    TheButton := LoadBitmap(HInstance,'PV_BUTTON');
  133.    TheLogo   := LoadBitmap(HInstance,'PV_BMP');
  134.    St2^.Attr.Style := St2^.Attr.Style or ss_LeftNoWordWrap;
  135.    St3^.Attr.Style := St3^.Attr.Style or ss_BlackFrame;
  136.    St4^.Attr.Style := St4^.Attr.Style or ss_Left;
  137.    FontSelection := 0;
  138.    FontSize := 48;
  139.    StrCopy(TextString,'');
  140. end;
  141.  
  142. {SetupWindow}
  143. procedure TPVWindow.SetupWindow;
  144. begin
  145.     TWindow.SetupWindow;
  146.     SetClassWord(HWindow,GCW_HIcon,LoadIcon(HInstance,'PV_Icon'));
  147.    LoadFBox;
  148. end;
  149.  
  150. {Paint}
  151. procedure TPVWindow.Paint(PaintDC:HDC;var PaintInfo:TPaintStruct);
  152. var
  153.     ThePen:HPen;
  154.    TheBrush :HBrush;
  155.    OldBrush :HBrush;
  156.    OldPen:HPen;
  157.    OldBitMap:HBitMap;
  158.    MemDC :HDC;
  159.    CR:TRect;
  160.    W,H:Integer;
  161.    BMRec:TBitMap;
  162.  
  163. begin
  164.     TheBrush := GetStockObject(LtGray_Brush);
  165.     ThePen := CreatePen(ps_Solid,1,$00000000);
  166.    OldPen := SelectObject(PaintDC,ThePen);
  167.    OldBrush := SelectObject(PaintDC,TheBrush);
  168.    Rectangle(PaintDC,0,0,1024,50);
  169.    SelectObject(PaintDC,OldBrush);
  170.    SelectObject(PaintDC,OldPen);
  171.    DeleteObject(ThePen);
  172.    MemDC := CreateCompatibleDC(PaintDC);
  173.    OldBitMap := SelectObject(MemDC,TheButton);
  174.    BitBlt(PaintDC,0,0,50,50,MemDC,0,0,SrcCopy);
  175.    SelectObject(MemDC,OldBitMap);
  176.    DeleteDC(MemDC);
  177.  
  178.    GetObject(TheLogo,sizeOf(BMRec),@BMRec);;
  179.    GetClientRect(HWindow,CR);
  180.    W := CR.Right-CR.Left;H := CR.Bottom-CR.Top;
  181.    MemDC := CreateCompatibleDC(PaintDC);
  182.    OldBitMap := SelectObject(MemDC,TheLogo);
  183.    BitBlt(PaintDC,((W div 3) - BMRec.bmWidth) div 2,
  184.        50+ ((H -50) div 2)+ abs((((H -50) div 2)-BMRec.bmHeight)div 2) ,
  185.        W div 3,H div 2,
  186.       MemDC,0,0,SrcCopy);
  187.    SelectObject(MemDC,OldBitMap);
  188.    DeleteDC(MemDC);
  189. end;
  190.  
  191. {Done}
  192. destructor TPVWindow.Done;
  193. begin
  194.     DeleteObject(TheButton);
  195.    DeleteObject(TheLogo);
  196.     TWindow.Done;
  197. end;
  198.  
  199. {WMSize}
  200. procedure TPVWindow.WMSize(var Msg:TMessage);
  201. begin
  202.     SetWindowPos(FBox^.HWindow,0,-1,75,(Msg.LParamLo div 3)+1,
  203.        ((Msg.LParamHi-75) div 2 - 0),swp_NoZOrder);
  204.     SetWindowPos(FWin^.HWindow,0,(Msg.LParamLo  div 3)-1,49,
  205.        (Msg.LParamLo * 2 div 3)+1,(Msg.LParamHi-48),swp_NoZOrder);
  206.    SetWindowPos(Bn1^.HWindow,0,50,0,100,50,swp_NoZOrder);
  207.    SetWindowPos(Bn2^.HWindow,0,150,0,100,50,swp_NoZOrder);
  208.   {SetWindowPos(Bn3^.HWindow,0,200,0,50,50,swp_NoZOrder);}
  209.    SetWindowPos(Bn4^.HWindow,0,250,0,50,50,swp_NoZOrder);
  210. end;
  211.  
  212. {WMSetFocus}
  213. procedure TPVWindow.WMSetFocus(var Msg:TMessage);
  214. begin
  215.     SetFocus(FBox^.HWindow);
  216. end;
  217.  
  218. {IDBut1} {run font size dialog box}
  219. procedure TPVWindow.IDBut1(var Msg:TMessage);
  220. begin
  221.     Dlg1 := new(PPVDialog,Init(@Self,'PV_Dlg1'));
  222.    Application^.ExecDialog(Dlg1);
  223.    if (Dlg1^.FontSize) <> 0 then
  224.        InvalidateRect(Fwin^.HWindow,nil,True);
  225. end;
  226.  
  227. {IDBut2}   {run sample string dialog box}
  228. procedure TPVWindow.IDBut2(var Msg:TMessage);
  229. var
  230.     TotChars:Integer;
  231. begin
  232.    If Application^.ExecDialog(New(PInputdialog,Init(@Self,'Font String',
  233.        'Enter text:',TextString,SizeOf(TextString)))) = id_OK then
  234.  
  235.     else StrCopy(TextString,'');
  236. end;
  237.  
  238. {IdBut3}{not used}
  239. procedure TPVWindow.IDBut3(var Msg:TMessage);
  240. begin
  241.  
  242. end;
  243.  
  244. {IdBut4}  {exit}
  245. procedure TPVWindow.IDBut4(var Msg:TMessage);
  246. begin
  247.    SendMessage(HWindow,wm_Close,0,0);
  248. end;
  249.  
  250. {WMLButtonDown} {hit test for bitmapped button}
  251. procedure TPVWindow.WMLButtonUp(var Msg:TMessage);
  252. var
  253.     Dlg : PDialog;
  254. begin
  255.     if (Msg.lParamLo < 50) and (Msg.lParamHi < 50) then
  256.        begin
  257.       Dlg :=New(PDialog,Init(@Self,'PV_About'));
  258.       Application^.ExecDialog(Dlg);
  259.       end;
  260. end;
  261.  
  262. procedure TPVWindow.LoadFBox;
  263. var
  264.     Indx : Integer;
  265.    Font : PFontItem;
  266.    Buf1 :Array[0..20] of Char;
  267.    Buf2 :Array[0..5] of Char;
  268. begin
  269.     Str(Fonts^.Count,Buf2);
  270.     StrECopy(StrECopy(StrECopy(Buf1,'*'),Buf2),' Fonts*');
  271.    St4^.SetText(Buf1);
  272.     for indx := 0 to (Fonts^.Count -1) do
  273.        begin
  274.         Font := Fonts^.At(indx);
  275.        FBox^.InsertString(Font^.LogFont.lfFaceName,-1);
  276.       end;
  277. end;
  278.  
  279. procedure TPVWindow.IDLB2(var Msg:TMessage);
  280. var
  281.     szBuffer:Array[0..80] of Char;
  282.  
  283.    indx:Integer;
  284. begin
  285.     case Msg.lParamHi of
  286.        lbn_DblClk, lbn_SelChange:
  287.           begin
  288.           indx := FBox^.GetSelIndex;
  289.          FontSelection := Indx;
  290.          InvalidateRect(FWin^.HWindow,nil,True);
  291.          Exit;
  292.          end;
  293.    end;
  294. end;
  295.  
  296. function EnumerateFont(var LogFont: TLogFont; TextMetric: PTextMetric;
  297.   FontType: Integer; Data: PChar): Integer; export;
  298. var
  299.   OldFont: HFont;
  300. begin
  301.   Fonts^.Insert(New(PFontItem,Init(LogFont)));
  302.   EnumerateFont := 1;
  303. end;
  304.  
  305.  
  306. { Collect all of the system fonts }
  307. procedure TPVWindow.EnumerateFonts;
  308. var
  309.   EnumProc: TFarProc;
  310.   TheDC :HDC;
  311.  
  312. begin
  313.     TheDC := GetDC(HWindow);
  314.     EnumProc := MakeProcInstance(@EnumerateFont, HInstance);
  315.     EnumFonts(TheDC, nil, EnumProc, nil);
  316.     ReleaseDC(HWindow, TheDC);
  317. end;
  318.  
  319. function TPVWindow.GetFontSelection:Integer;
  320. begin
  321.     GetFontSelection := FontSelection;
  322. end;
  323.  
  324. function TPVWindow.GetFontSize:Integer;
  325. begin
  326.     GetFontSize := FontSize;
  327. end;
  328.  
  329. function TPVWindow.GetTextString:PChar;
  330. begin
  331.     GetTextString := @TextString;
  332. end;
  333.  
  334. procedure TPVWindow.SetFontSize(NewFontSize:Integer);
  335. begin
  336.     FontSize := NewFontSize;
  337. end;
  338.  
  339. {***********************************************************************}
  340.  
  341. { Initialize object and collect font information }
  342. constructor TFontWindow.Init(AParent: PWindowsObject; ATitle: PChar);
  343. var
  344.   I: Integer;
  345.  
  346. function Max(I, J: LongInt): LongInt;
  347. begin
  348.   if I > J then Max := I else Max := J;
  349. end;
  350.  
  351. begin
  352.   TWindow.Init(AParent, ATitle);
  353.   Attr.Style := Attr.Style or ws_VScroll or ws_HScroll or ws_Border;
  354.   FontsHeight := 0;
  355.   Scroller := New(PScroller, Init(@Self, 12, 12,0,0));
  356. end;
  357.  
  358. { Draw each font name in it's font in the Display context.  Each
  359.   line is incremented by the height of the font }
  360. procedure TFontWindow.Paint(PaintDC: HDC; var PaintInfo: TPaintStruct);
  361. var
  362.   I: Integer;
  363.   VPosition: Integer;
  364.   FontItem :PFontItem;
  365.   FontSel:Integer;
  366.   AFont:HFont;
  367.   OldFont:HFont;
  368.   Extent:LongRec;
  369.   Text:Array[0..80] of Char;
  370.   Buf:Array[0..80] of Char;
  371.   szFH:Array[0..4] of Char;
  372. begin
  373.     FontItem := Fonts^.At(PPVWindow(Parent)^.GetFontSelection);
  374.    FontItem^.LogFont.lfHeight := PPVWindow(Parent)^.GetFontSize;
  375.    FontsHeight := PPVWindow(Parent)^.GetFontSize;
  376.    FontItem^.LogFont.lfWidth := 0;
  377.    FontItem^.LogFont.lfWeight := 0;
  378.    FontItem^.LogFont.lfQuality := Proof_Quality;
  379.    VPosition := 5;
  380.    if StrComp(PPVWindow(Parent)^.GetTextString,'') = 0
  381.        then StrCopy(Text,FontItem^.LogFont.lfFaceName)
  382.        else StrCopy(Text,PPVWindow(Parent)^.GetTextString);
  383.    AFont := CreateFontIndirect(FontItem^.LogFont);
  384.    OldFont := SelectObject(PaintDC, AFont);
  385.    LongInt(Extent) := GetTextExtent(PaintDC,Text,
  386.        StrLen(Text));
  387.    Scroller^.SetRange(Extent.lo div 12, Extent.Hi div 12);
  388.    TextOut(PaintDC, 10,VPosition, Text,
  389.       StrLen(Text));
  390.    StrCopy(Buf,'Face: ');
  391.     PPVWindow(Parent)^.St1^.SetText(StrCat(Buf,FontItem^.LogFont.lfFaceName));
  392.    Str(FontsHeight:3,szFH);
  393.    StrCat(StrCopy(Buf,'Size: '),szFH);
  394.    PPVWindow(Parent)^.St2^.SetText(Buf);
  395.    SelectObject(PaintDC,OldFont);
  396.    DeleteObject(AFont);
  397. end;
  398.  
  399. procedure TFontWindow.Destroy;
  400. var
  401.   I: Integer;
  402. begin
  403.   TWindow.Destroy;
  404. end;
  405.  
  406. procedure TFontWindow.WMSize(var Msg: TMessage);
  407. begin
  408.   TWindow.WMSize(Msg);
  409. {  if Scroller <> nil then
  410.     Scroller^.SetRange(FontsWidth div 12,
  411.       FontsHeight div 12);   }
  412. end;
  413.  
  414. {***********************************************************************}
  415. constructor TFontItem.Init(NewItem:TLogFont);
  416. begin
  417.     LogFont := NewItem;
  418. end;
  419.  
  420. destructor TFontItem.Done;
  421. begin
  422. end;
  423.  
  424.  
  425. {***********************************************************************}
  426. function TFontCollection.KeyOf(Item:Pointer):Pointer;
  427. var
  428.    Ptr :PChar;
  429. begin
  430.     Ptr := PFontItem(Item)^.LogFont.lfFaceName;
  431.     KeyOf := Ptr;
  432. end;
  433.  
  434.  
  435. function TFontCollection.Compare(Key1,Key2:Pointer):Integer;
  436. begin
  437.     Compare := StrIComp(PChar(Key1),PChar(Key2));
  438. end;
  439.  
  440. {***********************************************************************}
  441. procedure TPVDialog.IDLb1(var Msg:TMessage);
  442. var
  443.     Idx : Integer;
  444.    Buf:Array[0..5] of Char;
  445.    Ptr : PChar;
  446.    ErrCode:Integer;
  447. begin
  448.     case Msg.lParamHi of
  449.     lbn_SelChange,lbn_DblClk:
  450.        begin
  451.       Ptr := Buf;
  452.       Idx := SendDlgItemMsg(id_Lb1,lb_GetCurSel,0,0);
  453.       SendDlgItemMsg(id_Lb1,lb_GetText,word(Idx),LongInt(Ptr));
  454.        val(Ptr,FontSize,ErrCode);
  455.       PPVWindow(Parent)^.SetFontSize(FontSize);
  456.       EndDlg(Idx);
  457.       Exit;
  458.       end;
  459.    end;
  460. end;
  461.  
  462. procedure TPVDialog.WMInitDialog(var Msg:TMessage);
  463. var
  464.     TextItem:PChar;
  465.    Buf:Array[0..3] of Char;
  466.     Indx:Integer;
  467.    DSN,ErrCode :Integer;
  468. begin
  469.     TDialog.WMInitDialog(Msg);
  470.    DosError := 0;
  471.    {$I-}
  472.    Indx := 12;
  473.    TextItem := Buf;
  474.    Str(Indx:2,Buf);
  475.    while Indx < 200 do
  476.    begin
  477.        SendDlgItemMsg(id_Lb1,lb_InsertString,word(-1),LongInt(TextItem));
  478.         Indx := Indx + 12;
  479.       Str(Indx:2,Buf);
  480.    end;
  481. end;
  482.  
  483.  
  484. {*********************************************************************}
  485. {*** M A I N L I N E                                                  }
  486. {*********************************************************************}
  487. var
  488.     PVApp : TPVApplication;
  489. begin
  490.     PVApp.Init('Preview');
  491.     PVApp.Run;
  492.     PVApp.Done;
  493.  
  494. end.
  495.