Автор: Xavier Pacheco

{
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.

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

unit MainFrm;

interface

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

const

  // Array to represent the TLOGFONT.lfCharSet values
  CharSetArray: array[0..4] of byte = (ANSI_CHARSET, DEFAULT_CHARSET,
    SYMBOL_CHARSET, SHIFTJIS_CHARSET, OEM_CHARSET);

  // Array to represent the TLOGFONT.lfWeight values
  WeightArray: array[0..9] of integer =
  (FW_DONTCARE, FW_THIN, FW_EXTRALIGHT, FW_LIGHT, FW_NORMAL, FW_MEDIUM,
    FW_SEMIBOLD, FW_BOLD, FW_EXTRABOLD, FW_HEAVY);

  // Array to represent the TLOGFONT.lfOutPrecision values
  OutPrecArray: array[0..7] of byte = (OUT_DEFAULT_PRECIS,
    OUT_STRING_PRECIS, OUT_CHARACTER_PRECIS, OUT_STROKE_PRECIS,
    OUT_TT_PRECIS, OUT_DEVICE_PRECIS, OUT_RASTER_PRECIS,
    OUT_TT_ONLY_PRECIS);

  // Array to represent the TLOGFONT.lfPitchAndFamily higher four-bit values
  FamilyArray: array[0..5] of byte = (FF_DONTCARE, FF_ROMAN,
    FF_SWISS, FF_MODERN, FF_SCRIPT, FF_DECORATIVE);

  // Array to represent the TLOGFONT.lfPitchAndFamily lower two-bit values
  PitchArray: array[0..2] of byte = (DEFAULT_PITCH, FIXED_PITCH,
    VARIABLE_PITCH);

  // Array to represent the TLOGFONT.lfClipPrecision values
  ClipPrecArray: array[0..6] of byte = (CLIP_DEFAULT_PRECIS,
    CLIP_CHARACTER_PRECIS, CLIP_STROKE_PRECIS, CLIP_MASK, CLIP_LH_ANGLES,
    CLIP_TT_ALWAYS, CLIP_EMBEDDED);

  // Array to represent the TLOGFONT.lfQuality values
  QualityArray: array[0..2] of byte = (DEFAULT_QUALITY, DRAFT_QUALITY,
    PROOF_QUALITY);

type

  TMainForm = class(TForm)
    lblHeight: TLabel;
    lblWidth: TLabel;
    gbEffects: TGroupBox;
    cbxItalic: TCheckBox;
    cbxUnderline: TCheckBox;
    cbxStrikeOut: TCheckBox;
    cbWeight: TComboBox;
    lblWeight: TLabel;
    lblEscapement: TLabel;
    cbEscapement: TComboBox;
    pbxFont: TPaintBox;
    cbCharSet: TComboBox;
    lblCharSet: TLabel;
    cbOutPrec: TComboBox;
    lblOutPrecision: TLabel;
    cbFontFace: TComboBox;
    rgPitch: TRadioGroup;
    cbFamily: TComboBox;
    lblFamily: TLabel;
    lblClipPrecision: TLabel;
    cbClipPrec: TComboBox;
    rgQuality: TRadioGroup;
    btnSetDefaults: TButton;
    btnFontInfo: TButton;
    lblFaceName: TLabel;
    rgGraphicsMode: TRadioGroup;
    lblOrientation: TLabel;
    cbOrientation: TComboBox;
    seHeight: TSpinEdit;
    seWidth: TSpinEdit;
    procedure pbxFontPaint(Sender: TObject);
    procedure FormActivate(Sender: TObject);
    procedure btnFontInfoClick(Sender: TObject);
    procedure btnSetDefaultsClick(Sender: TObject);
    procedure rgGraphicsModeClick(Sender: TObject);
    procedure cbEscapementChange(Sender: TObject);
    procedure FontChanged(Sender: TObject);
  private
    { Private declarations }
    FLogFont: TLogFont;
    FHFont: HFont;
    procedure MakeFont;
    procedure SetDefaults;
  public
    { Public declarations }
  end;

var
  MainForm: TMainForm;

implementation
uses FontInfoFrm;

{$R *.DFM}

procedure TMainForm.MakeFont;
begin
  // Clear the contents of FLogFont
  FillChar(FLogFont, sizeof(TLogFont), 0);
  // Set the TLOGFONT's fields
  with FLogFont do
  begin
    lfHeight := StrToInt(seHeight.Text);
    lfWidth := StrToInt(seWidth.Text);
    lfEscapement := StrToInt(cbEscapement.Items[cbEscapement.ItemIndex]);
    lfOrientation := StrToInt(cbOrientation.Items[cbOrientation.ItemIndex]);
    lfWeight := WeightArray[cbWeight.ItemIndex];
    lfItalic := ord(cbxItalic.Checked);
    lfUnderline := ord(cbxUnderLine.Checked);
    lfStrikeOut := ord(cbxStrikeOut.Checked);
    lfCharSet := CharSetArray[cbCharset.ItemIndex];
    lfOutPrecision := OutPrecArray[cbOutPrec.ItemIndex];
    lfClipPrecision := ClipPrecArray[cbClipPrec.ItemIndex];
    lfQuality := QualityArray[rgQuality.ItemIndex];
    lfPitchAndFamily := PitchArray[rgPitch.ItemIndex] or
      FamilyArray[cbFamily.ItemIndex];
    StrPCopy(lfFaceName, cbFontFace.Items[cbFontFace.ItemIndex]);
  end;
  // Retrieve the requested font
  FHFont := CreateFontIndirect(FLogFont);
  // Assign to the Font.Handle
  pbxFont.Font.Handle := FHFont;
  pbxFont.Refresh;
end;

procedure TMainForm.SetDefaults;
begin
  // Set the various conrols to default values for ALogFont
  seHeight.Text := '0';
  seWidth.Text := '0';
  cbxItalic.Checked := false;
  cbxStrikeOut.Checked := false;
  cbxUnderline.Checked := false;
  cbWeight.ItemIndex := 0;
  cbEscapement.ItemIndex := 0;
  cbOrientation.ItemIndex := 0;
  cbCharset.ItemIndex := 1;
  cbOutPrec.Itemindex := 0;
  cbFamily.ItemIndex := 0;
  cbClipPrec.ItemIndex := 0;
  rgPitch.ItemIndex := 0;
  rgQuality.ItemIndex := 0;
  // Fill CBFontFace TComboBox with the screen's fonts
  cbFontFace.Items.Assign(Screen.Fonts);
  cbFontFace.ItemIndex := cbFontFace.Items.IndexOf(Font.Name);
end;

procedure TMainForm.pbxFontPaint(Sender: TObject);
begin
  with pbxFont do
  begin
    { Note that in Windows 95, the graphics mode will always be GM_COMPATIBLE
      as GM_ADVANCED is recognized only by Windows NT. }
    case rgGraphicsMode.ItemIndex of
      0: SetGraphicsMode(pbxFont.Canvas.Handle, GM_COMPATIBLE);
      1: SetGraphicsMode(pbxFont.Canvas.Handle, GM_ADVANCED);
    end;
    Canvas.Rectangle(2, 2, Width - 2, Height - 2);
    // Write the fonts name
    Canvas.TextOut(Width div 2, Height div 2, CBFontFace.Text);
  end;
end;

procedure TMainForm.FormActivate(Sender: TObject);
begin
  SetDefaults;
  MakeFont;
end;

procedure TMainForm.btnFontInfoClick(Sender: TObject);
begin
  FontInfoForm.ShowModal;
end;

procedure TMainForm.btnSetDefaultsClick(Sender: TObject);
begin
  SetDefaults;
  MakeFont;
end;

procedure TMainForm.rgGraphicsModeClick(Sender: TObject);
begin
  cbOrientation.Enabled := rgGraphicsMode.ItemIndex = 1;
  if not cbOrientation.Enabled then
    cbOrientation.ItemIndex := cbEscapement.ItemIndex;
  MakeFont;
end;

procedure TMainForm.cbEscapementChange(Sender: TObject);
begin
  if not cbOrientation.Enabled then
    cbOrientation.ItemIndex := cbEscapement.ItemIndex;
end;

procedure TMainForm.FontChanged(Sender: TObject);
begin
  MakeFont;
end;

end.