asked on

Retrieve True Type Font in a combox.

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

Emmanuel PASQUIER

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 Kiers

ASKER

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 PASQUIER

Yes, you just have to draw the items yourself and draw a bitmap before the font name

Peter Kiers

ASKER

Do you know how?

P.

ASKER CERTIFIED SOLUTION

Emmanuel PASQUIER

membership