paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-20 11:29:27 +02:00
Code Issues Packages Projects Releases Wiki Activity

* Some reworking by Graeme Geldenhuys:

Browse Source 
ttf: renamed SearchForFont() to SearchForFonts(). Plural makes more sense.
  ttf: extra sanity check before calling SearchForFont()
  ttf: new AssignFontList() method introduced.
       This populates AStrings with a list of found PostScript names. 
       Useful for fpReport and probably a visual report designer too.
  ttf: new overloaded Find() method, and Find-by-PostScript name.
       FamilyName is normally the base font name only. 
       PostScriptName is the base name plus an attribute suffix. 
       eg: Calibri vs Calibri-Bold

git-svn-id: trunk@33563 -
This commit is contained in:
michael 2016-04-27 15:34:00 +00:00
parent c365576841
commit 5ac352bc3c
1 changed files with 36 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

42
packages/fcl-pdf/src/fpttf.pp
View File

@ -37,6 +37,7 @@ type
FStyleFlags: TTrueTypeFontStyles;
FFileInfo: TTFFileInfo;
FOwner: TFPFontCacheList; // reference to FontCacheList that owns this instance
FPostScriptName: string;
procedure BuildFontCacheItem;
procedure SetStyleIfExists(var AText: string; var AStyleFlags: TTrueTypeFontStyles; const AStyleName: String; const AStyle: TTrueTypeFontStyle);
function GetIsBold: boolean;
@ -50,6 +51,7 @@ type
function TextWidth(AStr: utf8string; APointSize: single): single;
property FileName: String read FFileName;
property FamilyName: String read FFamilyName;
property PostScriptName: string read FPostScriptName;
property FontData: TTFFileInfo read FFileInfo;
{ A bitmasked value describing the full font style }
property StyleFlags: TTrueTypeFontStyles read FStyleFlags;
@ -66,7 +68,7 @@ type
FList: TObjectList;
FSearchPath: TStringList;
FDPI: integer;
procedure SearchForFont(const AFontPath: String);
procedure SearchForFonts(const AFontPath: String);
procedure SetDPI(AValue: integer);
protected
function GetCount: integer; virtual;
@ -77,11 +79,13 @@ type
destructor Destroy; override;
procedure BuildFontCache;
function Add(const AObject: TFPFontCacheItem): integer;
procedure AssignFontList(const AStrings: TStrings);
procedure Clear;
property Count: integer read GetCount;
function IndexOf(const AObject: TFPFontCacheItem): integer;
function Find(const AFontCacheItem: TFPFontCacheItem): integer;
function Find(const AFamilyName: string; ABold: boolean = False; AItalic: boolean = False): TFPFontCacheItem;
function Find(const AFontCacheItem: TFPFontCacheItem): integer; overload;
function Find(const AFamilyName: string; ABold: boolean; AItalic: boolean): TFPFontCacheItem; overload;
function Find(const APostScriptName: string): TFPFontCacheItem; overload;
{ not used: utility function doing a conversion for us. }
function PointSizeInPixels(const APointSize: single): single;
property Items[AIndex: Integer]: TFPFontCacheItem read GetItem write SetItem; default;
@ -138,6 +142,7 @@ var
s: string;
begin
s := FFileInfo.PostScriptName;
FPostScriptName := s;
FFamilyName := FFileInfo.FamilyName;
if Pos(s, FFamilyName) = 1 then
Delete(s, 1, Length(FFamilyName));
@ -272,7 +277,7 @@ end;
{ TFPFontCacheList }
procedure TFPFontCacheList.SearchForFont(const AFontPath: String);
procedure TFPFontCacheList.SearchForFonts(const AFontPath: String);
var
sr: TSearchRec;
lFont: TFPFontCacheItem;
@ -287,7 +292,7 @@ begin
// We got something, so lets continue
s := sr.Name;
if (sr.Attr and faDirectory) <> 0 then // found a directory
SearchForFont(IncludeTrailingPathDelimiter(AFontPath + s))
SearchForFonts(IncludeTrailingPathDelimiter(AFontPath + s))
else
begin // we have a file
if (lowercase(ExtractFileExt(s)) = '.ttf') or
@ -349,7 +354,8 @@ begin
for i := 0 to FSearchPath.Count-1 do
begin
lPath := FSearchPath[i];
SearchForFont(IncludeTrailingPathDelimiter(lPath));
if DirectoryExists(lPath) then
SearchForFonts(IncludeTrailingPathDelimiter(lPath));
end;
end;
@ -359,6 +365,17 @@ begin
AObject.FOwner := self;
end;
procedure TFPFontCacheList.AssignFontList(const AStrings: TStrings);
var
i: integer;
begin
if not Assigned(AStrings) then
Exit;
AStrings.Clear;
for i := 0 to FList.Count-1 do
AStrings.Add(TFPFontCacheItem(FList.Items[i]).PostScriptName);
end;
procedure TFPFontCacheList.Clear;
begin
FList.Clear;
@ -400,6 +417,19 @@ begin
Result := nil;
end;
function TFPFontCacheList.Find(const APostScriptName: string): TFPFontCacheItem;
var
i: integer;
begin
for i := 0 to Count-1 do
begin
Result := Items[i];
if (Result.PostScriptName = APostScriptName) then
Exit;
end;
Result := nil;
end;
function TFPFontCacheList.PointSizeInPixels(const APointSize: single): single;
begin
Result := APointSize * DPI / 72;