 {
 ****************************************************************************
 CRW32 project
 Copyright (C) by Kuryakin Alexey, Sarov, Russia, 2016, <kouriakine@mail.ru>
 Fonts routines: font check, search, embed to application from resource etc.
 Modifications:
 20160425 - Creation & test
 20160917 - TEmbeddedFont, TEmbeddedFontList, FullEmbeddedFontList
 ****************************************************************************
 }
unit _fonts; // Fonts routines.

{$I _sysdef}

interface

uses
 Windows,Messages,SysUtils,_alloc,_str,_fio,_dynar;

 //
 // GetSpecialShellFolderPath(CSIDL) - return special system directory by CSIDL identifier.
 // GetSystemFontsPath               - return Fonts system directory, like c:\Windows\Fonts.
 //                                  - that is special system directory by CSIDL_FONTS.
 //
function  GetSpecialShellFolderPath(CSIDL:Word):LongString;
function  GetSystemFontsPath:LongString;

 //
 // GetSystemFontsAsText(Charset,Pitch,Name) - enumerate system fonts and returns CR,LF delimited
 //                                   - list of system fonts by given charset, pitch and name.
 //                                   - name parameter specifies search pattern for font face name.
 //                                   - all fonts started from this pattern will be enumerated.
 // TheSystemFonts(Charset,Pitch)     - fast buffered version of GetSystemFontsAsText which return
 //                                   - CR,LF delimited list of system fonts from buffer after 1st
 //                                   - call. On 1st call GetSystemFontsAsText uses for enumeration.
 // TheSystemFontsReset               - clear TheSystemFonts's buffers to update list of fonts.
 // TheSystemFontsFree                - free TheSystemFontsFree's buffers.
 //
function  GetSystemFontsAsText(Charset:Integer=DEFAULT_CHARSET; Pitch:Integer=DEFAULT_PITCH; const Name:LongString=''):LongString;
function  TheSystemFonts(Charset:Integer=DEFAULT_CHARSET; Pitch:Integer=DEFAULT_PITCH):LongString;
procedure TheSystemFontsReset;
procedure TheSystemFontsFree;

 //
 // SystemFontsFound(Charset,Pitch,Name) - search fonts with given charset, pitch and name.
 //                                    - return true if specified font found. name parameter may be
 //                                    - empty, it means "any name".
 //
function SystemFontsFound(Charset:Integer=DEFAULT_CHARSET; Pitch:Integer=DEFAULT_PITCH; const Name:LongString=''):Integer;

 //
 // GetTextFaceName(dc)               - return current font uses by device context dc.
 // PostBroadcastFontChange           - post WM_FONTCHANGE broadcast to update system fonts.
 // AddSystemFont(FontPath,Post)      - add    font resource file FontPath and post message.
 // RemoveSystemFont(FontPath,Post)   - remove font resource file FontPath and post message.
 //
function  GetTextFaceName(dc:HDC):LongString;
procedure PostBroadcastFontChange;
function  AddSystemFont(const FontPath:LongString; Post:Bool=False):Integer;
function  RemoveSystemFont(const FontPath:LongString; Post:Bool=False):Integer;

 ///////////////////////////////////////////////////////////////////////////////
 // TEmbeddedFont class uses to embed required fonts to application.
 // Usually not uses by itself but uses as FullEmbeddedFontList member.
 ///////////////////////////////////////////////////////////////////////////////
type
 TEmbeddedFont = class(TMasterObject)
 private
  myNickName     : LongString;
  myFontData     : LongString;
  myFontName     : LongString;
  myFontSource   : LongString;
  myFontTarget   : LongString;
  myFontHand     : THandle;
  myEmbedded     : DWORD;
 private
  function    GetNickName:LongString;
  function    GetFontData:LongString;
  function    GetFontName:LongString;
  function    GetFontFamily:LongString;
  function    GetFontSource:LongString;
  function    GetFontTarget:LongString;
  function    GetFontHand:THandle;
  function    GetEmbedded:DWORD;
 public
  constructor Create(const aNickName,aFontName,aFontSource,aFontTarget:LongString; aEmbed:Boolean=False);
  destructor  Destroy; override;
  procedure   AfterConstruction; override;
  procedure   BeforeDestruction; override;
 public
  procedure   SmartEmbed(Charset:Integer=1; Pitch:Integer=0);     // Embed font if one not found in system
  function    FontEmbed:Integer;                                  // Embed font from resource or file
  procedure   FontFree;                                           // Free (unuse) embedded font
  function    DataLoad:Boolean;                                   // Load FontData from file
  procedure   DataFree;                                           // Free FontData
  function    FontOk:Boolean;                                     // Font is embedded
  function    DataOk:Boolean;                                     // FontData is loaded
  function    Found(Charset:Integer=1; Pitch:Integer=0):Cardinal; // Count system fonts by family
  function    FontSave(Add:Bool=False;Post:Bool=False):Integer;   // Save font file to system directory
 public
  property    NickName   : LongString    read  GetNickName;       // Nickname to identify font
  property    FontData   : LongString    read  GetFontData;       // Font raw data buffer
  property    FontSource : LongString    read  GetFontSource;     // Source font file
  property    FontTarget : LongString    read  GetFontTarget;     // Target font file
  property    FontName   : LongString    read  GetFontName;       // Font full name (with bold,italic,..)
  property    FontFamily : LongString    read  GetFontFamily;     // Font family name (skip bold, italic,..)
  property    FontHand   : THandle       read  GetFontHand;       // Font embed handle
  property    Embedded   : DWORD         read  GetEmbedded;       // Count of embedded fonts
 end;

 ///////////////////////////////////////////////////////////////////////////////
 // TEmbeddedFontList uses as container and master for embedded fonts.
 // Fonts to embed can be located in TTF, OTF or FON files on hard disk.
 // ReadIniFile(IniFile) uses to load fonts and embed it by FontEmbed call.
 // FullEmbeddedFontList contains all EmbeddedFont objects and uses as general
 // master to manipulate embedded fonts.
 // IniFile contains embedded font list described like that (PT fonts family):
 //  [EmbeddedFontList]
 //  EmbeddedFont = FONT_TTF_PTM55F
 //  EmbeddedFont = FONT_TTF_PTM75F
 //  EmbeddedFont = FONT_TTF_PTN57F
 //  EmbeddedFont = FONT_TTF_PTN77F
 //  EmbeddedFont = FONT_TTF_PTS55F
 //  EmbeddedFont = FONT_TTF_PTS56F
 //  EmbeddedFont = FONT_TTF_PTS75F
 //  EmbeddedFont = FONT_TTF_PTS76F
 //  EmbeddedFont = FONT_TTF_PTF55F
 //  EmbeddedFont = FONT_TTF_PTF56F
 //  EmbeddedFont = FONT_TTF_PTF75F
 //  EmbeddedFont = FONT_TTF_PTF76F
 //  [EmbeddedFontName]
 //  FONT_TTF_PTM55F = PT Mono
 //  FONT_TTF_PTM75F = PT Mono Bold
 //  FONT_TTF_PTN57F = PT Sans Narrow
 //  FONT_TTF_PTN77F = PT Sans Narrow Bold
 //  FONT_TTF_PTS55F = PT Sans
 //  FONT_TTF_PTS56F = PT Sans Italic
 //  FONT_TTF_PTS75F = PT Sans Bold
 //  FONT_TTF_PTS76F = PT Sans Bold Italic
 //  FONT_TTF_PTF55F = PT Serif
 //  FONT_TTF_PTF56F = PT Serif Italic
 //  FONT_TTF_PTF75F = PT Serif Bold
 //  FONT_TTF_PTF76F = PT Serif Bold Italic
 //  [EmbeddedFontTarget]
 //  FONT_TTF_PTM55F = PTM55F.ttf
 //  FONT_TTF_PTM75F = PTM75F.ttf
 //  FONT_TTF_PTN57F = PTN57F.ttf
 //  FONT_TTF_PTN77F = PTN77F.ttf
 //  FONT_TTF_PTS55F = PTS55F.ttf
 //  FONT_TTF_PTS56F = PTS56F.ttf
 //  FONT_TTF_PTS75F = PTS75F.ttf
 //  FONT_TTF_PTS76F = PTS76F.ttf
 //  FONT_TTF_PTF55F = PTF55F.ttf
 //  FONT_TTF_PTF56F = PTF56F.ttf
 //  FONT_TTF_PTF75F = PTF75F.ttf
 //  FONT_TTF_PTF76F = PTF76F.ttf
 //  [EmbeddedFontSource]
 //  FONT_TTF_PTM55F = Resource\Fonts\www.paratype.ru\PTMono\PTM55F.ttf
 //  FONT_TTF_PTM75F = Resource\Fonts\www.paratype.ru\PTMono\PTM75F.ttf
 //  FONT_TTF_PTN57F = Resource\Fonts\www.paratype.ru\PTSans\PTN57F.ttf
 //  FONT_TTF_PTN77F = Resource\Fonts\www.paratype.ru\PTSans\PTN77F.ttf
 //  FONT_TTF_PTS55F = Resource\Fonts\www.paratype.ru\PTSans\PTS55F.ttf
 //  FONT_TTF_PTS56F = Resource\Fonts\www.paratype.ru\PTSans\PTS56F.ttf
 //  FONT_TTF_PTS75F = Resource\Fonts\www.paratype.ru\PTSans\PTS75F.ttf
 //  FONT_TTF_PTS76F = Resource\Fonts\www.paratype.ru\PTSans\PTS76F.ttf
 //  FONT_TTF_PTF55F = Resource\Fonts\www.paratype.ru\PTSerif\PTF55F.ttf
 //  FONT_TTF_PTF56F = Resource\Fonts\www.paratype.ru\PTSerif\PTF56F.ttf
 //  FONT_TTF_PTF75F = Resource\Fonts\www.paratype.ru\PTSerif\PTF75F.ttf
 //  FONT_TTF_PTF76F = Resource\Fonts\www.paratype.ru\PTSerif\PTF76F.ttf
 ///////////////////////////////////////////////////////////////////////////////
 // Fonts also can be embedded in EXE file via resources. In this case INI file
 // [EmbeddedFontSource] section should contain EXE file name as source file,
 // [EmbeddedFontList] should contain names of resource linked to EXE file.
 // For example, to embed PT fonts as resources, include resource file:
 //  {$R ptfonts.res}
 // Next command use for ptfonts.res compilation:
 //  brcc32 ptfonts.rc
 // This is example of ptfonts.rc file content:
 //  #pragma code_page(1251)
 //  LANGUAGE LANG_NEUTRAL, SUBLANG_NEUTRAL
 //  FONT_TTF_PTM55F RCDATA Resource\Fonts\www.paratype.ru\PTMono\PTM55F.ttf
 //  FONT_TTF_PTM75F RCDATA Resource\Fonts\www.paratype.ru\PTMono\PTM75F.ttf
 //  FONT_TTF_PTN57F RCDATA Resource\Fonts\www.paratype.ru\PTSans\PTN57F.ttf
 //  FONT_TTF_PTN77F RCDATA Resource\Fonts\www.paratype.ru\PTSans\PTN77F.ttf
 //  FONT_TTF_PTS55F RCDATA Resource\Fonts\www.paratype.ru\PTSans\PTS55F.ttf
 //  FONT_TTF_PTS56F RCDATA Resource\Fonts\www.paratype.ru\PTSans\PTS56F.ttf
 //  FONT_TTF_PTS75F RCDATA Resource\Fonts\www.paratype.ru\PTSans\PTS75F.ttf
 //  FONT_TTF_PTS76F RCDATA Resource\Fonts\www.paratype.ru\PTSans\PTS76F.ttf
 //  FONT_TTF_PTF55F RCDATA Resource\Fonts\www.paratype.ru\PTSerif\PTF55F.ttf
 //  FONT_TTF_PTF56F RCDATA Resource\Fonts\www.paratype.ru\PTSerif\PTF56F.ttf
 //  FONT_TTF_PTF75F RCDATA Resource\Fonts\www.paratype.ru\PTSerif\PTF75F.ttf
 //  FONT_TTF_PTF76F RCDATA Resource\Fonts\www.paratype.ru\PTSerif\PTF76F.ttf
 // IniFile contains embedded font list described like that (PT fonts family):
 //  [EmbeddedFontList]
 //  EmbeddedFont = FONT_TTF_PTM55F
 //  EmbeddedFont = FONT_TTF_PTM75F
 //  EmbeddedFont = FONT_TTF_PTN57F
 //  EmbeddedFont = FONT_TTF_PTN77F
 //  EmbeddedFont = FONT_TTF_PTS55F
 //  EmbeddedFont = FONT_TTF_PTS56F
 //  EmbeddedFont = FONT_TTF_PTS75F
 //  EmbeddedFont = FONT_TTF_PTS76F
 //  EmbeddedFont = FONT_TTF_PTF55F
 //  EmbeddedFont = FONT_TTF_PTF56F
 //  EmbeddedFont = FONT_TTF_PTF75F
 //  EmbeddedFont = FONT_TTF_PTF76F
 //  [EmbeddedFontName]
 //  FONT_TTF_PTM55F = PT Mono
 //  FONT_TTF_PTM75F = PT Mono Bold
 //  FONT_TTF_PTN57F = PT Sans Narrow
 //  FONT_TTF_PTN77F = PT Sans Narrow Bold
 //  FONT_TTF_PTS55F = PT Sans
 //  FONT_TTF_PTS56F = PT Sans Italic
 //  FONT_TTF_PTS75F = PT Sans Bold
 //  FONT_TTF_PTS76F = PT Sans Bold Italic
 //  FONT_TTF_PTF55F = PT Serif
 //  FONT_TTF_PTF56F = PT Serif Italic
 //  FONT_TTF_PTF75F = PT Serif Bold
 //  FONT_TTF_PTF76F = PT Serif Bold Italic
 //  [EmbeddedFontTarget]
 //  FONT_TTF_PTM55F = PTM55F.ttf
 //  FONT_TTF_PTM75F = PTM75F.ttf
 //  FONT_TTF_PTN57F = PTN57F.ttf
 //  FONT_TTF_PTN77F = PTN77F.ttf
 //  FONT_TTF_PTS55F = PTS55F.ttf
 //  FONT_TTF_PTS56F = PTS56F.ttf
 //  FONT_TTF_PTS75F = PTS75F.ttf
 //  FONT_TTF_PTS76F = PTS76F.ttf
 //  FONT_TTF_PTF55F = PTF55F.ttf
 //  FONT_TTF_PTF56F = PTF56F.ttf
 //  FONT_TTF_PTF75F = PTF75F.ttf
 //  FONT_TTF_PTF76F = PTF76F.ttf
 //  [EmbeddedFontSource]
 //  FONT_TTF_PTM55F = Crw32.exe
 //  FONT_TTF_PTM75F = Crw32.exe
 //  FONT_TTF_PTN57F = Crw32.exe
 //  FONT_TTF_PTN77F = Crw32.exe
 //  FONT_TTF_PTS55F = Crw32.exe
 //  FONT_TTF_PTS56F = Crw32.exe
 //  FONT_TTF_PTS75F = Crw32.exe
 //  FONT_TTF_PTS76F = Crw32.exe
 //  FONT_TTF_PTF55F = Crw32.exe
 //  FONT_TTF_PTF56F = Crw32.exe
 //  FONT_TTF_PTF75F = Crw32.exe
 //  FONT_TTF_PTF76F = Crw32.exe
 ///////////////////////////////////////////////////////////////////////////////
type
 TEmbeddedFontList=class(TObjectStorage)
 private
  function    GetEmbeddedFont(i:LongInt):TEmbeddedFont;
  procedure   PutEmbeddedFont(i:LongInt; f:TEmbeddedFont);
  function    GetEmbedded:Integer;
 public
  constructor Create(aOwns:Boolean);
  destructor  Destroy; override;
 public
  function    ReadIniFile(const IniFile   : ShortString;
                          const ThePrefix : ShortString = 'EmbeddedFont';
                          const SecList   : ShortString = '[EmbeddedFontList]';
                          const SecName   : ShortString = '[EmbeddedFontName]';
                          const SecSource : ShortString = '[EmbeddedFontSource]';
                          const SecTarget : ShortString = '[EmbeddedFontTarget]'
                                        ) : Integer;
  procedure   SmartEmbed(Charset:Integer=1; Pitch:Integer=0);      // Embed fonts which not found in system
  function    Found(Charset:Integer=1; Pitch:Integer=0):Integer;   // Count fonts by families
  function    FontSave(Add:Bool=False;Post:Bool=False):Integer;    // Save fonts to system directory
  function    FontEmbed:Integer;                                   // Embed all fonts from resource
  procedure   FontFree;                                            // Free all embedded fonts
  procedure   FontKill;                                            // Kill all embedded font objects
  procedure   DataFree;                                            // Free all font data buffers
 public
  property    EmbeddedFont[i:LongInt]:TEmbeddedFont read GetEmbeddedFont write PutEmbeddedFont; default;
  property    Embedded:Integer read GetEmbedded;                   // Count embedded fonts
 end;

function  NewEmbeddedFontList(aOwns:Boolean=true):TEmbeddedFontList;
procedure Kill(var TheObject:TEmbeddedFontList); overload;

function FullEmbeddedFontList:TEmbeddedFontList; // Contains all embedded fonts

implementation

procedure HandleException(E:Exception);
begin
 if E is Exception then BugReport(E);
end;

function AnsiStrIComp(S1,S2:PChar; MaxLen:Integer=-1):Integer;
begin
 Result:=CompareString(LOCALE_USER_DEFAULT,NORM_IGNORECASE,S1,MaxLen,S2,MaxLen)-2;
end;

function SHGetSpecialFolderPath(hwndOwner: HWND; lpszPath: PChar;  nFolder: Integer;
         fCreate: BOOL): BOOL; stdcall;  external 'shell32.dll' name 'SHGetSpecialFolderPathA'

function GetSpecialShellFolderPath(CSIDL:Word):LongString;
var Buff:array[0..MAX_PATH] of Char;
begin
 if SHGetSpecialFolderPath(0,Buff,CSIDL,True) then Result:=SysUtils.Trim(Buff) else Result:='';
end;

function GetSystemFontsPath:LongString;
const CSIDL_FONTS=$0014;  // ShlObj.pas
begin
 Result:=GetSpecialShellFolderPath(CSIDL_FONTS);
end;

function AllocMem(Size:Cardinal):Pointer;
begin
 Result:=nil;
 if Size>0 then
 try
  GetMem(Result,Size);
  ZeroMemory(Result,Size);
 except
  on E:Exception do begin HandleException(E); Result:=nil; end;
 end;
end;

function ReallocMem(var P:Pointer; Size,Copy:Cardinal):Boolean;
var T,S:Pointer;
begin
 Result:=False;
 try
  T:=AllocMem(Size);
  if Assigned(T) then begin
   if Copy>Size then Copy:=Size;
   if not Assigned(P) then Copy:=0;
   if Copy>0 then MoveMemory(T,P,Copy);
   S:=P; P:=T; FreeMem(S);
   Result:=True;
  end;
 except
  on E:Exception do begin HandleException(E); Result:=False; end;
 end;
end;

type
 TFontFaceName = array[0..LF_FACESIZE-1] of AnsiChar; // Like TLogFont.lfFaceName
 TFontItemsBuf = array[0..1] of TFontFaceName;
 TFontIndexBuf = array[0..1] of Integer;
 TEnumFontsRec = record
  Match:TFontFaceName;
  Pitch:Integer;
  List:record
   Size,Count:Integer;
   Items:^TFontItemsBuf;
   Index:^TFontIndexBuf;
  end;
 end;

function FindFontsProc(var LogFont:TLogFont; var TextMetric:TTextMetric; FontType:Integer; Data:Pointer):Integer; stdcall;
begin
 Result:=1;
 if Assigned(Data) then
 with TEnumFontsRec(Data^) do
 try
  if (Pitch=DEFAULT_PITCH) or (Pitch=(LogFont.lfPitchAndFamily and $F)) then
  if (StrLen(Match)=0) or (AnsiStrIComp(Match,LogFont.lfFaceName)=0) then Inc(List.Count);
 except
  on E:Exception do begin HandleException(E); Result:=0; end;
 end;
end;

function EnumFontsProc(var LogFont:TLogFont; var TextMetric:TTextMetric; FontType:Integer; Data:Pointer):Integer; stdcall;
var NewSize:Integer;
begin
 Result:=1;
 if Assigned(Data) then
 with TEnumFontsRec(Data^) do
 try
  if (List.Count>=List.Size) then begin
   NewSize:=List.Size*2; if NewSize=0 then NewSize:=1024;
   if ReallocMem(Pointer(List.Index),SizeOf(List.Index[0])*NewSize,SizeOf(List.Index[0])*List.Size) then
   if ReallocMem(Pointer(List.Items),SizeOf(List.Items[0])*NewSize,SizeOf(List.Items[0])*List.Size) then
   List.Size:=NewSize;
  end;
  if (List.Count>=List.Size) then Result:=0 else
  if (Pitch=DEFAULT_PITCH) or (Pitch=(LogFont.lfPitchAndFamily and $F)) then
  if (StrLen(Match)=0) or (AnsiStrIComp(Match,LogFont.lfFaceName,StrLen(Match))=0) then
  if (List.Count=0) or (AnsiStrIComp(List.Items[List.Count-1],LogFont.lfFaceName)<>0) then begin
   StrLCopy(List.Items[List.Count],LogFont.lfFaceName,SizeOf(List.Items[0]));
   List.Index[List.Count]:=List.Count;
   Inc(List.Count);
  end;
 except
  on E:Exception do begin HandleException(E); Result:=0; end;
 end;
end;

procedure QuickSort(const Rec:TEnumFontsRec; L,R:Integer);
var I,J,M,T:Integer;
begin
 repeat
  I:=L; J:=R; M:=Rec.List.Index[(L+R) shr 1];
  repeat
   while AnsiStrIComp(Rec.List.Items[Rec.List.Index[I]],Rec.List.Items[M])<0 do Inc(I);
   while AnsiStrIComp(Rec.List.Items[Rec.List.Index[J]],Rec.List.Items[M])>0 do Dec(J);
   if I<=J then begin
    T:=Rec.List.Index[I]; Rec.List.Index[I]:=Rec.List.Index[J]; Rec.List.Index[J]:=T;
    Inc(I); Dec(J);
   end;
  until I>J;
  if L<J then QuickSort(Rec,L,J);
  L:=I;
 until I>=R;
end;

function GetSystemFontsAsText(Charset,Pitch:Integer; const Name:LongString):LongString;
var dc:HDC; LFont:TLogFont; Rec:TEnumFontsRec; i:Integer;
const CRLF = #13#10;
begin
 Result:='';
 try
  dc:=GetDC(0);
  if (dc<>0) then
  try
   ZeroMemory(@Rec,SizeOf(Rec)); Rec.Pitch:=Pitch;
   if Length(Trim(Name))>0 then StrLCopy(Rec.Match,PChar(SysUtils.Trim(Name)),SizeOf(Rec.Match));
   ZeroMemory(@LFont,SizeOf(LFont)); LFont.lfCharset:=Charset;
   EnumFontFamiliesEx(dc,LFont,@EnumFontsProc,LPARAM(@Rec),0);
   if Rec.List.Count>0 then begin
    if Rec.List.Count>1 then QuickSort(Rec,0,Rec.List.Count-1);
    for i:=0 to Rec.List.Count-1 do Result:=Result+(Rec.List.Items[Rec.List.Index[i]]+CRLF);
   end;
  finally
   ReleaseDC(0,dc);
   if Assigned(Rec.List.Index) then FreeMem(Rec.List.Index);
   if Assigned(Rec.List.Items) then FreeMem(Rec.List.Items);
  end;
 except
  on E:Exception do begin HandleException(E); Result:=''; end;
 end;
end;

function SystemFontsFound(Charset,Pitch:Integer; const Name:LongString):Integer;
var dc:HDC; LFont:TLogFont; Rec:TEnumFontsRec;
begin
 Result:=0;
 try
  dc:=GetDC(0);
  if (dc<>0) then
  try
   ZeroMemory(@Rec,SizeOf(Rec)); Rec.Pitch:=Pitch;
   if Length(Trim(Name))>0 then StrLCopy(Rec.Match,PChar(SysUtils.Trim(Name)),SizeOf(Rec.Match));
   ZeroMemory(@LFont,SizeOf(LFont)); LFont.lfCharset:=Charset;
   EnumFontFamiliesEx(dc,LFont,@FindFontsProc,LPARAM(@Rec),0);
   Result:=Rec.List.Count;
  finally
   ReleaseDC(0,dc);
  end;
 except
  on E:Exception do begin HandleException(E); Result:=0; end;
 end;
end;

function GetTextFaceName(dc:HDC):LongString;
var Buff:TFontFaceName;
begin
 if GetTextFace(dc,SizeOf(Buff),Buff)>0 then Result:=Buff else Result:='';
end;

procedure PostBroadcastFontChange;
begin
 PostMessage(HWND_BROADCAST,WM_FONTCHANGE,0,0);
end;

function AddSystemFont(const FontPath:LongString; Post:Bool=False):Integer;
begin
 Result:=0;
 if Length(Trim(FontPath))>0 then
 if FileExists(FontPath) then Result:=AddFontResource(PChar(FontPath));
 if Result>0 then if Post then PostBroadcastFontChange;
end;

function RemoveSystemFont(const FontPath:LongString; Post:Bool=False):Integer;
begin
 Result:=0;
 if Length(Trim(FontPath))>0 then
 if RemoveFontResource(PChar(FontPath)) then Result:=1;
 if Result>0 then if Post then PostBroadcastFontChange;
end;

////////////////
// TEmbeddedFont
////////////////

constructor TEmbeddedFont.Create(const aNickName,aFontName,aFontSource,aFontTarget:LongString; aEmbed:Boolean=False);
begin
 inherited Create;
 myNickName:=Trim(aNickName);
 myFontName:=Trim(aFontName);
 myFontSource:=Trim(aFontSource);
 myFontTarget:=Trim(ExtractFileNameExt(aFontTarget));
 if aEmbed then SmartEmbed;
end;

destructor TEmbeddedFont.Destroy;
begin
 FontFree;
 DataFree;
 myNickName:='';
 myFontData:='';
 myFontName:='';
 myFontSource:='';
 myFontTarget:='';
 inherited Destroy;
end;

procedure TEmbeddedFont.AfterConstruction;
begin
 inherited AfterConstruction;
 FullEmbeddedFontList.Add(Self);
end;

procedure TEmbeddedFont.BeforeDestruction;
begin
 FullEmbeddedFontList.Remove(Self);
 inherited BeforeDestruction;
end;

procedure DeleteStr(var S:LongString; const T:LongString);
var p:Integer;
begin
 p:=Pos(T,S); if p>0 then Delete(S,p,Length(T));
end;

function TEmbeddedFont.GetFontFamily:LongString;
begin
 Result:=FontName;
 DeleteStr(Result,' Oblique');
 DeleteStr(Result,' Italic');
 DeleteStr(Result,' Курсив');
 DeleteStr(Result,' Полужирный');
 DeleteStr(Result,' Обычный');
 DeleteStr(Result,' Bold');
 Result:=SysUtils.Trim(Result);
end;

function TEmbeddedFont.GetNickName:LongString;
begin
 if Assigned(Self) then Result:=myNickName else Result:='';
end;

function TEmbeddedFont.GetFontData:LongString;
begin
 if Assigned(Self) then Result:=myFontData else Result:='';
end;

function TEmbeddedFont.GetFontName:LongString;
begin
 if Assigned(Self) then Result:=myFontName else Result:='';
end;

function TEmbeddedFont.GetFontSource:LongString;
begin
 if Assigned(Self) then Result:=myFontSource else Result:='';
end;

function TEmbeddedFont.GetFontTarget:LongString;
begin
 if Assigned(Self) then Result:=AddBackSlash(GetSystemFontsPath)+myFontTarget else Result:='';
end;

function TEmbeddedFont.GetFontHand:THandle;
begin
 if Assigned(Self) then Result:=myFontHand else Result:=0;
end;

function TEmbeddedFont.GetEmbedded:DWORD;
begin
 if Assigned(Self) then Result:=myEmbedded else Result:=0;
end;

function TEmbeddedFont.FontOk:Boolean;
begin
 if Assigned(Self) then Result:=(FontHand<>0) and (Embedded>0) else Result:=False;
end;

function TEmbeddedFont.DataOk:Boolean;
begin
 if Assigned(Self) then Result:=Length(myFontData)>0 else Result:=False;
end;

function TEmbeddedFont.Found(Charset:Integer=1; Pitch:Integer=0):Cardinal;
begin
 if Assigned(Self) then Result:=SystemFontsFound(Charset,Pitch,FontFamily) else Result:=0;
end;

procedure TEmbeddedFont.SmartEmbed(Charset:Integer=1; Pitch:Integer=0);
begin
 if Assigned(Self) then if Found(Charset,Pitch)=0 then FontEmbed;
end;

function TEmbeddedFont.DataLoad:Boolean;
const
 FontFizeSizeLoLimit = 1024;
 FontFileSizeHiLimit = 1024*1024*32;
var
 ResInfo:HRSRC; ResHand:THandle; ResData:PChar;
 ResSize,Count:Integer; ModuleName:LongString; Instance:LongWord;
begin
 Result:=False;
 if Assigned(Self) then
 if not DataOk then
 try
  DataFree;
  ResHand:=0;
  if IsSameText(ExtractFileExt(FontSource),'.EXE')
  or IsSameText(ExtractFileExt(FontSource),'.DLL') then
  try
   ModuleName:=ExtractFileNameExt(FontSource);
   Instance:=GetModuleHandle(PChar(ModuleName));
   if Instance=0 then Instance:=LoadLibrary(PChar(FontSource));
   if Instance<>0 then begin
    ResInfo:=FindResource(Instance,PChar(NickName),RT_RCDATA);
    if ResInfo<>0 then ResHand:=LoadResource(Instance,ResInfo);
    if ResHand<>0 then begin
     ResData:=LockResource(ResHand);
     ResSize:=SizeOfResource(Instance,ResInfo);
     if (ResData<>nil) and (ResSize>0) then SetString(myFontData,ResData,ResSize);
    end;
   end;
  finally
   if ResHand<>0 then begin
    UnlockResource(ResHand);
    FreeResource(ResHand);
   end;
  end;
  if IsSameText(ExtractFileExt(FontSource),'.TTF')
  or IsSameText(ExtractFileExt(FontSource),'.OTF')
  or IsSameText(ExtractFileExt(FontSource),'.FON') then begin
   ResSize:=GetFileSize(FontSource);
   if (ResSize>=FontFizeSizeLoLimit) then
   if (ResSize<=FontFileSizeHiLimit) then begin
    SetLength(myFontData,ResSize);
    Count:=ReadFileToBuffer(FontSource,PChar(myFontData),Length(myFontData));
    if Count<>ResSize then myFontData:='';
   end;
  end;
  if not DataOk then DataFree;
  Result:=DataOk;
 except
  on E:Exception do HandleException(E);
 end;
end;

function TEmbeddedFont.FontEmbed:Integer;
begin
 Result:=0;
 if Assigned(Self) then
 if not FontOk then begin
  FontFree; DataLoad;
  if DataOk then myFontHand:=AddFontMemResourceEx(PChar(FontData),Length(FontData),nil,@myEmbedded);
  if not FontOk then FontFree;
  Result:=Embedded;
 end;
end;

procedure TEmbeddedFont.DataFree;
begin
 if Assigned(Self) then myFontData:='';
end;

procedure TEmbeddedFont.FontFree;
begin
 if Assigned(Self) then begin
  if FontHand<>0 then RemoveFontMemResourceEx(FontHand);
  myFontHand:=0; myEmbedded:=0;
 end;
end;

function TEmbeddedFont.FontSave(Add:Bool=False;Post:Bool=False):Integer;
begin
 Result:=0;
 if Assigned(Self) then if DataOk then
 if Length(FontTarget)>0 then if not FileExists(FontTarget) then
 try
  if WriteBufferToFile(FontTarget,PChar(FontData),Length(FontData))>0 then Result:=1;
  if Result>0 then if Add then AddSystemFont(FontTarget,Post);
 except
  on E:Exception do HandleException(E);
 end;
end;

////////////////////
// TEmbeddedFontList
////////////////////
function TEmbeddedFontList.GetEmbeddedFont(i:LongInt):TEmbeddedFont;
begin
 Result:=TEmbeddedFont(Items[i]);
end;

procedure TEmbeddedFontList.PutEmbeddedFont(i:LongInt; f:TEmbeddedFont);
begin
 Items[i]:=TObject(f);
end;

constructor TEmbeddedFontList.Create(aOwns:Boolean);
begin
 inherited Create(aOwns);
end;

destructor  TEmbeddedFontList.Destroy;
begin
 inherited Destroy;
end;

procedure TEmbeddedFontList.SmartEmbed(Charset:Integer=1; Pitch:Integer=0);
var i:Integer;
begin
 if Assigned(Self) then for i:=0 to Count-1 do Self[i].SmartEmbed(Charset,Pitch);
end;

function TEmbeddedFontList.Found(Charset:Integer=1; Pitch:Integer=0):Integer;
var i:Integer;
begin
 Result:=0;
 if Assigned(Self) then for i:=0 to Count-1 do Inc(Result,Ord(Self[i].Found(Charset,Pitch)>0));
end;

function TEmbeddedFontList.GetEmbedded:Integer;
var i:Integer;
begin
 Result:=0;
 if Assigned(Self) then for i:=0 to Count-1 do Inc(Result,Self[i].Embedded);
end;

function TEmbeddedFontList.FontSave(Add:Bool=False;Post:Bool=False):Integer;
var i:Integer;
begin
 Result:=0;
 if Assigned(Self) then for i:=0 to Count-1 do Inc(Result,Self[i].FontSave(Add));
 if Result>0 then if Add then if Post then PostBroadcastFontChange;
end;

function TEmbeddedFontList.FontEmbed:Integer;
var i:Integer;
begin
 Result:=0;
 if Assigned(Self) then for i:=0 to Count-1 do Inc(Result,Self[i].FontEmbed);
end;


procedure TEmbeddedFontList.DataFree;
var i:Integer;
begin
 if Assigned(Self) then for i:=0 to Count-1 do Self[i].DataFree;
end;

procedure TEmbeddedFontList.FontFree;
var i:Integer;
begin
 if Assigned(Self) then for i:=0 to Count-1 do Self[i].FontFree;
end;

procedure TEmbeddedFontList.FontKill;
var i:Integer;
begin
 if Assigned(Self) then
 for i:=Count-1 downto 0 do begin
  Self[i].Free; Delete(i);
 end;
end;

function TEmbeddedFontList.ReadIniFile(const IniFile   : ShortString;
                                       const ThePrefix : ShortString = 'EmbeddedFont';
                                       const SecList   : ShortString = '[EmbeddedFontList]';
                                       const SecName   : ShortString = '[EmbeddedFontName]';
                                       const SecSource : ShortString = '[EmbeddedFontSource]';
                                       const SecTarget : ShortString = '[EmbeddedFontTarget]'
                                                     ) : Integer;
var i:Integer; List:TText; Nick,Name,Source,Target:ShortString; Font:TEmbeddedFont;
begin
 Result:=0;
 try
  List:=ExtractEnumWordList(SysIniFile,SecList,ThePrefix,efConfig);
  try
   for i:=0 to List.Count-1 do begin
    Nick:=Trim(List[i]); Name:=''; Source:=''; Target:='';
    if Length(Nick)>0 then
    if ReadIniFileVariable(SysIniFile,SecName,Nick+'%s',Name,efConfigNC) then
    if ReadIniFilePath(SysIniFile,SecTarget,Nick,GetSystemFontsPath,Target) then
    if ReadIniFilePath(SysIniFile,SecSource,Nick,HomeDir,Source) then begin
     Font:=TEmbeddedFont.Create(Nick,Name,Source,Target);
     if Font.Ok then Inc(Result);
    end;
   end;
  finally
   Kill(List);
  end;
 except
  on E:Exception do HandleException(E);
 end;
end;
 
function NewEmbeddedFontList(aOwns:Boolean):TEmbeddedFontList;
begin
 Result:=nil;
 try
  Result:=TEmbeddedFontList.Create(aOwns);
 except
  on E:Exception do HandleException(E);
 end;
end;

procedure Kill(var TheObject:TEmbeddedFontList); overload;
begin
 try
  FreeAndNil(TheObject);
 except
  on E:Exception do HandleException(E);
 end;
end;

type
 TSysFontsList = array[ANSI_CHARSET..OEM_CHARSET] of array[DEFAULT_PITCH..VARIABLE_PITCH] of LongString;
var
 TheFonts : ^TSysFontsList = nil;

procedure TheSystemFontsReset;
var Charset,Pitch:Integer;
begin
 if not Assigned(TheFonts) then 
 try
  TheFonts:=AllocMem(SizeOf(TheFonts^));
  if Assigned(TheFonts) then
  for Charset:=ANSI_CHARSET to OEM_CHARSET do
  for Pitch:=DEFAULT_PITCH to VARIABLE_PITCH do
  TheFonts[Charset][Pitch]:='';
 except
  on E:Exception do HandleException(E);
 end;
end;

procedure TheSystemFontsFree;
begin
 if Assigned(TheFonts) then
 try
  TheSystemFontsReset;
  FreeMem(TheFonts);
 except
  on E:Exception do HandleException(E);
 end;
 TheFonts:=nil;
end;

function TheSystemFonts(Charset,Pitch:Integer):LongString;
begin
 Result:='';
 try
  if not Assigned(TheFonts)
  then TheSystemFontsReset;
  if Assigned(TheFonts) then begin
   if (Pitch<DEFAULT_PITCH) or (Pitch>VARIABLE_PITCH) then Pitch:=DEFAULT_PITCH;
   if (Charset<ANSI_CHARSET) or (Charset>OEM_CHARSET) then Charset:=DEFAULT_CHARSET;
   if Length(TheFonts[Charset][Pitch])=0 then TheFonts[Charset][Pitch]:=GetSystemFontsAsText(Charset,Pitch);
   Result:=TheFonts[Charset][Pitch];
  end;
 except
  on E:Exception do HandleException(E);
 end;
end;

const
 TheFullEmbeddedFontList : TEmbeddedFontList = nil;

function FullEmbeddedFontList:TEmbeddedFontList;
begin
 if TheFullEmbeddedFontList=nil then
 try
  TheFullEmbeddedFontList:=NewEmbeddedFontList(false);
  TheFullEmbeddedFontList.Master:=TheFullEmbeddedFontList;
 except
  on E:Exception do HandleException(E);
 end;
 Result:=TheFullEmbeddedFontList;
end;

initialization

 TheSystemFontsReset;

 TheFullEmbeddedFontList.Ok;

finalization

 ResourceLeakageLog(Format('%-60s = %d',['FullEmbeddedFontList.Count', TheFullEmbeddedFontList.Count]));
 Kill(TheFullEmbeddedFontList);

 TheSystemFontsFree;

end.
