1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
|
{
*****************************************************************************
See the file COPYING.modifiedLGPL.txt, included in this distribution,
for details about the license.
*****************************************************************************
Author: Werner Pamler
- If LazFreeType does not find the fonts needed call InitFonts at the beginning
of the program and specify the path to the font folder as a parameter.
Several folders can be used if separated by LineEnding codes.
}
unit TAFonts;
{$mode objfpc}{$H+}
interface
uses
SysUtils, Classes, EasyLazFreeType;
procedure InitFonts(AFontDir: string = '');
function LoadFont(AFontName: String; AStyle: TFreeTypeStyles): TFreeTypeFont;
implementation
uses
FileUtil, LazFileUtils, LazFreeTypeFontCollection;
var
FontsInitialized: Boolean = false;
procedure PopulateFontDirList(AList: TStrings);
const
CSIDL_FONTS = 20;
var
s: String;
begin
if AList = nil then
raise Exception.Create('PopulateFontDirList: list not allocated.');
{$IFDEF WINDOWS}
s := SHGetFolderPathUTF8(CSIDL_FONTS);
if s <> '' then
AList.Add(s);
{$ENDIF}
{$IFDEF linux}
AList.Add('/usr/share/cups/fonts/');
AList.Add('/usr/share/fonts/truetype/');
AList.Add('/usr/local/lib/X11/fonts/');
AList.Add(GetUserDir + '.fonts/');
{$ENDIF}
end;
function LoadFont(AFontName: String; AStyle: TFreeTypeStyles): TFreeTypeFont;
var
familyItem: TCustomFamilyCollectionItem;
fontItem: TCustomFontCollectionItem;
style: String;
begin
Result := nil;
familyItem := FontCollection.Family[AFontName];
if familyItem <> nil then begin
style := '';
if (ftsBold in AStyle) then style := 'Bold';
if (ftsItalic in AStyle) then style := style + ' Italic';
fontItem := familyItem.GetFont(style);
if fontItem <> nil then begin
Result := fontItem.CreateFont;
Result.Style := AStyle;
end;
end;
end;
procedure InitFonts(AFontDir: String = '');
{ Duplicates functionality in FontCollection.AddFolder in order to be able to
ignore exceptions due to font read errors (occur on Linux Mint with font
NanumMyeongjo.ttf) }
procedure AddFolder(AFolder: string);
var
files: TStringList;
i: integer;
begin
AFolder := ExpandFileName(AFolder);
if (length(AFolder) <> 0) and (AFolder[length(AFolder)] <> PathDelim) then
AFolder += PathDelim;
files := TStringList.Create;
FontCollection.BeginUpdate;
try
FindAllFiles(files, AFolder, '*.ttf', true);
files.Sort;
for i := 0 to files.Count-1 do
try
FontCollection.AddFile(files[i]);
except
end;
finally
FontCollection.EndUpdate;
files.Free;
end;
end;
var
i: Integer;
fontDirList: TStrings;
begin
if FontsInitialized then
exit;
fontDirList := TStringList.Create;
try
PopulateFontDirList(fontDirList);
if AFontDir <> '' then
fontDirList.Text := AFontDir;
for i:=0 to fontDirList.Count-1 do
AddFolder(fontDirList[i]);
FontsInitialized := true;
finally
fontDirList.Free;
end;
end;
end.
|
