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