home *** CD-ROM | disk | FTP | other *** search
/ ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng) / ProfitPress-MegaCDROM2.B6I / PROG / MISC / TPWN31.ZIP / TTDEMO.ZIP / TTFONT.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1992-04-06  |  8.9 KB  |  299 lines
  1. {************************************************}
  2. {                                                }
  3. {   Turbo Pascal for Windows                     }
  4. {   Windows 3.1 Demo program                     }
  5. {   Copyright (c) 1992 by Borland International  }
  6. {                                                }
  7. {************************************************}
  8. {$N+}
  9. {$R TTFonts}
  10.  
  11. program TrueTypeFontLab;
  12.  
  13. uses WObjects, WinTypes, WinProcs, Strings, Win31, CommDlg, TTFCnst;
  14.  
  15. type
  16.  
  17.   PFontWindow = ^TFontWindow;
  18.   TFontWindow = object(TWindow)
  19.     MainFontRec,
  20.     CornerFontRec,
  21.     BorlandFontRec:  TLogFont;
  22.     FanColor: array [0..9] of TColorRef;
  23.     ShadowAll: Boolean;
  24.     ShowAlignmentMarks: Boolean;
  25.     constructor Init(AParent: PWindowsObject; ATitle: PChar);
  26.     procedure Paint(DC: HDC; var PS: TPaintStruct); virtual;
  27.     procedure CMAbout(var Msg: TMessage); virtual cm_First + cm_About;
  28.     procedure CMShadows(var Msg: TMessage); virtual cm_First + cm_Shadows;
  29.     procedure CMAlignmentMarks(var Msg: TMessage); virtual cm_First + cm_AlignmentMarks;
  30.     procedure CMFonts(var Msg: TMessage); virtual cm_First + cm_Fonts;
  31.     procedure WMGetMinMaxInfo(var Msg: TMessage); virtual wm_First + wm_GetMinMaxInfo;
  32.   end;
  33.  
  34. constructor TFontWindow.Init(AParent: PWindowsObject; ATitle: PChar);
  35. begin
  36.   TWindow.Init(AParent, ATitle);
  37.   Attr.Menu := LoadMenu(HInstance, PChar(100));
  38.  
  39.   with MainFontRec do  { Init the logical font record for the 'fan' text }
  40.   begin
  41.     lfHeight:= 26;
  42.     lfWidth:= 10;
  43.     lfEscapement:= 0;
  44.     lfOrientation:= 0;
  45.     lfWeight:= fw_Bold;
  46.     lfItalic:= 0;
  47.     lfUnderline:= 0;
  48.     lfStrikeOut:= 0;
  49.     lfCharSet:= ANSI_CharSet;
  50.     lfOutPrecision:= Out_Default_Precis;
  51.     lfClipPrecision:= Clip_Default_Precis;
  52.     lfQuality:= Proof_Quality;
  53.     lfPitchAndFamily:= Variable_Pitch or FF_Roman;
  54.     StrCopy(lfFaceName,'Times New Roman');
  55.   end;
  56.  
  57.   CornerFontRec := MainFontRec;
  58.  
  59.   BorlandFontRec := MainFontRec;
  60.   with BorlandFontRec do
  61.   begin
  62.     lfHeight:= 60;
  63.     lfWidth:= 0;   { choose best width for this height }
  64.     lfWeight:= 900;
  65.     StrCopy(lfFaceName, 'Arial');
  66.   end;
  67.  
  68.   { Array of colors used to color the fan text }
  69.   FanColor[0] := RGB(255,0,0);
  70.   FanColor[1] := RGB(128,0,0);
  71.   FanColor[2] := RGB(255,128,0);
  72.   FanColor[3] := RGB(80,80,0);
  73.   FanColor[4] := RGB(80,255,0);
  74.   FanColor[5] := RGB(0,128,0);
  75.   FanColor[6] := RGB(0,128,255);
  76.   FanColor[7] := RGB(0,0,255);
  77.   FanColor[8] := RGB(128,128,128);
  78.   FanColor[9] := RGB(255,0,0);
  79.  
  80.   ShadowAll := False;
  81.   ShowAlignmentMarks := False;
  82. end;
  83.  
  84.  
  85. procedure TFontWindow.Paint(DC: HDC; var PS: TPaintStruct);
  86. const
  87.   ArcText = 'TrueType';
  88.   FanText = 'Turbo Pascal for Windows';
  89.   BorlandText = 'Borland';
  90.   Radius = 100;
  91.  
  92. type
  93.   TTextExtent = record
  94.     W, H: Word;
  95.   end;
  96.  
  97. var
  98.   FontRec: TLogFont;
  99.   FontMetric: TOutlineTextMetric;
  100.   FontHeight : integer;
  101.   d: Word;
  102.   x,y,j,k: Integer;
  103.   Theta : real;
  104.   P: PChar;
  105.   Deg2Rad: Extended;
  106.   R: TRect;
  107.   BaseWidth,
  108.   DesiredExtent,
  109.   FanTextLen: Word;
  110.   TE: TTextExtent;
  111. begin
  112.  
  113.   P := ArcText;
  114.   Deg2Rad := PI / 18;
  115.   FanTextLen := StrLen(FanText);
  116.  
  117.   SaveDC(DC);
  118.  
  119.   FontRec := CornerFontRec;
  120.   SetBkMode(DC, Transparent);
  121.   SetTextColor(DC, RGB(128,128,128));
  122.   FontRec.lfHeight := FontRec.lfHeight * 2;
  123.   FontRec.lfWidth := Trunc(FontRec.lfWidth * 2.1);
  124.   SelectObject(DC, CreateFontIndirect(FontRec));
  125.   TextOut(DC, 18, 5, 'T', 1);
  126.   SetTextColor(DC, RGB(0,0,0));
  127.   TextOut(DC, 32, 13,'T', 1);
  128.  
  129.   GetClientRect(HWindow, R);
  130.   FontRec := MainFontRec;
  131.   DeleteObject(SelectObject(DC, CreateFontIndirect(FontRec)));
  132.   GetOutlineTextMetrics(DC, sizeof(FontMetric), FontMetric);
  133.   FontHeight := FontMetric.otmTextMetrics.tmHeight;
  134.   SetViewportOrg(DC, FontHeight+2, 0);
  135.   Dec(R.Right, FontHeight+2);
  136.   BaseWidth := LoWord(GetTextExtent(DC, FanText, FanTextLen));
  137.  
  138.   SelectObject(DC, GetStockObject(Null_Brush));
  139.   if ShowAlignmentMarks then Ellipse(DC, -R.right, -R.Bottom, R.Right, R.Bottom);
  140.   Ellipse(DC, -(Radius-5), -(Radius-5), (Radius-5), Radius-5);
  141.   Ellipse(DC, -(Radius-10), -(Radius-10), (Radius-10), Radius-10);
  142.  
  143.   SetTextColor(DC, FanColor[0]);
  144.   for d:= 27 to 36 do
  145.   begin
  146.     x := Round(Radius * cos(d * Deg2Rad));
  147.     y := Round(Radius * sin(-d * Deg2Rad)); { -d because y axis is inverted }
  148.  
  149.     Theta := -d * deg2rad;
  150.     if (X <> 0) then
  151.       Theta := ArcTan((R.Right / R.Bottom) * (Y / X));
  152.     j := Round(R.Right * cos(Theta));
  153.     k := Round(R.Bottom * sin(Theta));
  154.  
  155.     if ShowAlignmentMarks then
  156.     begin
  157.       MoveTo(DC, x,y);
  158.       LineTo(DC, j,k);
  159.     end;
  160.  
  161.     { Calculate how long the displayed string should be }
  162.     DesiredExtent := Round(Sqrt(Sqr(x*1.0-j) + Sqr(y*1.0-k))) - 5;
  163.     FontRec := MainFontRec;
  164.     FontRec.lfEscapement := d * 100;
  165.     FontRec.lfWidth := Trunc((FontMetric.otmTextMetrics.tmAveCharWidth) * (DesiredExtent / BaseWidth));
  166.     DeleteObject(SelectObject(DC, CreateFontIndirect(FontRec)));
  167.     Longint(TE) := GetTextExtent(DC, FanText, FanTextLen);
  168.  
  169.     { Shave off some character width until the string fits }
  170.     while (TE.W > DesiredExtent) and (FontRec.lfWidth <> 0) do
  171.     begin
  172.       Dec(FontRec.lfWidth);
  173.       DeleteObject(SelectObject(DC, CreateFontIndirect(FontRec)));
  174.       Longint(TE) := GetTextExtent(DC, FanText, FanTextLen);
  175.     end;
  176.  
  177.     { Expand the string if necessary to make it fit the desired extent }
  178.     if TE.W < DesiredExtent then
  179.       SetTextJustification(DC,DesiredExtent - TE.W, 3);
  180.     if ShadowAll then
  181.     begin
  182.       SetTextColor(DC, RGB(0,0,0));
  183.       TextOut(DC, x+2, y+1, FanText, FanTextLen);
  184.     end;
  185.     SetTextColor(DC, FanColor[d - 27]);
  186.     TextOut(DC, x, y, FanText, FanTextLen);
  187.     SetTextJustification(DC,0,0);  { clear justifier's internal error accumulator }
  188.  
  189.     if P[0] <> #0 then
  190.     begin
  191.       FontRec := CornerFontRec;
  192.       FontRec.lfEscapement := (d+10) * 100;
  193.       FontRec.lfWidth := 0;
  194.       DeleteObject(SelectObject(DC, CreateFontIndirect(FontRec)));
  195.       SetTextColor(DC, 0);
  196.       x := Round((Radius - FontHeight - 5) * cos(d * Deg2Rad));
  197.       y := Round((Radius - FontHeight - 5) * sin(-d * Deg2Rad));
  198.       TextOut(DC, x, y, P, 1);
  199.       inc(P);
  200.     end;
  201.   end;
  202.  
  203.   DeleteObject(SelectObject(DC, CreateFontIndirect(BorlandFontRec)));
  204.   Longint(TE) := GetTextExtent(DC, BorlandText, StrLen(BorlandText));
  205.   SetTextColor(DC, RGB(0,0,0));
  206.   TextOut(DC, R.Right - TE.W, R.Bottom - TE.H, BorlandText, StrLen(BorlandText));
  207.   SetTextColor(DC, RGB(255,0,0));
  208.   TextOut(DC, R.Right - TE.W - 5, R.Bottom - TE.H, BorlandText, StrLen(BorlandText));
  209.  
  210.   DeleteObject(SelectObject(DC, GetStockObject(System_Font)));
  211.   RestoreDC(DC, -1);
  212. end;
  213.  
  214. procedure TFontWindow.CMAbout(var Msg: TMessage);
  215. begin
  216.   Application^.ExecDialog(new(PDialog, Init(@Self, 'About')));
  217. end;
  218.  
  219. procedure TFontWindow.CMShadows(var Msg: TMessage);
  220. begin
  221.   ShadowAll := not ShadowAll;
  222.   if ShadowAll then
  223.     CheckMenuItem(Attr.Menu, cm_Shadows, mf_ByCommand or mf_Checked)
  224.   else
  225.     CheckMenuItem(Attr.Menu, cm_Shadows, mf_ByCommand or mf_UnChecked);
  226.  
  227.   { Erase if going Shadow -> no Shadow }
  228.   InvalidateRect(HWindow, nil, not ShadowAll);
  229. end;
  230.  
  231. procedure TFontWindow.CMAlignmentMarks(var Msg: TMessage);
  232. begin
  233.   ShowAlignmentMarks := not ShowAlignmentMarks;
  234.   if ShowAlignmentMarks then
  235.     CheckMenuItem(Attr.Menu, cm_AlignmentMarks, mf_ByCommand or mf_Checked)
  236.   else
  237.     CheckMenuItem(Attr.Menu, cm_AlignmentMarks, mf_ByCommand or mf_UnChecked);
  238.  
  239.   { Erase if going marks -> no marks }
  240.   InvalidateRect(HWindow, nil, not ShowAlignmentMarks);
  241. end;
  242.  
  243. procedure TFontWindow.CMFonts(var Msg: TMessage);
  244. var
  245.   CF: TChooseFont;
  246.   FontRec: TLogFont;
  247. begin
  248.   FontRec := MainFontRec;
  249.   FillChar(CF, Sizeof(CF), #0);
  250.   with CF do
  251.   begin
  252.     lStructSize := SizeOf(TChooseFont);
  253.     HWndOwner := HWindow;
  254.     Flags := cf_AnsiOnly or cf_TTOnly or CF_ScreenFonts;
  255.     nFontType := Screen_FontType;
  256.     lpLogFont := @FontRec;
  257.   end;
  258.   if ChooseFont(CF) then
  259.   begin
  260.     { Only get the font name - we don't care what size the user selected }
  261.     StrCopy(MainFontRec.lfFaceName, FontRec.lfFaceName);
  262.     InvalidateRect(HWindow, nil, True);
  263.   end;
  264. end;
  265.  
  266. procedure TFontWindow.WMGetMinMaxInfo(var Msg: TMessage);
  267. type
  268.   TPointArray = array [0..4] of TPoint;
  269.   PPointArray = ^TPointArray;
  270. begin
  271.   { Limit the minimum size of the window to 300x300, so the fonts don't
  272.     get too small }
  273.   PPointArray(Msg.LParam)^[3].X := 300;
  274.   PPointArray(Msg.LParam)^[3].Y := 300;
  275. end;
  276.  
  277. type
  278.   { Define a TApplication descendant }
  279.   TFontApp = object(TApplication)
  280.     procedure InitMainWindow; virtual;
  281.   end;
  282.  
  283. { Construct the TFontApp's MainWindow object }
  284. procedure TFontApp.InitMainWindow;
  285. begin
  286.   MainWindow := New(PFontWindow, Init(nil, 'TrueType Font lab'));
  287. end;
  288.  
  289. { Declare a variable of type TFontApp }
  290. var
  291.   FontApp: TFontApp;
  292.  
  293. { Run the FontApp }
  294. begin
  295.   FontApp.Init('TrueType Font Lab');
  296.   FontApp.Run;
  297.   FontApp.Done;
  298. end.
  299.