{
Copyright © 1998 by Delphi 4 Developer's Guide - Xavier Pacheco and Steve Teixeira
}

unit FontInfoFrm;

interface

uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, Dialogs, ExtCtrls, StdCtrls;

type

  TFontInfoForm = class(TForm)
    lbFontInfo: TListBox;
    procedure FormActivate(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  FontInfoForm: TFontInfoForm;

implementation
uses MainFrm;

{$R *.DFM}

procedure TFontInfoForm.FormActivate(Sender: TObject);
const
  PITCH_MASK: byte = $0F;  // Set the lower order four bits
  FAMILY_MASK: byte = $F0; // Set to higher order four bits
var
  TxMetric: TTextMetric;
  FaceName: String;
  PitchTest, FamilyTest: byte;
begin

  // Allocate memory for FaceName string
  SetLength(FaceName, lf_FaceSize+1);

  // First get the font information
  with MainForm.pbxFont.Canvas do
  begin
    GetTextFace(Handle, lf_faceSize-1, PChar(FaceName));
    GetTextMetrics(Handle, TxMetric);
  end;

  // Now add the font information to the listbox from the TTEXTMETRIC structure.
  with lbFontInfo.Items, TxMetric do
  begin
    Clear;
    Add('Font face name:     '+FaceName);
    Add('tmHeight:     '+IntToStr(tmHeight));
    Add('tmAscent:     '+IntToStr(tmAscent));
    Add('tmDescent:     '+IntToStr(tmDescent));
    Add('tmInternalLeading:     '+IntToStr(tmInternalLeading));
    Add('tmExternalLeading:     '+IntToStr(tmExternalLeading));
    Add('tmAveCharWidth:     '+IntToStr(tmAveCharWidth));
    Add('tmMaxCharWidth:     '+IntToStr(tmMaxCharWidth));
    Add('tmWeight:     '+IntToStr(tmWeight));

    if tmItalic <> 0  then
      Add('tmItalic: YES')
    else
      Add('tmItalic: NO');

    if tmUnderlined <> 0 then
      Add('tmUnderlined: YES')
    else
      Add('tmUnderlined: NO');

    if tmStruckOut <> 0 then
      Add('tmStruckOut: YES')
    else
      Add('tmStruckOut: NO');

    // Check the font's pitch type
    PitchTest := tmPitchAndFamily and PITCH_MASK;
    if (PitchTest and TMPF_FIXED_PITCH) = TMPF_FIXED_PITCH then
      Add('tmPitchAndFamily-Pitch: Fixed Pitch');
    if (PitchTest and TMPF_VECTOR) = TMPF_VECTOR then
      Add('tmPitchAndFamily-Pitch: Vector');
    if (PitchTest and TMPF_TRUETYPE) = TMPF_TRUETYPE then
      Add('tmPitchAndFamily-Pitch: True type');
    if (PitchTest and TMPF_DEVICE) = TMPF_DEVICE then
      Add('tmPitchAndFamily-Pitch: Device');
    if PitchTest = 0 then
      Add('tmPitchAndFamily-Pitch: Unknown');

    // Check the fonts family type
    FamilyTest := tmPitchAndFamily and FAMILY_MASK;
    if (FamilyTest and FF_ROMAN) = FF_ROMAN then
      Add('tmPitchAndFamily-Family: FF_ROMAN');
    if (FamilyTest and FF_SWISS) = FF_SWISS then
      Add('tmPitchAndFamily-Family: FF_SWISS');
    if (FamilyTest and FF_MODERN) = FF_MODERN then
      Add('tmPitchAndFamily-Family: FF_MODERN');
    if (FamilyTest and FF_SCRIPT) = FF_SCRIPT then
      Add('tmPitchAndFamily-Family: FF_SCRIPT');
    if (FamilyTest and FF_DECORATIVE) = FF_DECORATIVE then
      Add('tmPitchAndFamily-Family: FF_DECORATIVE');
    if FamilyTest = 0 then
      Add('tmPitchAndFamily-Family: Unknown');

    Add('tmCharSet:     '+IntToStr(tmCharSet));
    Add('tmOverhang:     '+IntToStr(tmOverhang));
    Add('tmDigitizedAspectX:     '+IntToStr(tmDigitizedAspectX));
    Add('tmDigitizedAspectY:     '+IntToStr(tmDigitizedAspectY));
  end;
end;

end.