sfontctrls.pas

Alpha Controls 5.40,delphi上的alpha开发源码控件包。没有密码。5.40版的最新版。

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;

  TFontStrList = class(TStringList)
    procedure Delete(Index:integer); override;
    procedure Clear; override;
    destructor Destroy; override;
  end;

  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;
    FontStringList : TFontStrList;
    FOnValidateFont : EValidateFont;
    FDrawFont: boolean;
    procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
    procedure SetDrawFont(const Value: boolean);
  protected
    procedure CreateWnd; override;
    procedure SetFilterOptions(Value : TFilterOptions);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure WndProc(var Message: TMessage); override;
    procedure DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState); override;
    procedure MeasureItem(Index: Integer; var Height: Integer); override;
    procedure ReBuild;
  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;
    FontStringList : TFontStrList;
    FOnValidateFont : EValidateFont;
    FDrawFont: boolean;
    procedure SetDrawFont(const Value: boolean);
  protected
    procedure CreateWnd; override;
    procedure SetFilterOptions(Value : TFilterOptions);
    procedure PaintText; override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState); override;
    procedure MeasureItem(Index: Integer; var Height: Integer); override;
    procedure ReBuild;
    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;
    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, sMessages{$IFDEF LOGGED}, sDebugMsgs{$ENDIF};

var
  i : integer;
  FBitmaps : TBitmapArray;

procedure TFontStrList.Clear;
begin
  while Count > 0 do Delete(0);
end;

procedure TFontStrList.Delete(Index: integer);
begin
  TFontClass(Objects[Index]).Free;
  inherited Delete(Index);
end;

destructor TFontStrList.Destroy;
begin
  Clear;
  inherited Destroy;
End;

function AddFontToList(Sender: TObject; FntClass : TFontClass):Boolean;
var
  cont: Boolean;
begin
  cont := true;
  if Sender is TsFontListBox then with Sender as TsFontListBox do begin
    if assigned(FOnValidateFont) then FOnValidateFont(Sender, FntClass, cont);
    if cont then with FntClass do Case FntType of
      PS     : if ShowPostScript in FFilterOptions then FontStringList.AddObject(FntName, fntClass) else fntClass.Free;
      TTF    : if ShowTrueType in FFilterOptions then FontStringList.AddObject(FntName, fntClass) else fntClass.Free;
      RASTER : if ShowRaster in FFilterOptions then FontStringList.AddObject(FntName, fntClass) else fntClass.Free;
      else FontStringList.AddObject(FntName, FntClass);
    end
    else fntClass.Free;
  end
  else with Sender as TsFontComboBox do begin
    if assigned(FOnValidateFont) then FOnValidateFont(Sender,FntClass,cont);
    if cont then with FntClass do Case FntType of
      PS     : if ShowPostScript in FFilterOptions then FontStringList.AddObject(FntName, fntClass) else fntClass.Free;
      TTF    : if ShowTrueType in FFilterOptions then FontStringList.AddObject(FntName, fntClass) else fntClass.Free;
      RASTER : if ShowRaster in FFilterOptions then FontStringList.AddObject(FntName, fntClass) else fntClass.Free;
      else FontStringList.AddObject(FntName, FntClass);
    end
    else fntClass.Free;
  end;
  Result := true;
end;                                                

function EnumFontFamProc(var LogFont : TLogFont; var TextMetric : TTextMetric; FontType : Integer; Data : Pointer): Integer; StdCall;
var
  FontClass : TFontClass;
begin
  Result := 0;
  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;
  if TObject(Data) is TsFontListBox
    then Result := integer(AddFontToList(TsFontListBox(Data), FontClass))
    else if TObject(Data) is TsFontComboBox
      then Result := integer(AddFontToList(TsFontComboBox(Data), FontClass));
end;

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

Constructor TsFontListBox.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  Sorted     := True;
  ItemHeight := 16;
  FontStringList := TFontStrList.Create;
  FontStringList.Sorted := True;
  FontStringList.Duplicates := dupIgnore;//dupAccept;
  FontStringList.Clear;
  FFilterOptions := [ShowTrueType, ShowPostScript, ShowRaster];
  FDrawFont := True;
  GetAllInstalledScreenFonts(Self);
  Style := lbOwnerDrawVariable;
end;

Constructor TsFontComboBox.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  Sorted     := True;
  Style      := csOwnerDrawVariable;
  FontStringList := TFontStrList.Create;
  FontStringList.Duplicates := dupIgnore;//dupAccept;
  FontStringList.Sorted := True;
  FontStringList.Clear;
  FFilterOptions  := [ShowTrueType, ShowPostScript, ShowRaster];
  FDrawFont := True;
  GetAllInstalledScreenFonts(Self);
end;