unit FontCombobox;

interface

uses
  Windows, SysUtils, Types, Classes, Controls, StdCtrls, Graphics, Messages, Dialogs;

type
  TFontCombobox = class(TCustomComboBox)
  strict private
    FFonts: TStringList;
  protected
    procedure LoadFonts;
    procedure Loaded; override;
    procedure DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState);
      override;
    procedure CreateWnd; override;
    procedure CreateParams(var Params: TCreateParams); override;
    procedure WMMeasureItem(var Message: TWMMeasureItem);
      message WM_MEASUREITEM;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure LoadItems;
  published
    property Align;
    property AutoComplete;
    property AutoCompleteDelay;
    property AutoDropDown;
    property AutoCloseUp;
    property BevelEdges;
    property BevelInner;
    property BevelKind;
    property BevelOuter;
    property Anchors;
    property BiDiMode;
    property CharCase;
    property Color;
    property Constraints;
    property Ctl3D;
    property DoubleBuffered;
    property DragCursor;
    property DragKind;
    property DragMode;
    property Enabled;
    property Font;
    property ImeMode;
    property ImeName;
    property ItemHeight;
    property ItemIndex default -1;
    property MaxLength;
    property ParentBiDiMode;
    property ParentColor;
    property ParentCtl3D;
    property ParentDoubleBuffered;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property TabOrder;
    property TabStop;
    property Text;
    property TextHint;
    property Visible;
    property OnChange;
    property OnClick;
    property OnCloseUp;
    property OnContextPopup;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnDropDown;
    property OnEndDock;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnKeyDown;
    property OnKeyPress;
    property OnKeyUp;
    property OnMouseEnter;
    property OnMouseLeave;
    property OnSelect;
    property OnStartDock;
    property OnStartDrag;
    property Items;
  end;

procedure Register;

implementation

uses
  Math;

procedure Register;
begin
  RegisterComponents('Rejbrand 2015', [TFontCombobox]);
end;

{ TFontCombobox }

function EnumFontFamExProc(ALogFont: PLogFont; ATextMetric: PTextMetric;
  AFontType: DWORD; lParam: LPARAM): integer; stdcall;
var
  FontName: string;
  FontList: TStringList;
begin
  FontName := ALogFont.lfFaceName;
  FontList := TStringList(Pointer(lParam));

  result := 1;

  if (Length(FontName) = 0) or (FontName[1] = '@') then
    Exit;
  if (FontList.Count > 0) and (FontList[FontList.Count - 1] = FontName) then
    Exit;

  FontList.AddObject(FontName, TObject(IfThen(ALogFont.lfCharSet = SYMBOL_CHARSET, 1, 0)));
end;

constructor TFontCombobox.Create(AOwner: TComponent);
begin
  FFonts := TStringList.Create;
  LoadFonts;
  inherited;
end;

procedure TFontCombobox.CreateParams(var Params: TCreateParams);
begin
  inherited;
  Params.Style := Params.Style or CBS_OWNERDRAWVARIABLE;
end;

procedure TFontCombobox.CreateWnd;
var
  bm: TBitmap;
  w: integer;
  TM: TTextMetric;
begin
  inherited;
  bm := TBitmap.Create;
  try
    bm.Canvas.Font.Assign(Self.Font);

    GetTextMetrics(bm.Canvas.Handle, TM);
    Perform(CB_SETITEMHEIGHT, cardinal(-1), cardinal(GetSystemMetrics(SM_CYBORDER) * 2 + TM.tmHeight));

    bm.Canvas.Font.Size := Max(Self.Font.Size, 14);
    w := bm.Canvas.TextWidth('Arial Unicode MS Extra 2');
    Perform(CB_SETDROPPEDWIDTH, Round(1.5*w), 0);
    DropDownCount := 20;

  finally
    bm.Free;
  end;
end;

destructor TFontCombobox.Destroy;
begin
  FFonts.Free;
  inherited;
end;

procedure TFontCombobox.DrawItem(Index: Integer; Rect: TRect;
  State: TOwnerDrawState);
var
  R: TRect;
  S: string;
begin

  if odComboBoxEdit in State then
  begin
    inherited;
    Exit;
  end;

  if not InRange(Index, 0, Items.Count - 1) then
    Exit;

  R := Rect;
  S := Items[Index];

  Canvas.Brush.Color := IfThen(odSelected in State, clHighlight, clWindow);
  Canvas.Brush.Style := bsSolid;
  Canvas.FillRect(R);
  Canvas.Font.Assign(Self.Font);
  Canvas.Font.Color := IfThen(odSelected in State, clHighlightText, clWindowText);
  if Items.Objects[Index] <> TObject(1) then
  begin
    Canvas.Font.Name := Items[Index];
    Canvas.Font.Size := Max(Self.Font.Size, 14);
  end;
  Canvas.TextRect(R, S, [tfSingleLine, tfVerticalCenter]);
end;

procedure TFontCombobox.Loaded;
begin
  inherited;
  if Assigned(Parent) then
    Items.Assign(FFonts);
end;

procedure TFontCombobox.LoadFonts;
var
  LF: tagLOGFONTW;
begin
  FillChar(LF, sizeof(LF), 0);
  LF.lfCharSet := DEFAULT_CHARSET;
  FFonts.BeginUpdate;
  FFonts.Clear;
  try
    EnumFontFamiliesEx(GetDC(0), LF, @EnumFontFamExProc, NativeInt(Pointer(FFonts)), 0);
  finally
    FFonts.EndUpdate;
  end;
  FFonts.Sort;
end;

procedure TFontCombobox.LoadItems;
begin
  Items.Assign(FFonts);
end;

procedure TFontCombobox.WMMeasureItem(var Message: TWMMeasureItem);
var
  TM: TTextMetric;
  otmsize: cardinal;
  p: pointer;
  OTM: POutlineTextMetric absolute p;
begin
  if not InRange(Message.MeasureItemStruct.itemID, 0, FFonts.Count - 1) then
    Exit;

  Canvas.Font.Assign(Self.Font);
  if Message.MeasureItemStruct.itemID <> $FFFFFFFF then
  begin
    if FFonts.Objects[Message.MeasureItemStruct.itemID] <> TObject(1) then
    begin
      Canvas.Font.Size := Max(Self.Font.Size, 14);
      Canvas.Font.Name := FFonts[Message.MeasureItemStruct.itemID];
    end;
    GetTextMetrics(Canvas.Handle, TM);
    Message.MeasureItemStruct.itemHeight := TM.tmHeight + 2;
    otmsize := GetOutlineTextMetrics(Canvas.Handle, 0, nil);
    if otmsize > 0 then
    begin
      GetMem(p, otmsize);
      try
        OTM.otmSize := otmsize;
        if GetOutlineTextMetrics(Canvas.Handle, otmsize, p) <> 0 then
          Message.MeasureItemStruct.itemHeight := Abs(OTM.otmAscent) + Abs(OTM.otmDescent) + Abs(PInteger(@OTM.otmLineGap)^) + 4;
      finally
        FreeMem(p);
      end;
    end;
  end
  else
  begin
    GetTextMetrics(Canvas.Handle, TM);
    Message.MeasureItemStruct.itemHeight := TM.tmHeight;
  end;
  Message.Result := 1;
end;

end.
