sfontctrls.pas

Alpha Controls.v5.46b Source

unit sFontCtrls;
{$I sDefs.inc}
{.$DEFINE LOGGED}

interface

uses
 Windows, Messages, Classes, Graphics, Controls, StdCtrls, sAlphaListBox, sComboBox;

type
{$IFNDEF NOTFORHELP}
  FontTypes = (PS, TTF, RASTER, UNKNOWN);

  TFontClass = class
    FntName : string;
    FntType : FontTypes;
  end;

  TFontsArray = array of TFontClass;

  TBitmapArray = array [0..3] of TBitmap;
  TFilterOption = (ShowTrueType, ShowPostScript, ShowRaster);
  TFilterOptions = set of TFilterOption;
  EValidateFont = procedure (Sender: TObject; Font: TFontClass; var accept:Boolean) of object;
{$ENDIF} // NOTFORHELP

  TsFontListBox = Class(TsAlphaListBox)
{$IFNDEF NOTFORHELP}
  private
    FFilterOptions : TFilterOptions;
    FOnValidateFont : EValidateFont;
    FDrawFont: boolean;
    procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
    procedure SetDrawFont(const Value: boolean);
  protected
    procedure SetFilterOptions(Value : TFilterOptions);
  public
    constructor Create(AOwner: TComponent); override;
    procedure Loaded; override;
    procedure WndProc(var Message: TMessage); override;
    procedure DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState); override;
    procedure MeasureItem(Index: Integer; var Height: Integer); override;
  published
    property Align;
    property BorderStyle;
    property Color;
    property Ctl3D;
    property DragCursor;
    property DragMode;
    property Enabled;
    property ExtendedSelect;
    property Font;
    property IntegralHeight;
    property ItemHeight;
    property Items stored False;
    property MultiSelect;
    property ParentColor;
    property ParentCtl3D;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property Style default lbOwnerDrawVariable; 
    property TabOrder;
    property TabWidth;
    property Visible;
    property OnValidateFont:EValidateFont 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;
{$ENDIF} // NOTFORHELP
    property DrawFont : boolean read FDrawFont write SetDrawFont default True;
    property FilterOptions: TFilterOptions read FFilterOptions write SetFilterOptions default [ShowTrueType, ShowPostScript, ShowRaster];
  end;

  TsFontComboBox = Class(TsCustomComboBox)
{$IFNDEF NOTFORHELP}
  private
    FFilterOptions : TFilterOptions;
    FOnValidateFont : EValidateFont;
    FDrawFont: boolean;
    procedure SetDrawFont(const Value: boolean);
  protected
    procedure SetFilterOptions(Value : TFilterOptions);
    procedure PaintText; override;
  public
    constructor Create(AOwner: TComponent); override;
    procedure Loaded; override;
    procedure DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState); override;
    procedure MeasureItem(Index: Integer; var Height: Integer); override;
    property Style default csOwnerDrawVariable;
  published
    property Align;
    property Color;
    property Ctl3D;
    property DragMode;
    property DragCursor;
    property DropDownCount;
    property Enabled;
    property Font;
    property ItemHeight;
    property Items stored False;
    property MaxLength;
    property ParentColor;
    property ParentCtl3D;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property TabOrder;
    property TabStop;
    property Text;
    property Visible;
    property OnValidateFont : EValidateFont read FOnValidateFont write FOnValidateFont;
    property OnChange;
    property OnClick;
{$IFDEF DELPHI6UP}
    property OnCloseUp;
{$ENDIF}
    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;
{$ENDIF} // NOTFORHELP
    property DrawFont : boolean read FDrawFont write SetDrawFont default True;
    property FilterOptions: TFilterOptions read FFilterOptions write SetFilterOptions default [ShowTrueType, ShowPostScript, ShowRaster];
  end;

implementation

uses SysUtils, acntUtils, sGraphUtils, sVclUtils, sCommonData, Forms, sMessages{$IFDEF LOGGED}, sDebugMsgs{$ENDIF};

var
  iC : integer;
  FBitmaps : TBitmapArray;
  fa : TFontsArray;

function EnumFontFamProc(var LogFont : TLogFont; var TextMetric : TTextMetric; FontType : Integer; Data : Pointer): Integer; StdCall;
var
  FontClass : TFontClass;
  s : string;
  i, l : integer;
begin
  Result := 1;
  s := LogFont.lfFaceName;
  l := Length(fa);
  for i := 0 to l - 1 do if AnsiCompareText(fa[i].FntName, s) = 0 then Exit; // Skip duplicates Synchronize
  FontClass := TFontClass.Create;
  with FontClass do begin
    FntName := LogFont.lfFaceName;
    case FontType of
      1 : FntType := RASTER;
      2 : FntType := PS;
      4 : FntType := TTF;
      else FntType := UNKNOWN;
    end;
  end;
  SetLength(fa, Length(fa) + 1);
  fa[Length(fa) - 1] := FontClass;
end;

procedure GetFonts(Sender : TControl);
var
  cont: Boolean;
  i : integer;
  fc : TFontClass;
begin
  if Sender is TsFontListBox then with Sender as TsFontListBox do begin
    Items.BeginUpdate;
    Items.Clear;
    for i := 0 to Length(fa) - 1 do begin
      Cont := True;
      if Assigned(FOnValidateFont) then FOnValidateFont(Sender, fa[i], Cont);
      fc := fa[i];
      if Cont then with fa[i] do Case FntType of
        PS     : if ShowPostScript in TsFontListBox(Sender).FFilterOptions then Items.AddObject(FntName, fa[i]);
        TTF    : if ShowTrueType in FFilterOptions then TsFontListBox(Sender).Items.AddObject(FntName, fa[i]);
        RASTER : if ShowRaster in FFilterOptions then Items.AddObject(FntName, fc);
        else Items.AddObject(FntName, fa[i]);
      end;
    end;
    Items.EndUpdate;
  end
  else with Sender as TsFontComboBox do begin
    Items.BeginUpdate;
    Items.Clear;
    for i := 0 to Length(fa) - 1 do begin
      Cont := True;
      if Assigned(FOnValidateFont) then FOnValidateFont(Sender, fa[i], Cont);
      if cont then with fa[i] do Case FntType of
        PS     : if ShowPostScript in FFilterOptions then Items.AddObject(FntName, fa[i]);
        TTF    : if ShowTrueType in FFilterOptions then Items.AddObject(FntName, fa[i]);
        RASTER : if ShowRaster in FFilterOptions then Items.AddObject(FntName, fa[i]);
        else Items.AddObject(FntName, fa[i]);
      end;
    end;
    Items.EndUpdate;
  end;
end;

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

Constructor TsFontListBox.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  Sorted     := True;
  ItemHeight := 16;
  FFilterOptions := [ShowTrueType, ShowPostScript, ShowRaster];
  FDrawFont := True;
  Style := lbOwnerDrawVariable;
end;

Constructor TsFontComboBox.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  Sorted     := True;
  Style      := csOwnerDrawVariable;
  FFilterOptions  := [ShowTrueType, ShowPostScript, ShowRaster];
  FDrawFont := True;
end;