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
128
129
130
131
132
133
134
135
136
137
138
|
{
*****************************************************************************
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,
FileUtil, LazFileUtils, LazUTF8,
EasyLazFreeType, LazFreeTypeFontCollection;
procedure InitFonts(AFontDir: string = '');
function LoadFont(AFontName: String; AStyle: TFreeTypeStyles): TFreeTypeFont;
implementation
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}
{$IFDEF LCLCarbon}
AList.Add('/Library/Fonts/');
AList.Add('/System/Library/Fonts/');
AList.Add('/Network/Library/Fonts/');
AList.Add('~/Library/Fonts/');
{$ENDIF}
{$IFDEF LCLCocoa}
AList.Add('/Library/Fonts/');
AList.Add('/System/Library/Fonts/');
AList.Add('/Network/Library/Fonts/');
AList.Add('~/Library/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: TStringListUTF8Fast;
i: integer;
begin
AFolder := ExpandFileName(AFolder);
if (length(AFolder) <> 0) and (AFolder[length(AFolder)] <> PathDelim) then
AFolder += PathDelim;
files := TStringListUTF8Fast.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.
|
