Создание шрифтаDelphi , Графика и Игры , ШрифтыСоздание шрифтаАвтор: 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.Скачать весь проект В статье "Создание шрифта" описывается процесс создания и настройки шрифта в программировании на языке Delphi. Автор статьи Xavier Pacheco исследует свойства шрифта, такие как высота, ширина,pitch и family, и предоставляет пример кода для создания простог Комментарии и вопросыМатериалы статей собраны из открытых источников, владелец сайта не претендует на авторство. Там где авторство установить не удалось, материал подаётся без имени автора. В случае если Вы считаете, что Ваши права нарушены, пожалуйста, свяжитесь с владельцем сайта.
|
||||
©KANSoftWare (разработка программного обеспечения, создание программ, создание интерактивных сайтов), 2007 |