Retrieve True Type Font in a combox.

Peter Kiers
Peter Kiers used Ask the Experts™
on
Dear experts,

Does someone know how to retrieve only the true type font
in a combobox. with ComboBox1.Items := Screen.Fonts; i
get them all.

I have put the code in the code-section.

Peter 
unit CharMap;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, Grids, Buttons;

type
  TCharacterMap = class(TForm)
    ComboBox1: TComboBox;
    StringGrid1: TStringGrid;
    Label1: TLabel;
    BitBtn1: TBitBtn;
    BitBtn2: TBitBtn;
    procedure StringGrid1DrawCell(Sender: TObject; ACol, ARow: Integer;
      Rect: TRect; State: TGridDrawState);
    procedure ComboBox1Change(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
    procedure WriteText(ACanvas: TCanvas; const ARect: TRect; const Text: string);
  public
    { Public declarations }
  end;

var
  CharacterMap: TCharacterMap;

implementation

{$R *.dfm}

procedure TCharacterMap.ComboBox1Change(Sender: TObject);
var
 i, z: Integer;
begin 
 StringGrid1.Font.Name := ComboBox1.Text;
 for z := 0 to 6 do
  for i := 0 to 31 do 
   StringGrid1.Cells[i, z] := Chr((i + 1) * (z + 1) + 31); 
end;
(*---------------------------------------------------*)
procedure TCharacterMap.FormCreate(Sender: TObject);
begin
 ComboBox1.Items := Screen.Fonts;
 ComboBox1.ItemIndex := 0;
ComboBox1Change(ComboBox1);
end;
(*---------------------------------------------------*)
procedure TCharacterMap.StringGrid1DrawCell(Sender: TObject; ACol,
  ARow: Integer; Rect: TRect; State: TGridDrawState);
begin
 WriteText(StringGrid1.Canvas, Rect, StringGrid1.Cells[acol, arow]);
end;
(*---------------------------------------------------*)
procedure TCharacterMap.WriteText(ACanvas: TCanvas; const ARect: TRect;
  const Text: string);
var
 S: array[0..255] of Char;
begin
 with ACanvas, ARect do
  ExtTextOut(Handle, Left + (Right - Left - TextWidth(Text)) div 2, Top + (Bottom - Top - TextHeight(Text)) div 2,
  ETO_OPAQUE or ETO_CLIPPED, @ARect, StrPCopy(S, Text), Length(Text), nil);
end;
(*---------------------------------------------------*)
end.

Open in new window

Comment
Watch Question

Do more with

Expert Office
EXPERT OFFICE® is a registered trademark of EXPERTS EXCHANGE®
View Solution Only
Emmanuel PASQUIERFreelance Project Manager
Top Expert 2010

Commented:
Use the following function

ComboBox1.Items.Clear;
for i:=0 to Screen.Fonts.Count-1 do
 if IsTrueTypeFont(Screen.Fonts[i])
  Then ComboBox1.Items.Add(Screen.Fonts[i]);
function IsTrueTypeFont(FontName : string):boolean;
const
  PITCH_MASK: byte = $0F;
var
  TxMet: TTextMetric;
  TempCanvas : TCanvas;
  PitchTest : byte;
begin
  TempCanvas:=TCanvas.Create;
  TempCanvas.Handle:=CreateCompatibleDC(0) ;
  TempCanvas.Font.Name:=FontName;
  GetTextMetrics(TempCanvas.Handle, TxMet) ;
  PitchTest:=TxMet.tmPitchAndFamily and PITCH_MASK;
  Result:=(PitchTest and TMPF_TRUETYPE) <> 0;
  TempCanvas.free;
end;

Open in new window

Peter KiersOperator

Author

Commented:
Thanks, i have made a picture of another application.
and it has the true type icon in it.
Is it possible to do it in mine.

P.
Example1.jpg
Emmanuel PASQUIERFreelance Project Manager
Top Expert 2010

Commented:
Yes, you just have to draw the items yourself and draw a bitmap before the font name
OWASP: Avoiding Hacker Tricks

Learn to build secure applications from the mindset of the hacker and avoid being exploited.

Start Today!
Peter KiersOperator

Author

Commented:
Do you know how?

P.
Freelance Project Manager
Top Expert 2010
Commented:
Yes, set style of your listbox to csOwnerDrawFixed
and implement the onDrawItem event

procedure TForm1.ComboBox1DrawItem(Control: TWinControl; Index: Integer;
  Rect: TRect; State: TOwnerDrawState);
begin
 With (Control As TComboBox).Canvas do
  begin
   Draw(Rect.Left+2,Rect.Top+2,BMP);
   TextOut(Rect.Left+32,Rect.Top+2,TComboBox(Control).Items[Index]);
  end;
end;

Open in new window

Peter KiersOperator

Author

Commented:
Thanks. 500 points are comming your way.

Peter

Do more with

Expert Office
Submit tech questions to Ask the Experts™ at any time to receive solutions, advice, and new ideas from leading industry professionals.

Start 7-Day Free Trial