(************************************************************************
*    This File is Part of the AHM Triton Tools                          *
*    for Borland Delphi and C++ Builder.                                *
*************************************************************************
* Copyright © 1995-1999 Alexander H. Mehlhorn (AHM) and Tritontools.com *
* All Rights reserved.                                                  *
*                                                                       *
*    For more Information contact us at                                 *
*    E-Mail : support@tritontools.com                                   *
*    URL : http://www.tritontools.com                                   *
*                                                                       *
*    AHM is copyright by Alexander H. Mehlhorn                          *
*    All Parts of this Collection were developed,                       *
*    designed and implemented by AHM                                    *
*                                                                       *
*    Under no Circumstances may you distribute this file                *
*    in this or any other format. This File is supplied                 *
*    as Evaluation of Source only. No Delphi Components may be developed*
*    using extracts or subsets of this code without expressed permission*
*    by AHM.                                                            *
*                                                                       *
*************************************************************************)
unit AHMTFontHolder;
interface
uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  AHMSystemClass,AHMSystemConst;

type
  TAHMFontHolder = class;
  TAHMStoredFonts = class;
  TAHMTTFFont = String;
  TAHMFontInstallEvent = procedure(Sender : TObject;const FontName : String) of Object;
  TAHMStoredFont = class(TCollectionItem)
  private
    FAHMFontStorage : TAHMFontHolder;
    FFontData: TMemoryStream;
    FFont: TAHMTTFFont;
    FFontFileID : String;
    FFontLoaded : Boolean;
    FInstalledFontResFileID : String;
    FInstalledFontFileID : String;
    FInstall: Boolean;
    FOnInstalled: TNotifyevent;
    FOnFontExists: TNotifyevent;
    procedure SetInstall(const Value: Boolean);
    procedure ReadBinaryData(Stream: TStream);
    procedure WriteBinaryData(Stream: TStream);
    procedure RemoveFont;
    procedure SetFont(const Value: TAHMTTFFont);
    function GetFileName: String;
    procedure SetFileName(const Value: String);
    function Empty: boolean;
    function RNotEmpty: Boolean;
  protected
    function GetDisplayName: string; override;
    procedure DefineProperties(Filer: TFiler); override;
    procedure WriteToFile(const Filename: string);
    procedure LoadFromFile(const Filename: string);
  public
    constructor Create(Collection: TCollection); override;
    procedure Assign(Source: TPersistent); override;
    destructor Destroy; override;
    {New Procedures}
    procedure InstallFont;
    {New Properties}
    property Owner : TAHMFontHolder read FAHMFontStorage;
    property DisplayName : String read GetDisplayName;
  published
    Property Font : TAHMTTFFont read FFont write SetFont Stored RNotEmpty;
    Property FntFilename : String read GetFileName write SetFileName stored RNotEmpty;
    Property AutoInstall : Boolean read FInstall write SetInstall stored RNotEmpty default False;
    Property OnFontInstalled : TNotifyevent read FOnInstalled write FOnInstalled;
    Property OnFontExists : TNotifyevent read FOnFontExists write FOnFontExists;
  end;
  TAHMStoredFonts = class(TCollection)
  private
    FAHMFontStorage : TAHMFontHolder;
    function GetAHMStoredFont(Index: Integer): TAHMStoredFont;
    procedure SetAHMStoredFont(Index: Integer; Value: TAHMStoredFont);
  protected
    function GetOwner : TPersistent; override;
  public
    constructor Create(AOwner: TAHMFontHolder);
    function Add : TAHMStoredFont;
    function Delete(Index :Integer) :Boolean;
    property Owner : TAHMFontHolder read FAHMFontStorage;
    property Items[Index: Integer]: TAHMStoredFont read GetAHMStoredFont write SetAHMStoredFont; default;
  end;
  TAHMFontHolder = class(TAHMSystemsComponent)
  private
    FTTFFonts : TStrings;
    FAHMStoredFonts : TAHMStoredFonts;
    FOnInstalled: TAHMFontInstallEvent;
    FOnFontExists: TAHMFontInstallEvent;
    procedure SetAHMStoredFonts(Value: TAHMStoredFonts);
    function GetTTFFonts: TStrings;
  protected
  public
    constructor Create(AOwner: TComponent); override;
    procedure Loaded; override;
    destructor Destroy; override;
    property TTFFonts : TStrings read GetTTFFonts;
  published
    property Fonts : TAHMStoredFonts read FAHMStoredFonts write SetAHMStoredFonts;
    Property OnFontInstalled : TAHMFontInstallEvent read FOnInstalled write FOnInstalled;
    Property OnFontExists : TAHMFontInstallEvent read FOnFontExists write FOnFontExists;
  end;

implementation
uses Registry;

constructor TAHMStoredFont.Create(Collection: TCollection);
begin
  inherited Create(Collection);
  FAHMFontStorage :=(((Collection as TAHMStoredFonts).GetOwner) as TAHMFontHolder);
  FFontData:=TMemoryStream.Create;
  FInstall:=False;
end;

procedure TAHMStoredFont.ReadBinaryData(Stream: TStream);
function ReadString: shortstring;
begin
  Stream.ReadBuffer(Result[0],1);
  if Result <> '' then Stream.ReadBuffer(Result[1],ord(Result[0]));
end;
begin
  FFontData.LoadFromStream(Stream);
end;

procedure TAHMStoredFont.WriteBinaryData(Stream: TStream);
procedure WriteString(s: shortstring);
begin
  Stream.WriteBuffer(s[0],1);
  if s <> '' then
    Stream.WriteBuffer(s[1],ord(s[0]));
end;
begin
  FFontData.SaveToStream(Stream);
end;

destructor TAHMStoredFont.Destroy;
begin
  RemoveFont;
  FFontData.Free;
  inherited Destroy;
end;

procedure TAHMStoredFont.DefineProperties(Filer: TFiler);
begin
  inherited DefineProperties(Filer);
  Filer.DefineBinaryProperty('StoredFont',ReadBinaryData,WriteBinaryData,not Empty);
end;

procedure TAHMStoredFont.Assign(Source: TPersistent);
begin
  if Source is TAHMStoredFont then
  begin
    Font := TAHMStoredFont(Source).Font;
    AutoInstall := TAHMStoredFont(Source).AutoInstall;
    OnFontInstalled := TAHMStoredFont(Source).OnFontInstalled;
    OnFontExists := TAHMStoredFont(Source).OnFontExists;
    Exit;
  end;
  inherited Assign(Source);
end;

procedure TAHMStoredFont.LoadFromFile(const FileName: string);
begin
  FFontData.LoadFromFile(FileName);
end;

procedure TAHMStoredFont.WriteToFile(const FileName: string);
begin
  if not(Empty) then FFontData.SaveToFile( FileName );
end;

procedure TAHMStoredFont.InstallFont;
var sTempDir  : shortstring;
begin
  if (FFontLoaded) or (FFont = '') or (Empty) then  exit;
  if Owner.TTFFonts.IndexOf(FFont) >= 0 then
  begin
    if not (csDesigning in Owner.ComponentState) then FFontData.Clear;
    if assigned(OnFontExists) then FOnFontExists(self);
    if assigned(Owner.FOnFontExists) then Owner.FOnFontExists(self,FFont);
    exit;
  end;
  sTempDir[0] := char(GetTempPath(sizeof(sTempDir)-2,@sTempDir[1]));
  if sTempDir = '' then exit;
  if sTempDir[length(sTempDir)] <> '\' then sTempDir := sTempDir+'\';
  FInstalledFontResFileID := ChangeFileExt(sTempDir+FFontFileID,'.fot');
  FInstalledFontFileID := ChangeFileExt(sTempDir+FFontFileID,'.ttf');
  WriteToFile(FInstalledFontFileID);
  if not (csDesigning in Owner.ComponentState) then FFontData.Clear;
  CreateScalableFontResource(0,PChar(FInstalledFontResFileID),PChar(FInstalledFontFileID),nil);
  if FileExists(FInstalledFontResFileID) then
  begin
    if AddFontResource(PChar(FInstalledFontResFileID)) <> 0 then
    begin
      FFontLoaded := true;
      SendMessage(HWND_BROADCAST,WM_FONTCHANGE,0,0);
      if assigned(FOnInstalled) then FOnInstalled(Self);
      if assigned(Owner.FOnInstalled) then Owner.FOnInstalled(Self,FFont);
    end;
  end;
end;

procedure TAHMStoredFont.RemoveFont;
begin
  if FFontLoaded then
  begin
    RemoveFontResource(PChar(FInstalledFontResFileID));
    FFontLoaded := false;
    SendMessage(HWND_BROADCAST,WM_FONTCHANGE,0,0);
    DeleteFile(FInstalledFontResFileID);
    DeleteFile(FInstalledFontFileID);
  end;
end;


procedure TAHMStoredFont.SetFont(const Value: TAHMTTFFont);
var PDir : Array[0..255] of Char;
    FFontLocation,FDir,FFileID : String;
    OSVersionInfo : TOSVersionInfo;

begin
  if csLoading in Owner.ComponentState then
  begin
    FFont := Value;
    exit;
  end;
  if not (csDesigning in Owner.ComponentState) then raise Exception.Create(ahmscfntnomod);
  RemoveFont;
  FFontData.Clear;
  FFont := '';
  FFontFileID := '';
  if Value = '' then exit;
  FillChar(OSVersionInfo,SizeOf(OSVersionInfo),0);
  OSVersionInfo.dwOSVersionInfoSize := sizeof(TOSVERSIONINFO);
  GetVersionEx(OSVersionInfo);
  case OSVersionInfo.dwPlatformID of
    VER_PLATFORM_WIN32_WINDOWS : FFontLocation:=ahmscfntfilename;
    VER_PLATFORM_WIN32_NT      : FFontLocation:=ahmscfntfilenameNT;
  end;
  with TRegIniFile.Create('') do
  try
    RootKey := HKEY_LOCAL_MACHINE;
    FFileID := ReadString(FFontLocation,Value+' (TrueType)','');
    if FFileID = '' then raise Exception.Create(ahmscfntnotfnd+'"'+Value+'"');
    if ExtractFileName(FFileID)=FFileID then
    begin
      RootKey := HKEY_CURRENT_USER;
      FDir := ReadString(ahmscfntpath,'Fonts','');
      if FDir = '' then
      begin
        FillChar(PDir,SizeOf(PDir),#0);
        GetWindowsDirectory(@PDir,SizeOf(PDir)+1);
        FDir:=String(PDir);
        if (FDir = '') or (FDir[length(FDir)] <> '\') then FDir := FDir+'\';
        FDir := FDir+'Fonts\';
      end else if FDir[length(FDir)] <> '\' then FDir := FDir+'\';
    end else FDir:='';
  finally
    Free;
  end;
  LoadFromFile(FDir+FFileID);
  FFont := Value;
  FFontFileID := ExtractFileName(FFileID);
end;

function TAHMStoredFont.GetDisplayName: string;
begin
  if FFont<>'' then result:=FFont else result:=ahmscfntnostored; 
end;

function TAHMStoredFonts.GetOwner: TPersistent;
begin
  Result := FAHMFontStorage;
end;

constructor TAHMStoredFonts.Create(AOwner: TAHMFontHolder);
begin
  inherited Create(TAHMStoredFont);
  FAHMFontStorage := AOwner;
end;

function TAHMStoredFonts.Add: TAHMStoredFont;
begin
  Result := TAHMStoredFont(inherited Add);
end;

function TAHMStoredFonts.GetAHMStoredFont(Index: Integer): TAHMStoredFont;
begin
  Result := TAHMStoredFont(inherited GetItem(Index));
end;

procedure TAHMStoredFonts.SetAHMStoredFont(Index: Integer; Value: TAHMStoredFont);
begin
  inherited SetItem(Index, Value);
end;

constructor TAHMFontHolder.Create(AOwner: TComponent);
begin
  inherited create(AOwner);
  FTTFFonts:=TStringlist.Create;
  FAHMStoredFonts:=TAHMStoredFonts.Create(self);
end;

destructor TAHMFontHolder.Destroy;
begin
  FAHMStoredFonts.Free;
  FTTFFonts.Free;
  inherited Destroy;
end;

function EnumTrueTypeFontsProc(var LogFont : TEnumLogFont;var TextMetric : TTextMetric;FontType : Integer;Data : Pointer): Integer; stdcall;
begin
  if TextMetric.tmPitchAndFamily and TMPF_TRUETYPE = TMPF_TRUETYPE then
     TStringList(Data).Add(StrPas(LogFont.elfFullName));
  Result := 1;
end;

function TAHMFontHolder.GetTTFFonts: TStrings;
var DC : HDC;
begin
  FTTFFonts.Clear;
  DC := GetDC(0);
  try
    EnumFontFamilies(DC,nil,@EnumTrueTypeFontsProc,Integer(FTTFFonts));
  finally
    ReleaseDC(0, DC);
  end;
  result:=FTTFFonts;
end;

procedure TAHMFontHolder.Loaded;
Var I: Integer;
begin
  inherited Loaded;
  for I:=0 to FAHMStoredFonts.Count-1 do
    if FAHMStoredFonts[I].FInstall then FAHMStoredFonts[I].InstallFont;
end;

procedure TAHMFontHolder.SetAHMStoredFonts(Value: TAHMStoredFonts);
begin
  FAHMStoredFonts.Assign(Value);
end;

function TAHMStoredFonts.Delete(Index: Integer): Boolean;
begin
  result := true;
  Try
    Items[Index].free;
  Except
    result := false;
    Application.handleexception(self);
  End;
end;

procedure TAHMStoredFont.SetInstall(const Value: Boolean);
begin
  FInstall := Value;
end;

function TAHMStoredFont.GetFileName: String;
begin
  result:=FFontFileID;
end;

function TAHMStoredFont.Empty: boolean;
begin
  Result :=FFontData.Size = 0;
end;

procedure TAHMStoredFont.SetFileName(const Value: String);
begin
 { Designtime visibility}
  if not(csDesigning in Owner.Componentstate) or (csLoading in Owner.Componentstate) then FFontFileID:=Value;
end;

function TAHMStoredFont.RNotEmpty: Boolean;
begin
  result:=not(Empty);
end;

end.
