(************************************************************************
*    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 AHMTFontControls;
interface
{$I AHM.INC}
uses
 Windows, Messages, Classes, Graphics, Controls, StdCtrls,AHMStdClass;

type
  TAHMFontTypes = (PS, TTF, RASTER, Other);
  TAHMFontClass = Class
    CFontName : String;
    CFontType : TAHMFontTypes;
  end;
  TAHMFontList = Class(TStringList)
    destructor Destroy; Override;
  end;
  TAHMFontBits = array [0..3] of TBitmap;
  TAHMFilterOption = (ShowTrueType,ShowPostScript,ShowRaster,ShowOther);
  TAHMFilterOptions = Set of TAHMFilterOption;
  TAHMOnFontValidate = procedure (Sender: TObject; Font: TAHMFontClass; var accept:Boolean) of object;
  TAHMFontBox = Class(TCustomListBox)
  private
    FAboutStr : TAHMAboutSControlStr;
    FFilterOptions : TAHMFilterOptions;
    FontStringList : TAHMFontList;
    FOnValidateFont : TAHMOnFontValidate;
    FBitmaps : TAHMFontBits;
    procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
    Function GetFontSelected : String;
    Procedure SetFontSelected(Value : String);
  protected
    procedure CreateWnd; override;
    procedure SeTAHMFilterOptions(Value : TAHMFilterOptions);
  public
    constructor Create(AOwner: TComponent); override;
    destructor  Destroy; override;
    procedure   DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState); override;
    procedure   ReBuild;
  published
   property About : TAHMAboutSControlStr read FAboutStr write FAboutStr;
   property Align;
   property BorderStyle;
   property Color;
   property Ctl3D;
   {$IFDEF AHMONLY4}
    property Anchors;
    property BiDiMode;
    property Constraints;
    property DragKind;
    property ParentBiDiMode;
   {$ENDIF}
   property DragCursor;
   property DragMode;
   property Enabled;
   property ExtendedSelect;
   property FilterOptions: TAHMFilterOptions read FFilterOptions write SeTAHMFilterOptions
            default [ShowTrueType, ShowPostScript, ShowRaster,ShowOther];
   property Font;
   property IntegralHeight;
   property ItemHeight;
   property MultiSelect;
   property ParentColor;
   property ParentCtl3D;
   property ParentFont;
   property ParentShowHint;
   property PopupMenu;
   property ShowHint;
   property TabOrder;
   property TabWidth;
   property Visible;
   property OnValidateFont:TAHMOnFontValidate read FOnValidateFont write FOnValidateFont;
   property OnClick;
   property OnDblClick;
   property OnDragDrop;
   property OnDragOver;
   property OnDrawItem;
   property OnEndDrag;
   property OnEnter;
   property OnExit;
   property OnKeyDown;
   property OnKeyPress;
   property OnKeyUp;
   property OnMeasureItem;
   property OnMouseDown;
   property OnMouseMove;
   property OnMouseUp;
   property OnStartDrag;
   property FontSelected : String read GetFontSelected write SetFontSelected;
  end;

  TAHMFontCombo = Class(TCustomComboBox)
  private
    { Private declarations }
    FFilterOptions : TAHMFilterOptions;
    FontStringList : TAHMFontList;
    FOnValidateFont : TAHMOnFontValidate;
    FBitmaps : TAHMFontBits;
    FAboutStr : TAHMAboutSControlStr;
    procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
  protected
    { Protected declarations }
    procedure CreateWnd; override;
    procedure SeTAHMFilterOptions(Value : TAHMFilterOptions);
    Function GetFontSelected : String;
    Procedure SetFontSelected(Value : String);
  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
    destructor  Destroy; override;
    procedure   DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState); override;
    procedure   ReBuild;
  published
   property About : TAHMAboutSControlStr read FAboutStr write FAboutStr;
   property Align;
   property Color;
   property Ctl3D;
    {$IFDEF AHMONLY4}
    property Anchors;
    property BiDiMode;
    property Constraints;
    property DragKind;
    property ParentBiDiMode;
    {$ENDIF}
   property DragMode;
   property DragCursor;
   property DropDownCount;
   property Enabled;
   property FilterOptions: TAHMFilterOptions
            read FFilterOptions
            write SeTAHMFilterOptions
            default [ShowTrueType, ShowPostScript, ShowRaster,ShowOther];
   property Font;
   property MaxLength;
   property ParentColor;
   property ParentCtl3D;
   property ParentFont;
   property ParentShowHint;
   property PopupMenu;
   property ShowHint;
   property TabOrder;
   property TabStop;
   property Text;
   property Visible;
   property OnValidateFont:TAHMOnFontValidate read FOnValidateFont write FOnValidateFont;
   property OnChange;
   property OnClick;
   property OnDblClick;
   property OnDragDrop;
   property OnDragOver;
   property OnDrawItem;
   property OnDropDown;
   property OnEndDrag;
   property OnEnter;
   property OnExit;
   property OnKeyDown;
   property OnKeyPress;
   property OnKeyUp;
   property OnMeasureItem;
   property OnStartDrag;
   property FontSelected : String read GetFontSelected write SetFontSelected;
  end;

{$R AHMTFONTCONTROLS.RES}

implementation

Destructor TAHMFontList.Destroy;
Var
 Temp : TObject;
Begin
 While Count > 0 Do
  Begin
   Temp := Objects[0];
   Temp.Free;
   Delete(0);
  End;
 Inherited Destroy;
End;

function AddFontToList(Sender: TObject; FntClass : TAHMFontClass):Boolean;
var
 cont: Boolean;
begin
 cont := true;
 if Sender is TAHMFontBox then
  with Sender as TAHMFontBox do
   begin
    if assigned(FOnValidateFont) then  FOnValidateFont(Sender,FntClass,cont);
    if cont then
     with FntClass do
      Case CFontType of
       PS     : if ShowPostScript in FFilterOptions then
                 FontStringList.AddObject(CFontName, fntClass);
       TTF    : if ShowTrueType in FFilterOptions then
                 FontStringList.AddObject(CFontName, fntClass);
       RASTER : if ShowRaster in FFilterOptions then
                 FontStringList.AddObject(CFontName, fntClass);
       else if ShowOther in FFilterOptions then
         FontStringList.AddObject(CFontName, FntClass);
     end;
   end
 else
  with Sender as TAHMFontCombo do
   begin
    if assigned(FOnValidateFont) then
     FOnValidateFont(Sender,FntClass,cont);
    if cont then
     with FntClass do
      Case CFontType of
       PS     : if ShowPostScript in FFilterOptions then
                 FontStringList.AddObject(CFontName, fntClass);
       TTF    : if ShowTrueType in FFilterOptions then
                 FontStringList.AddObject(CFontName, fntClass);
       RASTER : if ShowRaster in FFilterOptions then
                 FontStringList.AddObject(CFontName, fntClass);
       else if ShowOther in FFilterOptions then
         FontStringList.AddObject(CFontName, FntClass);
     end;
   end;
 Result := true;
end;


function EnumFontFamProc(var LogFont : TLogFont;var TextMetric : TTextMetric;
                             FontType : Integer;Data : Pointer): Integer; StdCall;
var FontClass : TAHMFontClass;
begin
  Result:=0;
  FontClass := TAHMFontClass.Create;
  With FontClass Do
  begin
    CFontName := LogFont.lfFaceName;
    Case FontType of
      1 : CFontType := RASTER;
      2 : CFontType := PS;
      4 : CFontType := TTF;
      else CFontType := Other;
    end;
  end;
  if TObject(Data) is TAHMFontBox then
  begin
    if AddFontToList(TAHMFontBox(Data),FontClass) then result:=1 else result:=0;
  end;
  if TObject(Data) is TAHMFontCombo then
  begin
    if AddFontToList(TAHMFontCombo(Data),FontClass) then result:=1 else result:=0;
  end;
end;

procedure GetAllInstalledScreenFonts(Sender: TObject);
var DC : HDC;
begin
  DC := GetDC(0);
  EnumFontFamilies(DC, nil, @EnumFontFamProc, LongInt(Pointer(Sender)));
  ReleaseDC(0, DC);
end;


Constructor TAHMFontBox.Create(AOwner: TComponent);
var i : integer;
begin
  inherited Create(AOwner);
  Font.Name  := 'MS Sans Serif';
  Font.Size  := 8;
  Font.Style := Font.Style - [fsBold];
  Sorted     := True;
  Style      := lbOwnerDrawFixed;
  ItemHeight := 16;
  FontStringList := TAHMFontList.Create;
  FontStringList.Sorted := True;
  FontStringList.Clear;
  for i := 0 to 3 do FBitmaps[i]:= TBitmap.Create;
  FBitmaps[0].Handle := LoadBitmap(hinstance,'PS');
  FBitmaps[1].Handle := LoadBitmap(hinstance,'TTF');
  FBitmaps[2].Handle := LoadBitmap(hinstance,'RASTER');
  FBitmaps[3].Handle := LoadBitmap(hinstance,'UNKNOWN');
  FFilterOptions  := [ShowTrueType, ShowPostScript, ShowRaster,ShowOther];
  GetAllInstalledScreenFonts(Self);
end;

Constructor TAHMFontCombo.Create(AOwner: TComponent);
var i : integer;
begin
  inherited Create(AOwner);
  Font.Name  := 'MS Sans Serif';
  Font.Size  := 8;
  Font.Style := Font.Style - [fsBold];
  Sorted     := True;
  Style      := csOwnerDrawFixed;
  ItemHeight := 16;
  FontStringList := TAHMFontList.Create;
  FontStringList.Sorted := True;
  FontStringList.Clear;
  for i := 0 to 3 do FBitmaps[i]:= TBitmap.Create;
  FBitmaps[0].Handle := LoadBitmap(hinstance,'PS');
  FBitmaps[1].Handle := LoadBitmap(hinstance,'TTF');
  FBitmaps[2].Handle := LoadBitmap(hinstance,'RASTER');
  FBitmaps[3].Handle := LoadBitmap(hinstance,'UNKNOWN');
  FFilterOptions  := [ShowTrueType, ShowPostScript, ShowRaster, ShowOther];
  GetAllInstalledScreenFonts(Self);
end;

Destructor TAHMFontBox.Destroy;
var i : integer;
begin
  for i := 0 to 3 do FBitmaps[i].Free;
  FontStringList.Destroy;
  inherited Destroy;
end;

Destructor TAHMFontCombo.Destroy;
var i : integer;
begin
  for i := 0 to 3 do FBitmaps[i].Free;
  FontStringList.Destroy;
  inherited Destroy;
end;

procedure TAHMFontBox.SetFontSelected(Value : String);
begin
  ItemIndex:=Items.IndexOf(Value);
end;

Function TAHMFontBox.GetFontSelected : String;
begin
  result:='';
  if Itemindex<>-1 then
  begin
    result:=Items[Itemindex];
  end;
end;

procedure TAHMFontCombo.SetFontSelected(Value : String);
begin
  ItemIndex:=Items.IndexOf(Value);
end;

Function TAHMFontCombo.GetFontSelected : String;
begin
  result:='';
  if Itemindex<>-1 then
  begin
    result:=Items[Itemindex];
  end;
end;



procedure TAHMFontBox.CreateWnd;
begin
  inherited CreateWnd;
  Items.Assign(FontStringList);
  ItemIndex := 0;
end;


procedure TAHMFontCombo.CreateWnd;
begin
  inherited CreateWnd;
  Items.clear;
  Items.Assign(FontStringList);
  ItemIndex:=0;
end;

procedure TAHMFontBox.Rebuild;
begin
  FontStringList.Clear;
  Items.clear;
  GetAllInstalledScreenFonts(Self);
  Items.Assign(FontStringList);
end;

procedure TAHMFontCombo.Rebuild;
begin
  FontStringList.Clear;
  GetAllInstalledScreenFonts(Self);
  Items.Assign(FontStringList);
end;

procedure TAHMFontBox.SeTAHMFilterOptions(Value: TAHMFilterOptions);
begin
  if FFilterOptions <> Value then
  begin
    FFilterOptions := Value;
    Rebuild;
  end;
end;


procedure TAHMFontCombo.SeTAHMFilterOptions(Value: TAHMFilterOptions);
begin
  if FFilterOptions <> Value then
  begin
    FFilterOptions := Value;
    Rebuild;
  end;
end;


procedure TAHMFontBox.DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState);
var
 tmpbitmap1,
 tmpbitmap2   : TBitmap;
 ARect,BRect  : TRect;
 TmpColor     : TColor;
 TmpFontClass : TAHMFontClass;
begin
 TmpFontClass := TAHMFontClass(FontStringList.Objects[Index]);
 tmpbitmap1      := TBitmap.Create;
 tmpbitmap1.Assign(FBitmaps[ord(TmpFontClass.CFontType)]);
 if odSelected in State then TmpColor := clHighLight else TmpColor := Color;
 with arect do
 begin
   left   := 0;
   top    := 0;
   bottom := tmpbitmap1.Height;
   right  := tmpbitmap1.Width;
 end;
 Canvas.FillRect(Rect);
 tmpbitmap2 := TBitmap.Create;
 with tmpbitmap2, canvas do
  begin
   Height      := tmpbitmap1.Height;
   Width       := tmpbitmap1.Width;
   Brush.Color := TmpColor;
   BrushCopy(ARect, tmpbitmap1, ARect, clWhite); // white is transparent in bitmap
  end;
 with brect do
  begin
   left   := rect.left;
   top    := rect.top;
   bottom := rect.bottom;
   right  := rect.bottom-rect.top;
  end;
 with canvas do
  begin
   copyrect(bRect, tmpbitmap2.Canvas, ARect);
   TextOut(Rect.Left+brect.right+2, Rect.Top, TmpFontClass.CFontName);
  end;
 tmpbitmap2.Free;
 tmpbitmap1.Free;
end;


procedure TAHMFontCombo.DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState);
var
 tmpbitmap1,
 tmpbitmap2   : TBitmap;
 ARect,BRect  : TRect;
 TmpColor     : TColor;
 TmpFontClass : TAHMFontClass;
begin
 TmpFontClass := TAHMFontClass(FontStringList.Objects[Index]);
 tmpbitmap1 := TBitmap.Create;
 tmpbitmap1.Assign(FBitmaps[ord(TmpFontClass.CFontType)]);
 if odSelected in State then
  TmpColor := clHighLight
 else
  TmpColor := Color;
 with arect do
  begin
   left   := 0;
   top    := 0;
   bottom := tmpbitmap1.Height;
   right  := tmpbitmap1.Width;
  end;
 Canvas.FillRect(Rect);
 tmpbitmap2 := TBitmap.Create;
 with tmpbitmap2, canvas do
  begin
   Height      := tmpbitmap1.Height;
   Width       := tmpbitmap1.Width;
   Brush.Color := TmpColor;
   BrushCopy(ARect, tmpbitmap1, ARect, clWhite);
  end;
 with brect do
  begin
   left   := rect.left;
   top    := rect.top;
   bottom := rect.bottom;
   right  := rect.bottom-rect.top+rect.left;
  end;
 with canvas do
  begin
   copyrect(bRect, tmpbitmap2.Canvas, ARect);
   TextOut(Rect.Left+brect.right+2, Rect.Top, TmpFontClass.CFontName);
  end;
 tmpbitmap2.Free;
 tmpbitmap1.Free;
end;


procedure TAHMFontBox.CMFontChanged(var Message: TMessage);
begin
 Canvas.Font := Font;
 ItemHeight  := Canvas.TextHeight(' ');
 inherited;
end;


procedure TAHMFontCombo.CMFontChanged(var Message: TMessage);
begin
 Style := csDropDownList;
 inherited;
 ItemHeight := ItemHeight;
 Style := csOwnerDrawFixed;
end;
end.
