fcfontcombo.pas

一套及时通讯的原码

  begin
    Canvas.Pen.Color := clBtnShadow;
    Canvas.PolyLine([Point(0, r.Top), Point(Width, r.Top)]);
  end;
end;

constructor TfcCustomFontCombo.Create(AOwner: TComponent);
begin
  inherited;
  Sorted := True;
  FMaxMRU := 6;
  FShowFontHint := True;
  TreeView.ShowHint := True;
  TreeView.OnMouseMove := TreeViewMouseMove;
  TreeView.OnChange := TreeViewChange;
  FRecentFonts := TStringList.Create;
  FRecentFonts.OnChanging := RecentFontsChanging;
  FRecentFonts.OnChange := RecentFontsChange;
  FCheckMRUChange := True;
  TreeOptions := TreeOptions - [tvoShowLines, tvoShowRoot] + [tvoRowSelect];
  Style:= csDropDownList;
//  {$ifdef fcDelphi4Up}
//  FFontTypes:= fcScreenFonts;
//  {$endif}
end;

destructor TfcCustomFontCombo.Destroy;
begin
  FRecentFonts.Free;
  inherited;
end;

procedure TfcCustomFontCombo.CreateWnd;
begin
  inherited;
  If Images<>GetFontImages then
     Images := GetFontImages;
  if PreLoad then Reload(False);
end;

function fcFontCallBack(lpelf: PEnumLogFont; lpntm: PNewTextMetric; FontType: Integer;
  FontCombo: TfcCustomFontCombo): Integer; stdcall;
begin
  result := FontCombo.FontCallBack(lpelf^, lpntm^, FontType);
end;

function TfcCustomFontCombo.CreatePopupTreeView: TfcPopupTreeView;
begin
  result := TfcFontPopupTreeView.Create(self);
end;

procedure TfcCustomFontCombo.DoAddFont(
  AFontText: string; AFontType: TfcComboFontType;
  EnumLogFont: TEnumLogFont; NewTextMetric: TNewTextMetric;
  var Accept: boolean);
begin
  if Assigned(FOnAddFont) then
    FOnAddFont(self, AFontText, AFontType, EnumLogFont, NewTextMetric, Accept);
end;

function TfcCustomFontCombo.FontCallBack(EnumLogFont: TEnumLogFont; NewTextMetric: TNewTextMetric;
  FontType: Integer): Integer;
var Accept: Boolean;
    FontText: string;
    AFontType: TfcComboFontType;
begin
  result := 1;

//  AFontType := fcGetFontType(FontType);

  Accept := True;
  FontText := EnumLogFont.elfLogFont.lfFaceName;

  { Map to type that is declared in this unit so that developer does not need to add
    an additional unit to the uses clause }
  if FontType = DEVICE_FONTTYPE then AFontType := ftFontPrinter
  else if (FontType and TRUETYPE_FONTTYPE) <> 0 then AFontType := ftFontTrueType
  else if (FontType and RASTER_FONTTYPE) <> 0 then AFontType := ftFontRaster
  else AFontType := ftFontOther;

  DoAddFont(FontText, AFontType, EnumLogFont, NewTextMetric, Accept);

  if Accept and (EnumLogFont.elfLogFont.lfFaceName <> '') then
    with Items.Add(nil, FontText) do
  begin
    case AFontType of
      ftFontTrueType: ImageIndex := 0;
      ftFontPrinter: ImageIndex := 1;
      ftFontRaster: ImageIndex := 2;
      ftFontOther: ImageIndex := -1;
    end;
  end;
end;

function TfcCustomFontCombo.GetStartingNode: TfcTreeNode;
begin
  result := nil;
  if Items.Count > RecentFonts.Count then result := TreeView.Items[RecentFonts.Count];
end;

function TfcCustomFontCombo.GetSelectedFont: string;
begin
  result := '';
  if TreeView.Selected <> nil then result := TreeView.Selected.Text;
end;

procedure TfcCustomFontCombo.SetMaxMRU(Value: Integer);
begin
  if FMaxMRU <> Value then
  begin
    FMaxMRU := Value;
    MaintainMaxMRU;
  end;
end;

procedure TfcCustomFontCombo.SetRecentFonts(Value: TStringList);
begin
  FRecentFonts.Assign(Value);
end;

procedure TfcCustomFontCombo.CMEnter(var Message: TCMEnter);
begin
  inherited;
//  if not PreLoad and (TreeView.Items.Count <= RecentFonts.Count) then Reload(False);
end;

procedure TfcCustomFontCombo.ChangeHint(HintClass: THintWindowClass);
begin
  if HintClass = nil then Exit;
  if (HintWindowClass <> HintClass) and ImmediateHints then
  begin
    if (HintClass = TfcToolTip) then
    begin
      FOldHintPause := Application.HintPause;
      Application.HintPause := 0
    end else Application.HintPause := FOldHintPause;
  end;
  HintWindowClass := HintClass;
end;

procedure TfcCustomFontCombo.CloseUp(Accept: Boolean);
begin
  inherited;
  ChangeHint(FOldHintClass);

  if Accept and (MaxMRU <> -1) and (TreeView.Selected <> nil) then
  begin
    MRUChange(Text);
    TreeView.Selected := TreeView.Items.FindNode(Text, False);
  end;
end;

procedure TfcCustomFontCombo.DropDown;
begin
  if not PreLoad and (TreeView.Items.Count <= RecentFonts.Count) then
     Reload(False); { 4/5/99 - RSW }
  inherited;
  FOldHintClass := HintWindowClass;
  ChangeHint(TfcToolTip);
end;

procedure TfcCustomFontCombo.GenerateFontHint(FontName: string; var AHint: string; AHintFont: TFont);
begin
  if Assigned(FOnGenerateFontHint) then FOnGenerateFontHint(self, FontName, AHint, AHintFont);
end;

procedure TfcCustomFontCombo.MaintainMaxMRU;
begin
  if (MaxMRU <> -1) then while RecentFonts.Count > MaxMRU do
    RecentFonts.Delete(RecentFonts.Count - 1);
end;

procedure TfcCustomFontCombo.MRUChange(FontName: string);
var FontNameIndex: Integer;
begin
  FontNameIndex := RecentFonts.IndexOf(FontName);
  if FontNameIndex <> -1 then RecentFonts.Move(FontNameIndex, 0)
  else begin
    RecentFonts.Insert(0, FontName);
    MaintainMaxMRU;
  end;
end;

procedure TfcCustomFontCombo.Reload(RecentFontsOnly: Boolean);
var OldCursor: TCursor;
begin
  if RecentFontsOnly then
    RecentFontsChanging(RecentFonts)
  else begin
{    if TreeView.FStateChanging then begin
       Treeview.HandleNeeded;
       exit;
    end;
}
    OldCursor:= Cursor;
    if Focused then
      Screen.Cursor:= crHourGlass;

    if Items.Count > 0 then Items.Clear;
    {$ifdef fcDelphi4Up}
    if FFontSelections = fcPrinterFonts then
       EnumFontFamilies(Printers.Printer.Handle, nil, @fcFontCallback, LPARAM(self))
    else
    {$endif}
       EnumFontFamilies(Canvas.Handle, nil, @fcFontCallback, LPARAM(self)); { 6/6/97 - RSW }
    if Sorted then TreeView.AlphaSort;

    Screen.Cursor:= OldCursor;
  end;
  RecentFontsChange(RecentFonts);    // Add the RecentFonts list back into the tree view
end;

procedure TfcCustomFontCombo.KeyDown(var Key: Word; Shift: TShiftState);
begin
  inherited;
  // 10/29/2001- Hide hints or flicker occurs when key is pressed and hint showing.
  if ImmediateHints then ChangeHint(FOldHintClass);
end;

procedure TfcCustomFontcombo.RecentFontsChanging(Sender: TObject);
var Node: TfcTreeNode;
begin
  if TreeView.Selected <> nil then FOldSelectedText := TreeView.Selected.Text;
  Node := TreeView.Items.GetFirstNode;
  while (Node <> nil) and TfcFontPopupNode(Node).RecentFont do
  begin
    Node.Free;
    Node := TreeView.Items.GetFirstNode;
  end;
end;

procedure TfcCustomFontCombo.RecentFontsChange(Sender: TObject);
var i: Integer;
    s: string;
begin
  for i := RecentFonts.Count - 1 downto 0 do
    with TfcFontPopupNode(TreeView.Items.AddFirst(nil, RecentFonts[i])) do
    begin
      RecentFont := True;
      s := ItemsList.Values[Text];
      if s <> '' then ImageIndex := StrToInt(s)
    end;
  if (FOldSelectedText <> '') and ((TreeView.Selected = nil) or
    ((TreeView.Selected <> nil) and (TreeView.Selected.Text <> FOldSelectedText))) then
  begin
    TreeView.Selected := TreeView.Items.FindNode(FOldSelectedText, False);
    FOldSelectedText := ''
  end;
end;

procedure TfcCustomFontCombo.TreeViewChange(Sender: TfcCustomTreeView; Node: TfcTreeNode);
var AHint: string;
begin
  if ShowFontHint then with (Sender as TfcTreeView) do
  begin
    Node := Selected;
    if Node <> nil then with fcHintFont do
    begin
      Application.CancelHint;
      AHint := Node.Text;
      Name := Node.Text;
      Size := 12;
      GenerateFontHint(Node.Text, AHint, fcHintFont);
      TreeView.Hint := AHint;
    end;
  end;
end;

procedure TfcCustomFontCombo.TreeViewMouseMove(TreeView: TfcCustomTreeView;
   Node: TfcTreeNode; Shift: TShiftState; X, Y: Integer);
begin
  if ShowFontHint then
  begin
    if not PtInRect(Rect(0, 0, TreeView.Width, TreeView.Height), Point(x, y)) then
      ChangeHint(FOldHintClass)
    else ChangeHint(TfcToolTip);
  end;
end;

procedure TfcCustomFontCombo.KeyPress(var Key: Char);
begin
  if not PreLoad and (TreeView.Items.Count <= RecentFonts.Count) then Reload(False); { 4/5/99 - RSW }
  inherited;
end;

initialization
finalization
  fcFontImages.Free;
  fcFontImages := nil;
end.