Context Navigation

source: branches/pre_reorg/Components/CanvasFontManager.pas

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

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

Download in other formats: