fcfontcombo.pas

一套及时通讯的原码

unit fcFontCombo;
{
//
// Components : TfcFontCombo
//
// Copyright (c) 1999 by Woll2Woll Software
// 6/6/99 - RSW - Destroy gets called when DLL is unloaded
// 6/6/99 - Add screen fonts
// 10/1/2001- Exposed OnMouseEnter and OnMouseLeave to be consistent with InfoPower.
// 10/1/2001- Exposed PopupMenu property and OnContextPopup event.
// 10/29/2001- Hide hints or flicker occurs when key is pressed and hint showing.
}

interface

{$i fcIfDef.pas}

uses Graphics, Windows, Messages, Classes, SysUtils, Controls, fcCombo, Dialogs,
  fcTreeCombo, Forms, Printers, fcCommon, fcTreeView, fcToolTip
  {$ifdef fcDelphi4Up}
  ,ImgList
  {$endif};

type
  TfcCustomFontCombo = class;

  TfcComboFontType = (ftFontPrinter, ftFontTrueType, ftFontOther, ftFontRaster);

  TfcAddFontEvent = procedure(FontCombo: TfcCustomFontCombo; FontName: string;
    FontType: TfcComboFontType; EnumLogFont: TEnumLogFont; NewTextMetric: TNewTextMetric;
    var Accept: Boolean) of object;

  TfcFontHintEvent = procedure(FontCombo: TfcCustomFontCombo; FontName: string;
    var Hint: string; const Font: TFont) of object;


  TfcFontPopupNode = class(TfcTreeComboTreeNode)
  private
    FRecentFont: Boolean;
  public
    property RecentFont: Boolean read FRecentFont write FRecentFont;
  end;

  TfcFontPopupTreeView = class(TfcPopupTreeView)
  protected
    procedure EndItemPainting(Node: TfcTreeNode; ARect: TRect; AItemState: TfcItemStates); override;
  public
    constructor Create(Owner: TComponent); override;
  end;

  {
  // TfcCustomFontCombo
  //
  // Properties:
  // - MaxMRU: This property specifies the maximum number of items
  //           that will be added to the most recently used section
  //           of the drop down tree view.  If this property is -1
  //           then MRU functionality is disabled.
  //
  // - PreLoad: When this property is set, the fonts are loaded into
  //           the combo upon creation.  However, when this property
  //           is false, the fonts are loaded in either when you
  //           enter the control or drop it down depending on whether
  //           ShowMatchText is true or false, respectively.
  //
  // - RecentFonts: A list of fonts that appear at the top of the
  //           font combo.  This property is automatically managed
  //           if the MaxMRU property contains a value other than
  //           -1.
  //
  // - ShowFontHints: When true, holding the mouse over a font
  //           selection in the drop-down list will pop-up a hint
  //           displaying the font name in that font's face.
  //
  // Methods:
  // - Reload: Causes the font combo to reload its fonts.  If
  //           RecentFontsOnly is true, then only reloads the
  //           items at the top corresponding to the values in
  //           the RecentFonts property.
  //
  // Events:
  // - OnAddFont: Occurs immediately before adding a font to the
  //           font combo.  Accept is initially true -- setting it
  //           to false will prevent the font from being added to
  //           the font combo.
  //
  // - OnGenerateFontHint: Occurs immediately before displaying a
  //           hint for a particular font.  Customization on the hint
  //           text and font can occur here.  Only occurs when the
  //           ShowFontHints property is true.
  }

  TfcFontType = (fcScreenFonts, fcPrinterFonts, fcRasterFonts);
  TfcCustomFontCombo = class(TfcCustomTreeCombo)
  private
    FOldHintClass: THintWindowClass;
    FOldSelectedText: string;

    FCheckMRUChange: Boolean;
    FImmediateHints: Boolean;
    FMaxMRU: Integer;
    FOldHintPause: Integer;
    FPreLoad: Boolean;
    FRecentFonts: TStringList;
    FShowFontHint: Boolean;

    FOnAddFont: TfcAddFontEvent;
    FOnGenerateFontHint: TfcFontHintEvent;
    {$ifdef fcDelphi4Up}
    FFontSelections: TfcFontType;
    {$endif}

    // Property Access Methods
    function GetSelectedFont: string;
    procedure SetMaxMRU(Value: Integer);
    procedure SetRecentFonts(Value: TStringList);

    // Message Handlers
    procedure CMEnter(var Message: TCMEnter); message CM_ENTER;
    procedure ChangeHint(HintClass: THintWindowClass);
  protected
    // Virtual Methods
    function FontCallBack(EnumLogFont: TEnumLogFont; NewTextMetric: TNewTextMetric;
      FontType: Integer): Integer; virtual;
    procedure GenerateFontHint(FontName: string; var AHint: string; AHintFont: TFont); virtual;
    procedure MaintainMaxMRU; virtual;
    procedure MRUChange(FontName: string); virtual;
    procedure RecentFontsChanging(Sender: TObject); virtual;
    procedure RecentFontsChange(Sender: TObject); virtual;
    procedure TreeViewMouseMove(TreeView: TfcCustomTreeView; Node: TfcTreeNode; Shift: TShiftState; X, Y: Integer); virtual;
    procedure TreeViewChange(Sender: TfcCustomTreeView; Node: TfcTreeNode); virtual;

    // Overridden Methods
    function CreatePopupTreeView: TfcPopupTreeView; override;
    function GetStartingNode: TfcTreeNode; override;
    procedure CreateWnd; override;
    procedure KeyPress(var Key: Char); override;
    procedure KeyDown(var Key: Word; Shift: TShiftState); override;
    procedure DoAddFont(
                AFontText: string; AFontType: TfcComboFontType;
                EnumLogFont: TEnumLogFont; NewTextMetric: TNewTextMetric;
                var Accept: boolean); virtual;
  public
    Patch: Variant;
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;

    procedure CloseUp(Accept: Boolean); override;
    procedure DropDown; override;
    procedure Reload(RecentFontsOnly: Boolean); virtual;

    property ImmediateHints: Boolean read FImmediateHints write FImmediateHints;
    property MaxMRU: Integer read FMaxMRU write SetMaxMRU;
    property PreLoad: Boolean read FPreLoad write FPreLoad;
    property RecentFonts: TStringList read FRecentFonts write SetRecentFonts;
    property ShowFontHint: Boolean read FShowFontHint write FShowFontHint;
    property SelectedFont: string read GetSelectedFont;
    {$ifdef fcDelphi4Up}
    property FontSelections: TfcFontType read FFontSelections write FFontSelections default fcScreenFonts;
    {$endif}

    property OnAddFont: TfcAddFontEvent read FOnAddFont write FOnAddFont;
    property OnGenerateFontHint: TfcFontHintEvent read FOnGenerateFontHint write FOnGenerateFontHint;
  end;

  TfcFontCombo = class(TfcCustomFontCombo)
  published
    property Controller;
    property DisableThemes;
    
    {$ifdef fcDelphi4Up}
    property Anchors;
    property BiDiMode;
    property Constraints;
    property ParentBiDiMode;    
    {$endif}
    property AllowClearKey;
    property AutoSelect;
    property AutoSize;
    property BorderStyle;
    property ButtonStyle;
    property ButtonEffects;
    property ButtonGlyph;
    property ButtonWidth;
    property CharCase;
    property DropDownCount default 8;
    property DropDownWidth;
    property Enabled;
    property Frame;
    property Font;
    property ImmediateHints;
    property MaxMRU default 6;
    property PreLoad default False;
    property PopupMenu;
    property ReadOnly;
    property RecentFonts;
    property ShowFontHint default True;
    property ShowHint;
    property ShowMatchText default True;
    property Sorted default True;
    property Style default csDropDownList;
    property TabOrder;
    property TreeOptions;
    property Visible;
    {$ifdef fcDelphi4Up}
    property FontSelections;
    {$endif}

    property OnAddFont;
    property OnCloseUp;
    property OnChange;
    {$ifdef fcDelphi5Up}
    property OnContextPopup;
    {$endif}
    property OnDropDown;
    property OnEnter;
    property OnExit;
    property OnGenerateFontHint;
    property OnKeyDown;
    property OnKeyPress;
    property OnKeyUp;
    property OnMouseEnter;
    property OnMouseLeave;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnSelectionChange;
  end;

implementation

{$r fcFont.res}

type
   TFontImageList = class(TImageList)
      public
         destructor Destroy; override;
   end;
var fcFontImages: TImageList = nil;

destructor TFontImageList.Destroy; { 6/6/99 - RSW - Destroy gets called when DLL is unloaded }
begin
   inherited Destroy;
   fcFontImages:= nil;
end;

function GetFontImages: TImageList;
var bm: Graphics.TBitmap;
begin
  if fcFontImages = nil then
  begin
    bm := Graphics.TBitmap.Create;
    bm.Transparent := True;
    bm.LoadFromResourceName(HINSTANCE, 'FCFONTTRUETYPE');
    fcFontImages := TFontImageList.Create(nil);
    fcFontImages.Width := bm.Width;
    fcFontImages.Height := bm.Height;
    fcFontImages.AddMasked(bm, bm.TransparentColor);
    bm.LoadFromResourceName(HINSTANCE, 'FCFONTPRINTER');
    fcFontImages.AddMasked(bm, bm.TransparentColor);
    fcFontImages.BlendColor := clHighlight;
    bm.Free;
  end;
  result := fcFontImages;
end;

constructor TfcFontPopupTreeView.Create(Owner: TComponent);
begin
  inherited;
  NodeClass := TfcFontPopupNode;
end;

procedure TfcFontPopupTreeView.EndItemPainting(Node: TfcTreeNode; ARect: TRect; AItemState: TfcItemStates);
var r: TRect;
begin
  inherited;

  r := Node.DisplayRect(False);

  { RSW - Separated logic to allow lines to moved down by 1}
  with (TreeCombo as TfcCustomFontCombo).RecentFonts do
    if (Count > 0) and TfcFontPopupNode(Node).RecentFont and (TfcFontPopupNode(Node).GetNext <> nil) and not TfcFontPopupNode(Node.GetNext).RecentFont then
  begin
    Canvas.Pen.Color := clBtnShadow;
//    Canvas.PolyLine([Point(0, r.Bottom - 0), Point(Width, r.Bottom - 0)]);
    Canvas.PolyLine([Point(0, r.Bottom - 2), Point(Width, r.Bottom - 2)]);
  end;

  with (TreeCombo as TfcCustomFontCombo).RecentFonts do
    if (Count > 0) and
       not TfcFontPopupNode(Node).RecentFont and (Node.GetPrev <> nil) and TfcFontPopupNode(Node.GetPrev).RecentFont then