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