Context Navigation

source: branches/2.20_branch/Components/CanvasFontManager.pas

Last change on this file was 210, checked in by RBRi, 18 years ago
using StringUtilsUnit
Property svn:eol-style set to `native`
File size: 31.7 KB

Line
1	Unit CanvasFontManager;
2
3	Interface
4
5	Uses
6	OS2Def,
7	Classes,
8	Forms,
9	PMWIN,
10	Graphics;
11
12	Const
13	// This defines the fraction of a pixel that
14	// font character widths will be given in
15	FontWidthPrecisionFactor = 256;
16
17	Type
18	// a user-oriented specification of a font;
19	// does not include OS/2 API data
20	TFontSpec = record
21	FaceName: string[ 64 ];
22	PointSize: integer; // if 0 then use x/y size
23	XSize: integer;
24	YSize: integer;
25	Attributes: TFontAttributes; // set of faBold, faItalic etc
26	end;
27
28	// NOTE: Char widths are in 1/FontWidthPrecisionFactor units
29	TCharWidthArray = array[ #0..#255 ] of longint;
30	TPCharWidthArray = ^ TCharWidthArray;
31
32	// Used internally for storing full info on font
33	TLogicalFont= Class( TComponent )
34	pFaceName: pstring; // user-selected name
35	pUseFaceName: pstring; // after substitutions.
36
37	// Selected bits of FONTMETRICS
38	fsSelection: USHORT;
39
40	FontType: TFontType;
41	FixedWidth: boolean;
42	PointSize: integer;
43	ID: integer;
44	Attributes: TFontAttributes;
45
46	// this can be nil if not already fetched
47	pCharWidthArray: TPCharWidthArray;
48	lMaxbaselineExt: LONG;
49	lAveCharWidth: LONG;
50	lMaxCharInc: LONG;
51	lMaxDescender: LONG;
52
53	destructor Destroy; override;
54	end;
55
56	TFontFace = class
57	pName: pstring;
58	FixedWidth: boolean;
59	FontType: TFontType;
60
61	Sizes: TList; // relevant for bitmap fonts only
62	// contains TLogicalFont objects
63	constructor Create;
64	destructor Destroy; override;
65	end;
66
67	TCanvasFontManager = class
68	protected
69	FCanvas: TCanvas;
70	FLogicalFonts: TList;
71	FCurrentFontSpec: TFontSpec;
72	FDefaultFontSpec: TFontSpec;
73	FCurrentFont: TLogicalFont;
74	FAllowBitmapFonts: boolean;
75
76	protected
77	function CreateFont( const FontSpec: TFontSpec ): TLogicalFont;
78
79	function GetFont( const FontSpec: TFontSpec ): TLogicalFont;
80
81	procedure RegisterFont( Font: TLogicalFont );
82	procedure SelectFont( Font: TLogicalFont;
83	Scale: longint );
84
85	// Retrieve character widths for current font
86	procedure LoadMetrics;
87
88	// load metrics if needed
89	procedure EnsureMetricsLoaded;
90	public
91	Constructor Create( Canvas: TCanvas;
92	AllowBitmapFonts: boolean );
93	destructor Destroy; override;
94
95	// Useful functions:
96
97	// Set the font for the associated canvas.
98	procedure SetFont( const FontSpec: TFontSpec );
99
100	// Retrieve the width of the given char, in the current font
101	function CharWidth( const C: Char ): longint;
102
103	function AverageCharWidth: longint;
104	function MaximumCharWidth: longint;
105
106	function IsFixed: boolean;
107
108	function CharHeight: longint;
109	function CharDescender: longint;
110
111	procedure DrawString( Var Point: TPoint;
112	const Length: longint;
113	const S: PChar );
114
115	property Canvas: TCanvas read FCanvas;
116	property DefaultFontSpec: TFontSpec read FDefaultFontSpec write FDefaultFontSpec;
117	end;
118
119	// Convert a Sibyl font to a FontSpec (Color is left the same)
120	procedure SibylFontToFontSpec( Font: TFont; Var FontSpec: TFontSpec );
121
122	// Thoughts on how it works....
123
124	// SelectFont looks for an existing logical font that
125	// matches the request. If found selects that logical font
126	// onto the canvas.
127
128	// If not found it creates a logical font and selects that onto
129	// the canvas.
130
131	// For bitmap fonts the logical font definition includes pointsize
132	// For outline fonts the defn is only face+attr; in this case
133	// selectfont also ses the 'CharBox' according to the point size.
134	Implementation
135
136	uses
137	PMWin,
138	PMGpi,
139	OS2Def,
140	PmDev,
141	SysUtils,
142	StringUtilsUnit;
143
144	Imports
145	Function GpiQueryCharStringPosAt( PS: Hps;
146	StartPoint: PPointL;
147	Options: ULONG;
148	Count: LONG;
149	TheString: PChar;
150	IncrementsArray: PLONG;
151	CharacterPoints: PPointL ): BOOL;
152	ApiEntry; 'PMGPI' Index 585;
153	Function GpiQueryCharStringPos( PS: Hps;
154	Options: ULONG;
155	Count: LONG;
156	TheString: PChar;
157	IncrementsArray: PLONG;
158	CharacterPoints: PPointL ): BOOL;
159	ApiEntry; 'PMGPI' Index 584;
160	end;
161
162	Type
163	// A little pretend window to send font name.size
164	// and get definite font info back. (See .CreateFont)
165	TFontWindow = class( TControl )
166	public
167	procedure CreateWnd; override;
168	property OwnerDraw;
169	Function SetPPFontNameSize( Const FNS: String ): Boolean;
170	end;
171
172	var
173	FontFaces: TList = nil; // of TFontface
174	FontWindow: TFontWindow;
175
176	DefaultOutlineFixedFace: TFontFace;
177	DefaultOutlineProportionalFace: TFontFace;
178
179	// TFontFace
180	//------------------------------------------------------------------------
181
182	constructor TFontface.Create;
183	begin
184	Sizes := TList.Create;
185	end;
186
187	destructor TFontface.Destroy;
188	begin
189	Sizes.Destroy;
190	end;
191
192	// TLogicalFont
193	//------------------------------------------------------------------------
194
195	// frees allocated memory, if any.
196	// Note - does not delete the Gpi Logical Font
197	destructor TLogicalFont.Destroy;
198	begin
199	DisposeStr( pFaceName );
200	DisposeStr( pUseFaceName );
201
202	if pCharWidthArray <> nil then
203	FreeMem( pCharWidthArray,
204	sizeof( TCharWidthArray ) );
205
206	inherited Destroy;
207	end;
208
209	// TFontWindow
210	//------------------------------------------------------------------------
211
212	procedure TFontWindow.CreateWnd;
213	begin
214	inherited CreateWnd;
215	end;
216
217	Function TFontWindow.SetPPFontNameSize( Const FNS: String ): Boolean;
218	Var
219	CS: Cstring;
220	Begin
221	CS := FNS;
222
223	Result := WinSetPresParam( Handle,
224	PP_FONTNAMESIZE,
225	Length( CS ) + 1,
226	CS );
227	End;
228
229	//------------------------------------------------------------------------
230
231	// Convert a Sibyl font to a FontSpec
232	//------------------------------------------------------------------------
233	procedure SibylFontToFontSpec( Font: TFont; Var FontSpec: TFontSpec );
234	begin
235	FontSpec.FaceName := Font.FaceName;
236	FontSpec.PointSize := Font.PointSize;
237	FontSpec.Attributes := Font.Attributes;
238	end;
239
240	// Find a font face with the given name
241	//------------------------------------------------------------------------
242	function FindFaceName( const name: string ): TFontFace;
243	Var
244	FaceIndex: LongInt;
245	Face: TFontFace;
246	begin
247	for FaceIndex := 0 to FontFaces.Count - 1 do
248	begin
249	Face := FontFaces[ FaceIndex ];
250
251	if StrEqualIgnoringCase( Face.pName^, Name ) then
252	begin
253	Result := Face;
254	exit;
255	end;
256	end;
257	Result := nil;
258	end;
259
260	// Return the first font face of type = Outline (scalable)
261	//------------------------------------------------------------------------
262	function GetFirstOutlineFace( FixedWidth: boolean ): TFontFace;
263	Var
264	FaceIndex: LongInt;
265	Face: TFontFace;
266	begin
267	for FaceIndex := 0 to FontFaces.Count - 1 do
268	begin
269	Face := FontFaces[ FaceIndex ];
270
271	if ( Face.FixedWidth = FixedWidth )
272	and ( Face.FontType = ftOutline ) then
273	begin
274	Result := Face;
275	exit;
276	end;
277	end;
278	Result := nil;
279	end;
280
281	// Find the bitmap font which best matches the given pointsize.
282	//------------------------------------------------------------------------
283	function GetClosestBitmapFixedFont( const PointSize: longint ): TLogicalFont;
284	Var
285	FaceIndex: Longint;
286	FontIndex: longint;
287	Face: TFontFace;
288	Font: TLogicalFont;
289	begin
290	Result := nil;
291	for FaceIndex := 0 to FontFaces.Count - 1 do
292	begin
293	Face := FontFaces[ FaceIndex ];
294
295	if Face.FontType = ftBitmap then
296	begin
297	for FontIndex := 0 to Face.Sizes.Count - 1 do
298	begin
299	Font := Face.Sizes[ FontIndex ];
300	if Font.FixedWidth then
301	begin
302	if ( Result = nil )
303	or ( Abs( Font.PointSize - PointSize )
304	< Abs( Result.PointSize - PointSize ) ) then
305	Result := Font;
306	end;
307	end;
308	end;
309	end;
310	end;
311
312	// Pick some nice default fonts.
313	//------------------------------------------------------------------------
314	procedure GetDefaultFonts;
315	begin
316	// courier new is common and reasonably nice
317	DefaultOutlineFixedFace := FindFaceName( 'Courier New' );
318	if DefaultOutlineFixedFace = nil then
319	begin
320	DefaultOutlineFixedFace := GetFirstOutlineFace( true ); // first fixed outline face
321	end;
322
323	DefaultOutlineProportionalFace := FindFaceName( 'Helvetica' );
324	if DefaultOutlineProportionalFace = nil then
325	begin
326	DefaultOutlineProportionalFace := GetFirstOutlineFace( false ); // first prop outline face
327	end;
328	end;
329
330	Type
331	TMyFontMetrics = Array[ 0..1 ] Of FONTMETRICS;
332	PMyFontMetrics = ^TMyFontMetrics;
333
334	// Fetch the global list of font faces and sizes
335	//------------------------------------------------------------------------
336	procedure GetFontList;
337	Var
338	Count: LongInt;
339	aPS: HPS;
340	T: LongInt;
341	Font: TLogicalFont;
342	Face: TFontFace;
343	pfm: PMyFontMetrics;
344	FamilyName: string;
345	fsDefn: USHORT;
346	Begin
347	FontFaces := TList.Create;
348
349	aPS := WinGetPS( HWND_DESKTOP );
350	Count := 0;
351	// Get font count
352	Count := GpiQueryFonts( aPS,
353	QF_PUBLIC,
354	Nil,
355	Count,
356	0,
357	Nil );
358	If Count > 0 Then
359	Begin
360	// allocate memory to retrieve all the font data.
361	GetMem( pfm, Count * SizeOf( FONTMETRICS ) );
362	GpiQueryFonts( aPS,
363	QF_PUBLIC,
364	Nil,
365	Count,
366	SizeOf(FONTMETRICS),
367	pfm^[ 0 ] );
368
369	For T := 0 To Count - 1 Do
370	Begin
371	Font := TLogicalFont.Create( Screen );
372
373	Font.pFaceName := NewStr( pfm^[ T ].szFaceName );
374	FamilyName := pfm^[ T ].szFamilyName;
375
376	// See what type it is. Actually this is not very
377	// useful as various substitutions are normally made.
378	fsDefn := pfm^[ T ].fsDefn;
379	If ( fsDefn And FM_DEFN_OUTLINE ) <> 0 Then
380	Font.FontType := ftOutline
381	else
382	Font.FontType := ftBitmap;
383
384	if Font.pFaceName^ = 'Helvetica' then
385	Font := Font;
386	Font.PointSize := pfm^[ T ].sNominalPointSize div 10;
387	Font.FixedWidth := pfm^[ T ].fsType And FM_TYPE_FIXED <> 0 ;
388	Font.fsSelection := pfm^[ T ].fsSelection;
389	Font.lMaxbaselineExt := pfm^[ T ].lMaxbaselineExt;
390	Font.lAveCharWidth := pfm^[ T ].lAveCharWidth;
391	Font.lMaxCharInc := pfm^[ T ].lMaxCharInc;
392
393	Font.ID := -1; // and always shall be so...
394
395	Face := FindFaceName( Font.pFaceName^ );
396	if Face = nil then
397	begin
398	// new face found
399	Face := TFontFace.Create;
400	Face.pName := Font.pFaceName; // point to the actual face name string!
401	Face.FixedWidth := Font.FixedWidth;
402	Face.FontType := Font.FontType;
403	FontFaces.Add( Face );
404	end;
405	Face.Sizes.Add( Font );
406	End;
407	End;
408
409	FreeMem( pfm, Count * SizeOf( FONTMETRICS ) );
410	WinReleasePS( aPS );
411
412	// pick some for defaults
413	GetDefaultFonts;
414
415	FontWindow := TFontWindow.Create( Nil );
416	FontWindow.OwnerDraw := True;
417	FontWindow.CreateWnd;
418	end;
419
420	// Add .subscript to font name for attributes
421	//------------------------------------------------------------------------
422	Function ModifyFontName( const FontName: string;
423	const Attrs: TFontAttributes ): String;
424	Begin
425	Result := FontName;
426	If faItalic in Attrs Then
427	Result := Result + '.Italic';
428	If faBold in Attrs Then
429	Result := Result + '.Bold';
430	If faOutline in Attrs Then
431	Result := Result + '.Outline';
432	If faStrikeOut in Attrs Then
433	Result := Result + '.Strikeout';
434	If faUnderScore in Attrs Then
435	Result := Result + '.Underscore';
436	End;
437
438	// Create a font without attributes
439	//------------------------------------------------------------------------
440	function CreateFontBasic( const FaceName: string;
441	const PointSize: integer ): TLogicalFont;
442	var
443	PPString: string;
444	PresSpace: HPS;
445	FontInfo: FONTMETRICS;
446	begin
447	Result := TLogicalFont.Create( nil );
448
449	if FindFaceName( FaceName ) = nil then
450	exit;
451
452	Result.PointSize := PointSize; // will use later if the result was an outline font...
453	Result.pFaceName := NewStr( FaceName );
454
455	// OK now we have found the font face...
456	PPString := IntToStr( PointSize) + '.' + FaceName;
457
458	PPString := ModifyFontName( PPString, [] );
459	If Not FontWindow.SetPPFontNameSize( PPString ) Then
460	// Gurk!
461	Exit;
462
463	PresSpace := WinGetPS( FontWindow.Handle );
464	If Not GpiQueryFontMetrics( PresSpace,
465	SizeOf( FONTMETRICS ),
466	FontInfo ) Then
467	begin
468	// Clurkle!?
469	WinReleasePS( PresSpace );
470	Exit;
471	end;
472	WinReleasePS( PresSpace );
473
474	if ( FontInfo.fsDefn And FM_DEFN_OUTLINE ) > 0 then
475	Result.FontType := ftOutline
476	else
477	Result.FontType := ftBitmap;
478	end;
479
480	// Provide outline substitutes for some common bitmap fonts
481	// From Mozilla/2 source.
482	//------------------------------------------------------------------------
483	function SubstituteBitmapFontToOutline( const FaceName: string ): string;
484	begin
485	if StrEqualIgnoringCase( FaceName, 'Helv' ) then
486	result := 'Helvetica'
487	else if StrEqualIgnoringCase( FaceName, 'Tms Rmn' ) then
488	result := 'Times New Roman'
489	else if StrEqualIgnoringCase( FaceName, 'System Proportional' ) then
490	result := 'Helvetica'
491	else if StrEqualIgnoringCase( FaceName, 'System Monospaced' ) then
492	result := 'Courier'
493	else if StrEqualIgnoringCase( FaceName, 'System VIO' ) then
494	result := 'Courier'
495	else
496	result := FaceName; // no substitution
497
498	end;
499
500	// NOTE!!! Not currently used or working...
501	// Find a font with exact width and height
502	//------------------------------------------------------------------------
503	function FindXYSizeFont( const Face: TFontFace;
504	const XSize: longint;
505	const YSize: longint ): TLogicalFont;
506	var
507	SizeIndex: longint;
508	F: TLogicalFont;
509	FontInfo: FONTMETRICS;
510	begin
511	for SizeIndex := 0 to Face.Sizes.Count - 1 do
512	begin
513	F := Face.Sizes[ SizeIndex ];
514	if ( F.lMaxbaselineExt = YSize )
515	and ( F.lAveCharWidth = XSize ) then
516	begin
517	// found exact match
518	FontInfo.lMaxbaselineExt := F.lMaxbaselineExt;
519	FontInfo.lAveCharWidth := F.lAveCharWidth;
520	Result.FontType := ftBitmap;
521	end;
522	end;
523	end;
524
525	// Ask OS/2 dummy font window to convert a font spec
526	// into a FONTMETRICS.
527	//------------------------------------------------------------------------
528	procedure AskOS2FontDetails( const FaceName: string;
529	const PointSize: longint;
530	const Attributes: TFontAttributes;
531	var FontInfo: FONTMETRICS );
532	var
533	PPString: string;
534	PresSpace: HPS;
535	begin
536	// Hack from Sibyl code - we don't know WTF the algorithm is
537	// for selecting between outline/bitmap and doing substitutions
538	// so send it to a dummy window and find out the resulting details
539	PPString := IntToStr( PointSize )
540	+ '.'
541	+ FaceName;
542
543	PPString := ModifyFontName( PPString, Attributes );
544
545	FontWindow.SetPPFontNameSize( PPString );
546
547	PresSpace := WinGetPS( FontWindow.Handle );
548	GpiQueryFontMetrics( PresSpace,
549	SizeOf( FontInfo ),
550	FontInfo );
551	WinReleasePS( PresSpace );
552	end;
553
554	// Look for the best match for the given face, size and attributes.
555	// If FixedWidth is set then makes sure that the result is fixed
556	// (if there is any fixed font on the system at all!)
557	// This uses the OS/2 GPI and therefore makes some substitutions,
558	// such as Helv 8 (bitmap) for Helvetica 8 (outline)
559	//------------------------------------------------------------------------
560	procedure FindBestFontMatch( const FaceName: string;
561	const PointSize: longint;
562	const Attributes: TFontAttributes;
563	const FixedWidth: boolean;
564	var FontInfo: FONTMETRICS );
565	var
566	BestBitmapFontMatch: TLogicalFont;
567	begin
568	// First just ask GPI to give us a font
569	AskOS2FontDetails( FaceName,
570	PointSize,
571	Attributes,
572	FontInfo );
573
574	if not FixedWidth then
575	// OK, whatever it gave us.
576	exit;
577
578	// we want a fixed width font...
579	if ( FontInfo.fsType and FM_TYPE_FIXED ) <> 0 then
580	// got a suitable font
581	exit;
582
583	// the stoopid freaking OS/2 GPI has given us
584	// a proportional font for that size
585	if DefaultOutlineFixedFace <> nil then
586	// use the default fixed width outline face
587	AskOS2FontDetails( DefaultOutlineFixedFace.pName^,
588	PointSize,
589	Attributes,
590	FontInfo );
591
592
593	if ( FontInfo.fsType and FM_TYPE_FIXED ) <> 0 then
594	// got a suitable font
595	exit;
596
597	// still got a proportional font,
598	// or we didn't have any fixed width outline face
599	// so see what we can find in the way of a bitmap fixed font
600
601	BestBitmapFontMatch := GetClosestBitmapFixedFont( PointSize );
602	if BestBitmapFontMatch <> nil then
603	begin
604	FontInfo.lMaxbaseLineExt := BestBitmapFontMatch.lMaxbaselineExt;
605	FontInfo.lAveCharWidth := BestBitmapFontMatch.lAveCharWidth;
606	FontInfo.fsDefn := 0;
607	FontInfo.szFaceName := BestBitmapFontMatch.pFaceName^;
608	end;
609	// else - there are no fixed fonts of any kind on the system. Oh dear.
610
611	end;
612
613	//------------------------------------------------------------------------
614	// Font manager
615	//------------------------------------------------------------------------
616
617	// constructor
618	//------------------------------------------------------------------------
619	constructor TCanvasFontManager.Create( Canvas: TCanvas;
620	AllowBitmapFonts: boolean );
621	begin
622	inherited Create;
623
624	if FontFaces = nil then
625	GetFontList;
626
627	FCanvas := Canvas;
628	FLogicalFonts := TList.Create;
629	FCurrentFontSpec.FaceName := 'notafont';
630	FCurrentFont := nil;
631	FAllowBitmapFonts := AllowBitmapFonts;
632
633	// get system default font spec
634	// as default default ;)
635	SibylFontToFontSpec( Screen.DefaultFont,
636	FDefaultFontSpec );
637
638	end;
639
640	// Destructor
641	//------------------------------------------------------------------------
642	destructor TCanvasFontManager.Destroy;
643	var
644	i: integer;
645	Font: TLogicalFont;
646	rc: ERRORID;
647	begin
648	// select default font so none of our logical fonts are in use
649	if not GpiSetCharSet( FCanvas.Handle, LCID_DEFAULT ) then
650	rc := WinGetLastError( AppHandle );
651
652	// delete each logical font and our record of it
653	for i := 0 to FLogicalFonts.Count - 1 do
654	begin
655	Font := FLogicalFonts[ i ];
656	if not GpiDeleteSetID( FCanvas.Handle, Font.ID ) then
657	rc := WinGetLastError( AppHandle );
658	Font.Destroy;
659	end;
660	FLogicalFonts.Destroy;
661	inherited Destroy;
662	end;
663
664	// Create a logical font for the given spec
665	//------------------------------------------------------------------------
666	function TCanvasFontManager.CreateFont( const FontSpec: TFontSpec ): TLogicalFont;
667	var
668	UseFaceName: string;
669	Face: TFontFace;
670	RemoveBoldFromSelection: boolean;
671	RemoveItalicFromSelection: boolean;
672	UseAttributes: TFontAttributes;
673	MatchAttributes: TFontAttributes;
674	BaseFont: TLogicalFont;
675	BaseFontIsBitmapFont: Boolean;
676	FontInfo: FONTMETRICS;
677	FixedWidth: boolean;
678	begin
679	Face := nil;
680	RemoveBoldFromSelection := false;
681	RemoveItalicFromSelection := false;
682
683	UseAttributes := FontSpec.Attributes;
684
685	// see if the originally specified font is a fixed width one.
686	FixedWidth := false;
687	Face := FindFaceName( FontSpec.FaceName );
688	if Face <> nil then
689	FixedWidth := Face.FixedWidth;
690
691	Face := nil;
692
693	if not FAllowBitmapFonts then
694	UseFaceName := SubstituteBitmapFontToOutline( FontSpec.FaceName )
695	else
696	UseFaceName := FontSpec.FaceName;
697
698	if FontSpec.Attributes <> [] then
699	begin
700	BaseFontIsBitmapFont := false;
701	if FAllowBitmapFonts then
702	begin
703	// First see if the base font (without attributes)
704	// would be a bitmap font...
705	BaseFont := CreateFontBasic( UseFaceName, FontSpec.PointSize );
706	if BaseFont <> nil then
707	begin
708	BaseFontIsBitmapFont := BaseFont.FontType = ftBitmap;
709	BaseFont.Destroy;
710	end;
711	end;
712
713	If not BaseFontIsBitmapFont Then
714	begin
715	// Result is an outline font so look for specific bold/italic fonts
716	if ( faBold in FontSpec.Attributes )
717	and ( faItalic in FontSpec.Attributes ) then
718	begin
719	Face := FindFaceName( UseFaceName + ' BOLD ITALIC' );
720	if Face <> nil then
721	begin
722	Exclude( UseAttributes, faBold );
723	Exclude( UseAttributes, faItalic );
724	RemoveBoldFromSelection := true;
725	RemoveItalicFromSelection := true;
726	end;
727	end;
728
729	if Face = nil then
730	if faBold in FontSpec.Attributes then
731	begin
732	Face := FindFaceName( UseFaceName + ' BOLD' );
733	if Face <> nil then
734	begin
735	Exclude( UseAttributes, faBold );
736	RemoveBoldFromSelection := true;
737	end;
738	end;
739
740	if Face = nil then
741	if faItalic in FontSpec.Attributes then
742	begin
743	Face := FindFaceName( UseFaceName + ' ITALIC' );
744	if Face <> nil then
745	begin
746	Exclude( UseAttributes, faItalic );
747	RemoveItalicFromSelection := true;
748	end;
749	end;
750	end;
751	end;
752
753	if Face <> nil then
754	// found a styled face, does it match fixed width?
755	if Face.FixedWidth <> FixedWidth then
756	// no so we don't want to use it.
757	Face := nil;
758
759	if Face = nil then
760	// didn't find a styled face (or no styles set)
761	// so find unmodified, we will use simulation bits
762	Face := FindFaceName( UseFaceName );
763
764	if not FAllowBitmapFonts then
765	if Face.FontType = ftBitmap then
766	// we aren't allowed bitmaps, but that's what this
767	// face is. So use the default outline face of the
768	// appropriate width type
769	if FixedWidth then
770	Face := DefaultOutlineFixedFace
771	else
772	Face := DefaultOutlineProportionalFace;
773
774	if Face = nil then
775	begin
776	// Could not find the specified font name. Bummer.
777	Result := nil;
778	exit;
779	end;
780
781	// OK now we have found the font face...
782
783	Result := TLogicalFont.Create( nil );
784
785	Result.PointSize := FontSpec.PointSize; // will use later if the result was an outline font...
786	Result.pFaceName := NewStr( FontSpec.FaceName );
787	Result.pUseFaceName := NewStr( Face.pName^ );
788	Result.Attributes := FontSpec.Attributes;
789
790	Result.fsSelection := 0;
791
792	Result.FixedWidth := Face.FixedWidth;
793
794	if FAllowBitmapFonts then
795	begin
796	if BaseFontIsBitmapFont then
797	MatchAttributes := []
798	else
799	MatchAttributes := UseAttributes;
800	FindBestFontMatch( Face.pName^,
801	FontSpec.PointSize,
802	MatchAttributes,
803	FixedWidth,
804	FontInfo );
805
806	AssignStr( Result.pUseFaceName, FontInfo.szFaceName );
807
808	// We may actually get a bitmap OR an outline font back
809	If ( FontInfo.fsDefn And FM_DEFN_OUTLINE ) <> 0 Then
810	Result.FontType := ftOutline
811	else
812	Result.FontType := ftBitmap;
813	end
814	else
815	begin
816	// no bitmap fonts please.
817	Result.FontType := ftOutline
818	end;
819
820	// store the baseline and average char width.
821	// For bitmap fonts, these tell GPI which font we really want
822	// For outline fonts, we are just storing them for later ref.
823	Result.lMaxbaseLineExt := FontInfo.lMaxbaselineExt;
824	Result.lAveCharWidth := FontInfo.lAveCharWidth;
825	Result.lMaxCharInc := FontInfo.lMaxCharInc;
826
827	// Set style flags
828	with Result do
829	begin
830	If faBold in UseAttributes Then
831	fsSelection := fsSelection or FM_SEL_BOLD;
832	If faItalic in UseAttributes Then
833	fsSelection := fsSelection or FM_SEL_ITALIC;
834	If faUnderScore in UseAttributes Then
835	fsSelection := fsSelection or FM_SEl_UNDERSCORE;
836	If faStrikeOut in UseAttributes Then
837	fsSelection := fsSelection or FM_SEl_STRIKEOUT;
838	If faOutline in UseAttributes Then
839	fsSelection := fsSelection or FM_SEl_OUTlINE;
840	end;
841
842	Result.pCharWidthArray := Nil;
843	end;
844
845	// Register the given logical font with GPI and store for later use
846	//------------------------------------------------------------------------
847	procedure TCanvasFontManager.RegisterFont( Font: TLogicalFont );
848	var
849	fa: FATTRS;
850	rc: LONG;
851	begin
852	FLogicalFonts.Add( Font );
853	Font.ID := FLogicalFonts.Count + 1; // add 1 to stay out of Sibyl's way
854
855	// Initialise GPI font attributes
856	FillChar( fa, SizeOf( FATTRS ), 0 );
857	fa.usRecordLength := SizeOf( FATTRS );
858
859	// Copy facename and 'simulation' attributes from what we obtained
860	// earlier
861	fa.szFaceName := Font.pUseFaceName^;
862	fa.fsSelection := Font.fsSelection;
863
864	fa.lMatch := 0; // please Mr GPI be helpful and do clever stuff for us, we are ignorant
865
866	fa.idRegistry := 0; // IBM magic number
867	fa.usCodePage := 0; // use current codepage
868
869	If Font.FontType = ftOutline then
870	// Outline font wanted
871	fa.fsFontUse := FATTR_FONTUSE_OUTLINE Or FATTR_FONTUSE_TRANSFORMABLE
872	else
873	// bitmap font
874	fa.fsFontUse := 0;
875
876	// don't need mixing with graphics (for now)
877	fa.fsFontUse := fa.fsFontUse or FATTR_FONTUSE_NOMIX;
878
879	// copy char cell width/height from the (valid) one we
880	// found earlier in GetFont (will be zero for outline)
881	fa.lMaxbaseLineExt := Font.lMaxbaselineExt;
882	fa.lAveCharWidth := Font.lAveCharWidth;
883
884	fa.fsType := 0;
885
886	// create logical font
887	rc := GpiCreateLogFont( FCanvas.Handle,
888	nil,
889	Font.ID,
890	fa );
891	end;
892
893	// Select the given (existing) logical font
894	//------------------------------------------------------------------------
895	procedure TCanvasFontManager.SelectFont( Font: TLogicalFont;
896	Scale: longint );
897	var
898	aHDC: HDC;
899	xRes: LongInt;
900	yRes: LongInt;
901	aSizeF: SIZEF;
902	begin
903	// Select the logical font
904	GpiSetCharSet( FCanvas.Handle, Font.ID );
905	if Font.FontType = ftOutline then
906	begin
907	// For outline fonts, also set character Box
908	aHDC := GpiQueryDevice( FCanvas.Handle );
909	DevQueryCaps( aHDC,
910	CAPS_HORIZONTAL_FONT_RES,
911	1,
912	xRes );
913	DevQueryCaps( aHDC,
914	CAPS_VERTICAL_FONT_RES,
915	1,
916	yRes );
917
918	aSizeF.CX := 65536 * xRes* Font.PointSize Div 72 * Scale;
919	aSizeF.CY := 65536 * yRes* Font.PointSize Div 72 * Scale;
920
921	GpiSetCharBox( FCanvas.Handle, aSizeF );
922	end;
923	end;
924
925	// Get a font to match the given spec, creating or re-using an
926	// existing font as needed.
927	//------------------------------------------------------------------------
928	function TCanvasFontManager.GetFont( const FontSpec: TFontSpec ): TLogicalFont;
929	var
930	AFont: TLogicalFont;
931	FontIndex: integer;
932	begin
933	for FontIndex := 0 to FLogicalFonts.Count - 1 do
934	begin
935	AFont := FLogicalFonts[ FontIndex ];
936	if AFont.PointSize = FontSpec.PointSize then
937	begin
938	if ( AFont.PointSize > 0 )
939	or ( ( AFont.lAveCharWidth = FontSpec.XSize )
940	and ( AFont.lMaxbaselineExt = FontSpec.YSize ) ) then
941	begin
942	if AFont.Attributes = FontSpec.Attributes then
943	begin
944	// search name last since it's the slowest thing
945	if AFont.pFaceName^ = FontSpec.FaceName then
946	begin
947	// Found a logical font already created
948	Result := AFont;
949	// done
950	exit;
951	end;
952	end;
953	end;
954	end;
955	end;
956
957	// Need to create new logical font
958	Result := CreateFont( FontSpec );
959	if Result <> nil then
960	begin
961	RegisterFont( Result );
962	end;
963	end;
964
965	// Set the current font for the canvas to match the given
966	// spec, creating or re-using fonts as needed.
967	//------------------------------------------------------------------------
968	procedure TCanvasFontManager.SetFont( const FontSpec: TFontSpec );
969	var
970	Font: TLogicalFont;
971	DefaultFontSpec: TFontSpec;
972	begin
973	if FCurrentFontSpec = FontSpec then
974	// same font
975	exit;
976
977	Font := GetFont( FontSpec );
978
979	if Font = nil then
980	begin
981	// ack! Pfffbt! Couldn't find the font.
982
983	// Try to get the default font
984	Font := GetFont( FDefaultFontSpec );
985	if Font = nil then
986	begin
987	SibylFontToFontSpec( Screen.DefaultFont,
988	DefaultFontSpec );
989	Font := GetFont( DefaultFontSpec );
990	if Font = nil then
991	// Jimminy! We can't even get the default system font
992	raise Exception.Create( 'Could not access default font '
993	+ 'in place of '
994	+ FontSpec.FaceName
995	+ ' '
996	+ IntToStr( FontSpec.PointSize ) );
997	end;
998
999	end;
1000
1001	SelectFont( Font, 1 );
1002	FCurrentFontSpec := FontSpec;
1003	FCurrentFont := Font;
1004	end;
1005
1006	// Get the widths of all characters for current font
1007	// and other dimensions
1008	//------------------------------------------------------------------------
1009	procedure TCanvasFontManager.LoadMetrics;
1010	var
1011	TheChar: Char;
1012	fm: FONTMETRICS;
1013	begin
1014	// Retrieve all character widths
1015	if FCurrentFont.FontType = ftOutline then
1016	begin
1017	SelectFont( FCurrentFont, FontWidthPrecisionFactor );
1018	end;
1019
1020	// allocate memory for storing the char widths
1021	GetMem( FCurrentFont.pCharWidthArray,
1022	sizeof( TCharWidthArray ) );
1023	if not GpiQueryWidthTable( FCanvas.Handle,
1024	0, 256,
1025	FCurrentFont.pCharWidthArray^[ #0 ] ) then
1026	begin
1027	raise Exception.Create( 'Error getting character width table: '
1028	+ 'GpiQueryWidthTable error '
1029	+ IntToStr( WinGetLastError( AppHandle ) ) );
1030	end;
1031
1032	// Convert all widths to positive!
1033	// For unknown reason, sometimes GPI returns negative values...
1034	for TheChar := #0 to #255 do
1035	begin
1036	FCurrentFont.pCharWidthArray^[ TheChar ] := Abs( FCurrentFont.pCharWidthArray^[ TheChar ] );
1037	end;
1038
1039	if FCurrentFont.FontType = ftOutline then
1040	begin
1041	SelectFont( FCurrentFont, 1 );
1042	end
1043	else
1044	begin
1045	// For bitmap fonts, multiply by 256 manually
1046	for TheChar := #0 to #255 do
1047	begin
1048	FCurrentFont.pCharWidthArray^[ TheChar ] :=
1049	FCurrentFont.pCharWidthArray^[ TheChar ]
1050	* FontWidthPrecisionFactor;
1051	end;
1052	end;
1053
1054	GpiQueryFontMetrics( FCanvas.Handle,
1055	sizeof( fm ),
1056	fm );
1057	FCurrentFont.lMaxbaseLineExt := fm.lMaxbaselineExt;
1058	FCurrentFont.lAveCharWidth := fm.lAveCharWidth;
1059	FCurrentFont.lMaxCharInc := fm.lMaxCharInc;
1060	FCurrentFont.lMaxDescender := fm.lMaxDescender;
1061	end;
1062
1063	procedure TCanvasFontManager.EnsureMetricsLoaded;
1064	begin
1065	if FCurrentFont = nil then
1066	raise( Exception.Create( 'No font selected before getting font metrics' ) );
1067
1068	if FCurrentFont.pCharWidthArray = Nil then
1069	LoadMetrics;
1070	end;
1071
1072	function TCanvasFontManager.CharWidth( const C: Char ): longint;
1073	begin
1074	EnsureMetricsLoaded;
1075	Result := FCurrentFont.pCharWidthArray^[ C ];
1076	end;
1077
1078	function TCanvasFontManager.AverageCharWidth: longint;
1079	begin
1080	EnsureMetricsLoaded;
1081	Result := FCurrentFont.lAveCharWidth;
1082	end;
1083
1084	function TCanvasFontManager.MaximumCharWidth: longint;
1085	begin
1086	EnsureMetricsLoaded;
1087	Result := FCurrentFont.lMaxCharInc;
1088	end;
1089
1090	function TCanvasFontManager.CharHeight;
1091	begin
1092	EnsureMetricsLoaded;
1093	Result := FCurrentFont.lMaxBaseLineExt;
1094	end;
1095
1096	function TCanvasFontManager.CharDescender;
1097	begin
1098	EnsureMetricsLoaded;
1099	Result := FCurrentFont.lMaxDescender;
1100	end;
1101
1102	function TCanvasFontManager.IsFixed: boolean;
1103	begin
1104	Result := FCurrentFont.FixedWidth;
1105	end;
1106
1107	procedure TCanvasFontManager.DrawString( Var Point: TPoint;
1108	const Length: longint;
1109	const S: PChar );
1110	begin
1111	GpiCharStringAt( FCanvas.Handle,
1112	Point,
1113	Length,
1114	S^ );
1115	Point := FCanvas.PenPos;
1116	end;
1117
1118	end.

Note: See TracBrowser for help on using the repository browser.

Download in other formats: