Home page > Delphi, tips bulk > For MS-Windows > FontUtils: managing fonts

FontUtils: managing fonts

Wednesday 7 September 2011, by CapJack

This Delphi unit has some useful features for managing fonts and text attributes. You can turn them into descriptive strings and vice versa, list all fonts or only the TrueType fonts.

Compatibility:
Delphi all non-.NET versions, including XE2.
Lazarus 32/64 bits, from 0.9.25, tested on 0.9.30.

Target platform:
Windows 32/64 bits.

I’m not asking anything in return for this work, except a small link to my site if you find it useful and use it in your software.

  1. (*********************************************************)
  2. (***)                                                 (***)
  3. (***)                UNIT FontUtils;                  (***)
  4. (***)                                                 (***)
  5. (*********************************************************)
  6.  
  7. (*********************************************************)
  8. (* Feel free to use it, but at your own risk!            *)
  9. (* À utiliser librement, mais à vos risques et périls !  *)
  10. (* CapJack.                                              *)
  11. (*********************************************************)
  12.  
  13.  
  14. (*********************************************************)
  15. (***)                                                 (***)
  16. (***)                  INTERFACE                      (***)
  17. (***)                                                 (***)
  18. (*********************************************************)
  19.  
  20. {$WARN UNIT_PLATFORM OFF}
  21. {$IFDEF MSWindows}
  22.  {$IFDEF FPC} // Lazarus / Free Pascal
  23.    uses SysUtils, Classes, Windows, Graphics,
  24.         Forms, LCLProc;
  25.  {$ELSE} // Delphi
  26.   {$IFDEF DCC} // Delphi XE2 Win 32/64
  27.    uses System.SysUtils, System.Classes,
  28.         WinAPI.Windows,VCL.Graphics,
  29.         VCL.ComCtrls, VCL.Forms;
  30.   {$ELSE} // Delphi other
  31.    uses Windows, SysUtils, Classes,
  32.         Graphics, ComCtrls, Forms;
  33.   {$ENDIF DCC}
  34.  {$ENDIF FPC}
  35. {$ELSE}
  36.  'MS-Windows only!'
  37. {$ENDIF MSWindows}
  38.  
  39.  
  40. {$IFDEF FPC}
  41. type
  42.         TTextAttributes = record
  43.          Charset : TFontCharset;
  44.          Color   : TColor;
  45.          Name    : TFontName;
  46.          Pitch   : TFontPitch;
  47.          Size    : Integer;
  48.          Style   : TFontStyles;
  49.          Height  : Integer;
  50.         end;
  51. {$ENDIF FPC}
  52.  
  53. const
  54.         // Descriptor of a default font.
  55.         // Descripteur d'une police par défaut.
  56.         DTDefFontStr = 'Tahoma,8,,Black';
  57.  
  58.         DTTrueTypeSizes = '8'#13#10'9'#13#10'10'#13#10 +
  59.                           '11'#13#10'12'#13#10'14'#13#10 +
  60.                           '16'#13#10'18'#13#10'20'#13#10 +
  61.                           '22'#13#10'24'#13#10'26'#13#10 +
  62.                           '28'#13#10'36'#13#10'48'#13#10 +
  63.                           '72'#13#10;
  64.  
  65.         // Flag used to indicate a TrueType font.
  66.         // Flag utilisé pour marquer une police TrueType
  67.         _ISTRUETYPE=$04;
  68.  
  69.  
  70. (*********************************************************)
  71. (* DTColorToIdent                                        *)
  72. (* ------------------------------------------------------*)
  73. (* Returns the identifier of a color as a string.        *)
  74. (* The standard Delphi colors are recognized,            *)
  75. (* with "cl" prefix removed.                             *)
  76. (* ------------------------------------------------------*)
  77. (* Renvoie l'identificateur d'une couleur sous forme de  *)
  78. (* chaîne. Les couleurs standards de Delphi sont         *)
  79. (* reconnues, préfixe "cl" ôté.                          *)
  80. (*********************************************************)
  81.  
  82. function  DTColorToIdent(Color : TColor) : string;
  83.  
  84. (*********************************************************)
  85. (* DTIdentToColor                                        *)
  86. (* ------------------------------------------------------*)
  87. (* Transforms a string identifier in color.              *)
  88. (* ------------------------------------------------------*)
  89. (* Transforme un identificateur chaîne en couleur.       *)
  90. (*********************************************************)
  91.  
  92. function  DTIdentToColor
  93.                  (Ident:String;DefColor:TColor=0) : TColor;
  94.  
  95. (*********************************************************)
  96. (* DTDefFont                                             *)
  97. (* ------------------------------------------------------*)
  98. (* Default Font described in DTDefFontStr.               *)
  99. (* ------------------------------------------------------*)
  100. (* Police par défaut décrite dans DTDefFontStr.          *)
  101. (*********************************************************)
  102.  
  103. var DTDefFont : TFont;
  104.  
  105.  
  106. (*********************************************************)
  107. (* DTEnumerateFonts                                      *)
  108. (* ------------------------------------------------------*)
  109. (* Lists the fonts of the system.                        *)
  110. (* ------------------------------------------------------*)
  111. (* Énumère les polices de caractères du système.         *)
  112. (*********************************************************)
  113.  
  114. procedure DTEnumerateFonts
  115.           (
  116.            const S          : TStrings
  117.           );
  118.  
  119. (*********************************************************)
  120. (* DTFontStylesToStr                                     *)
  121. (* ------------------------------------------------------*)
  122. (* Transforms a set of font attributes in a simple       *)
  123. (* string, ex. "BI". "B" => fsBold "I" => fsItalic       *)
  124. (* "U" => fsUnderline "S" => fsStrikeOut                 *)
  125. (* ------------------------------------------------------*)
  126. (* Transforme un ensemble d'attributs de police en       *)
  127. (* chaîne simple, ex. "BI". "B"=>fsBold  "I"=>fsItalic   *)
  128. (* "U"=>fsUnderline  "S"=>fsStrikeOut                    *)
  129. (*********************************************************)
  130.  
  131. function  DTFontStylesToStr
  132.           (
  133.            const FontStyles : TFontStyles
  134.           ) : string;
  135.  
  136. (*********************************************************)
  137. (* DTStrToFontStyles                                     *)
  138. (* ------------------------------------------------------*)
  139. (* Transforms a simple string, ex. "BI", in font         *)
  140. (* attributes. "B" => fsBold "I" => fsItalic             *)
  141. (* "U" => fsUnderline "S" => fsStrikeOut                 *)
  142. (* ------------------------------------------------------*)
  143. (* Transforme une chaîne simple, ex. "BI" en ensemble    *)
  144. (* d'attributs de police. "B"=>fsBold  "I"=>fsItalic     *)
  145. (* "U"=>fsUnderline  "S" => fsStrikeOut                  *)
  146. (*********************************************************)
  147.  
  148. function  DTStrToFontStyles
  149.           (
  150.            const S          : string
  151.           ) : TFontStyles;
  152.  
  153. (*********************************************************)
  154. (* DTAttrToStr                                           *)
  155. (* ------------------------------------------------------*)
  156. (* Transforms a variable of type TTextAttributes         *)
  157. (* in descriptive string.                                *)
  158. (* ------------------------------------------------------*)
  159. (* Transforme une variable de type TTextAttributes       *)
  160. (* en chaîne descriptive.                                *)
  161. (*********************************************************)
  162.  
  163. function  DTAttrToStr
  164.           (
  165.            const Attr       : TTextAttributes
  166.           ) : string;
  167.  
  168. (*********************************************************)
  169. (* DTFontToStr                                           *)
  170. (* ------------------------------------------------------*)
  171. (* Transforms the attributes of a font                   *)
  172. (* in descriptive string.                                *)
  173. (* ------------------------------------------------------*)
  174. (* Transforme les attributs d'une police de caractères   *)
  175. (* en chaîne descriptive.                                *)
  176. (*********************************************************)
  177.  
  178. function  DTFontToStr
  179.           (
  180.            const Font       : TFont
  181.           ) : string;
  182.  
  183. (*********************************************************)
  184. (* DTStrToFont                                           *)
  185. (* ------------------------------------------------------*)
  186. (* Sets the attributes of the descriptive string Str     *)
  187. (* to the given font.                                    *)
  188. (* ------------------------------------------------------*)
  189. (* Affecte les attributs de la chaîne descriptive Str    *)
  190. (* à la police Font.                                     *)
  191. (*********************************************************)
  192.  
  193. procedure DTStrToFont
  194.           (
  195.            const Str        : String;
  196.            const Font       : TFont
  197.           );
  198.  
  199. (*********************************************************)
  200. (* PDTGetFontSizesData, TDTGetFontSizesData              *)
  201. (* ------------------------------------------------------*)
  202. (* Parameters structure for DTGetFontSizes.              *)
  203. (* ------------------------------------------------------*)
  204. (* Structure paramètres pour DTGetFontSizes.             *)
  205. (*********************************************************)
  206.  
  207. type PDTGetFontSizesData = ^TDTGetFontSizesData;
  208.      TDTGetFontSizesData =
  209.         record
  210.          IsTrueType : Boolean;
  211.          Sizes      : TStrings;
  212.         end;
  213.  
  214. (*********************************************************)
  215. (* DTGetFontSizes                                        *)
  216. (* ------------------------------------------------------*)
  217. (* Returns the sizes allowed for a given font.           *)
  218. (* ------------------------------------------------------*)
  219. (* Renvoie les tailles autorisées pour une police donnée.*)
  220. (*********************************************************)
  221.  
  222. procedure DTGetFontSizes
  223.           (
  224.            const FontName   : String;
  225.            const SizesList  : TStrings;
  226.            var   IsTrueType : Boolean
  227.           ) ; overload;
  228.  
  229. procedure DTGetFontSizes
  230.           (
  231.            const FontName   : string;
  232.            const SizesList  : TStrings
  233.           ) ; overload;
  234.  
  235.  
  236.  
  237. (*********************************************************)
  238. (***)                                                 (***)
  239. (***)                 IMPLEMENTATION                  (***)
  240. (***)                                                 (***)
  241. (*********************************************************)
  242.  
  243.  
  244. // Utility for cross-compiler compatibility, while
  245. // Lazarus will not accept string->PChar UTF8 typecasting.
  246. // Pointer should be deallocated by StrDispose.
  247. //
  248. // Utilitaire de compatibilité inter-compilateurs.
  249. // Lazarus n'accepte pas le transtypage UTF8 string->PChar.
  250. // Le pointeur fourni devra être désalloué par StrDispose.
  251. //
  252. function DTStrCopy(const AString:string):PChar;
  253.  begin
  254.   // Works under Delphi Ansi/Unicode,
  255.   // but works also with Lazarus, because for Lazarus,
  256.   // length() returns the SIZE of the UTF8 string...
  257.   //
  258.   // Fonctionne sous Delphi Ansi/Unicode,
  259.   // mais marche aussi sous Lazarus, car sous Lazarus,
  260.   // length() renvoie la TAILLE en octets de la chaîne.
  261.   //
  262.   Result := StrAlloc( (Length(AString)+1) * SizeOf(Char) );
  263.   Result := StrPCopy(Result,AString);
  264.  end;
  265.  
  266. (*********************************************************)
  267.  
  268. function  DTColorToIdent(Color : TColor) : string;
  269.  begin
  270.   Result := ColorToString(Color);
  271.   if Result = ''
  272.      then exit
  273.      else if Result[1]='$'
  274.              then Result[1] := '#'
  275.              else if Copy(Result,1,2)='cl'
  276.                   then Delete(Result,1,2);
  277.  end;
  278.  
  279. (*********************************************************)
  280.  
  281. function  DTIdentToColor
  282.             (Ident:String;DefColor:TColor=clBlack): TColor;
  283.  begin
  284.   if Ident = '' then begin Result := DefColor; Exit end;
  285.   if not IdentToColor('cl'+Ident,Integer(Result)) then
  286.   if not IdentToColor(Ident,Integer(Result)) then
  287.    begin
  288.     if Ident[1] = '#'
  289.        then Ident[1] := '$';
  290.     if not TryStrToInt(Ident,Integer(Result))
  291.        then Result := DefColor;
  292.    end;
  293.  end;
  294.  
  295. (*********************************************************)
  296.  
  297. procedure DTEnumerateFonts(const S:TStrings);
  298.  begin
  299.   S.Assign(Screen.Fonts);
  300.  end;
  301.  
  302. (*********************************************************)
  303.  
  304. function  DTFontStylesToStr
  305.                     (const FontStyles:TFontStyles): string;
  306.  begin
  307.   Result := '';
  308.   if fsBold      in FontStyles then Result := Result + 'B';
  309.   if fsItalic    in FontStyles then Result := Result + 'I';
  310.   if fsUnderline in FontStyles then Result := Result + 'U';
  311.   if fsStrikeOut in FontStyles then Result := Result + 'S';
  312.  end;
  313.  
  314. (*********************************************************)
  315.  
  316. function  DTStrToFontStyles(const S:string):TFontStyles;
  317.  var I : Integer;
  318.  begin
  319.   Result := [];
  320.   for I := 1 to length(S) do
  321.   case UpCase(S[I]) of
  322.         'B' : Result := Result + [fsBold];
  323.         'I' : Result := Result + [fsItalic];
  324.         'U' : Result := Result + [fsUnderline];
  325.         'S' : Result := Result + [fsStrikeOut];
  326.   end
  327.  end;
  328.  
  329. (*********************************************************)
  330.  
  331. function  DTFontToStr(const Font:TFont):string;
  332.  var S:TStringList;
  333.  begin
  334.   S := TStringList.Create;
  335.   with Font do
  336.    begin
  337.     S.Add(Name);
  338.     S.Add(IntToStr(Size));
  339.     S.Add(DTFontStylesToStr(Style));
  340.     S.Add(DTColorToIdent(Color));
  341.    end;
  342.   Result := S.CommaText;
  343.   S.Free;
  344.  end;
  345.  
  346. (*********************************************************)
  347.  
  348. function  DTAttrToStr(const Attr:TTextAttributes):string;
  349.  var S:TStringList;
  350.  begin
  351.   S := TStringList.Create;
  352.   with Attr do
  353.    begin
  354.     S.Add(Name);
  355.     S.Add(IntToStr(Size));
  356.     S.Add(DTFontStylesToStr(Style));
  357.     S.Add(DTColorToIdent(Color));
  358.    end;
  359.   Result := S.CommaText;
  360.   S.Free;
  361.  end;
  362.  
  363. (*********************************************************)
  364.  
  365. procedure DTStrToFont(const Str:String;const Font : TFont);
  366.  var S:TStringList;FontSize : Integer;
  367.  begin
  368.   S := TStringList.Create;
  369.   S.CommaText := Str;
  370.   FontSize := 0;
  371.   with Font do
  372.    begin
  373.     if S.Count > 0
  374.        then Name := S[0]
  375.        else Name := DTDefFont.Name;
  376.     if ( (S.Count > 1) and TryStrToInt(S[1],FontSize) )
  377.        then Size := FontSize
  378.        else Size := DTDefFont.Size;
  379.     if S.Count > 2
  380.        then Style := DTStrToFontStyles(S[2])
  381.        else Style := DTDefFont.Style;
  382.     if S.Count > 3
  383.        then Color := DTIdentToColor(S[3])
  384.        else Color := DTDefFont.Color;
  385.    end;
  386.   S.Free;
  387.  end;
  388.  
  389. (*********************************************************)
  390.  
  391. var DTGetFontSizesDataList : TList;
  392.  
  393. function  EnumFontSizes(var EnumLogFont: TEnumLogFont;
  394.                         var TextMetric: TNewTextMetric;
  395.                         FontType:longint;
  396.                         DataIndex:LParam):longint;
  397.                         export; stdcall;
  398. var
  399.   Data  : PDTGetFontSizesData;
  400.   size  : String;
  401.   i, s  : Integer;
  402.   value : Integer;
  403. begin
  404.   Data := DTGetFontSizesDataList[DataIndex];
  405.   Data^.IsTrueType := false;
  406.   with Data^ do
  407.   if (FontType and TRUETYPE_FONTTYPE)<>0
  408.    then begin
  409.          if assigned(Sizes)
  410.             then Sizes.Text := DTTrueTypeSizes;
  411.          IsTrueType := True;
  412.          Result := 0
  413.         end
  414.    else if not(Assigned(Sizes))
  415.          then Result := 0
  416.          else begin
  417.                s := Round( (EnumLogFont.elfLogFont.lfHeight
  418.                             - TextMetric.tmInternalLeading)
  419.                            * 72 / Screen.PixelsPerInch);
  420.                size := IntToStr(s);
  421.                Result := 1;
  422.                for i := 0 to Sizes.Count - 1 do
  423.                 begin
  424.                  value := StrToInt(Sizes[I]);
  425.                  if value = s then Exit;
  426.                  if value > s
  427.                     then begin
  428.                           Sizes.Insert(i, size);
  429.                           Exit
  430.                          end
  431.                 end;
  432.                Sizes.Add(size);
  433.               end;
  434. end;
  435.  
  436. (*********************************************************)
  437.  
  438. procedure DTGetFontSizes(const FontName: String;
  439.                          const SizesList: TStrings;
  440.                          var IsTrueType:Boolean);
  441. var
  442.   DC   : HDC;
  443.   Data : TDTGetFontSizesData;
  444.   DataIndex : Integer;
  445.   FontNamePtr:PChar;
  446. begin
  447.   Data.IsTrueType:=false;
  448.   FillChar(Data,SizeOf(Data),0);
  449.   Data.Sizes := SizesList;
  450.   Data.Sizes.BeginUpdate;
  451.   DataIndex := DTGetFontSizesDataList.Add(@Data);
  452.   DC := GetDC(0);
  453.   try
  454.     Data.Sizes.Clear;
  455.     if FontName <> '' then
  456.      begin
  457.       FontNamePtr := DTStrCopy( FontName );
  458.       EnumFontFamilies(DC, FontNamePtr,
  459.                        @EnumFontSizes, DataIndex);
  460.       StrDispose(FontNamePtr);
  461.      end;
  462.   finally
  463.     ReleaseDC(0, DC);
  464.     Data.Sizes.EndUpdate;
  465.     IsTrueType := Data.IsTrueType;
  466.     DTGetFontSizesDataList.Delete(DataIndex);
  467.   end;
  468. end;
  469.  
  470. (*********************************************************)
  471.  
  472. procedure DTGetFontSizes(const FontName: String;
  473.                          const SizesList: TStrings);
  474. var IsTrueType : Boolean;
  475. begin
  476.  IsTrueType:=False;
  477.  DTGetFontSizes(FontName,SizesList,IsTrueType);
  478. end;
  479.  
  480. (*********************************************************)
  481.  
  482. function  IsTrueType(DC: HDC): Boolean; overload;
  483. var
  484.   LMetric: TTextMetric;
  485. begin
  486.   LMetric.tmCharSet:=0;
  487.   GetTextMetrics(DC, LMetric);
  488.   result := LMetric.tmPitchAndFamily and _ISTRUETYPE <> 0;
  489. end;
  490.  
  491. (*********************************************************)
  492.  
  493. function  IsTrueType(AFontname: String): Boolean;overload;
  494. var
  495.   LBmp: TBitmap;
  496. begin
  497.   LBmp := TBitmap.Create;
  498.   LBmp.Canvas.Font.Name := AFontname;
  499.   result := IsTrueType(LBmp.Canvas.Handle);
  500.   LBmp.Free;
  501. end;
  502.  
  503. (*********************************************************)
  504.  
  505. INITIALIZATION
  506.  DTDefFont := TFont.Create;
  507.  DTStrToFont(DTDefFontStr,DTDefFont);
  508.  DTGetFontSizesDataList := TList.Create;
  509.  
  510. FINALIZATION
  511.  if assigned(DTDefFont)
  512.     then FreeAndNil(DTDefFont);
  513.  if assigned(DTGetFontSizesDataList)
  514.     then FreeAndNil(DTGetFontSizesDataList);
  515.  
  516. END.