1{============================================================================== 2 Content: TheTextDrawer, a helper class for drawing of 3 fixed-pitched font characters 4 ============================================================================== 5 The contents of this file are subject to the Mozilla Public License Ver. 1.0 6 (the "License"); you may not use this file except in compliance with the 7 License. You may obtain a copy of the License at http://www.mozilla.org/MPL/ 8 9 Software distributed under the License is distributed on an "AS IS" basis, 10 WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for 11 the specific language governing rights and limitations under the License. 12 ============================================================================== 13 The Original Code is HANAI Tohru's private delphi library. 14 ============================================================================== 15 The Initial Developer of the Original Code is HANAI Tohru (Japan) 16 Portions created by HANAI Tohru are Copyright (C) 1999. 17 All Rights Reserved. 18 ============================================================================== 19 Contributor(s): HANAI Tohru 20 ============================================================================== 21 History: 01/19/1999 HANAI Tohru 22 Initial Version 23 02/13/1999 HANAI Tohru 24 Changed default intercharacter spacing 25 09/09/1999 HANAI Tohru 26 Redesigned all. Simplified interfaces. 27 When drawing text now it uses TextOut + SetTextCharacter- 28 Extra insted ExtTextOut since ExtTextOut has a little 29 heavy behavior. 30 09/10/1999 HANAI Tohru 31 Added code to call ExtTextOut because there is a problem 32 when TextOut called with italicized raster type font. 33 After this changing, ExtTextOut is called without the 34 last parameter `lpDx' and be with SetTextCharacterExtra. 35 This pair performs faster than with `lpDx'. 36 09/14/1999 HANAI Tohru 37 Changed code for saving/restoring DC 38 09/15/1999 HANAI Tohru 39 Added X/Y parameters to ExtTextOut. 40 09/16/1999 HANAI Tohru 41 Redesigned for multi-bytes character drawing. 42 09/19/1999 HANAI Tohru 43 Since TheTextDrawer grew fat it was split into three 44 classes - TheFontStock, TheTextDrawer and TheTextDrawerEx. 45 Currently it should avoid TheTextDrawer because it is 46 slower than TheTextDrawer. 47 09/25/1999 HANAI Tohru 48 Added internally definition of LeadBytes for Delphi 2 49 10/01/1999 HANAI Tohru 50 To save font resources, now all fonts data are shared 51 among all of TheFontStock instances. With this changing, 52 there added a new class `TheFontsInfoManager' to manage 53 those shared data. 54 10/09/1999 HANAI Tohru 55 Added BaseStyle property to TheFontFont class. 56 ==============================================================================} 57 58// $Id: syntextdrawer.pp 58255 2018-06-14 09:05:50Z juha $ 59 60// SynEdit note: The name had to be changed to get SynEdit to install 61// together with mwEdit into the same Delphi installation 62 63unit SynTextDrawer; 64 65{$mode objfpc}{$H+} 66 67interface 68 69uses 70 Classes, Types, SysUtils, 71 // LCL 72 LCLType, LCLIntf, Graphics, GraphUtil, 73 // LazUtils 74 LazMethodList, LazLoggerBase, LazTracer, 75 // SynEdit 76 SynEditTypes, SynEditMiscProcs; 77 78type 79 TheStockFontPatterns = 0..(1 shl (1 + Ord(High(TFontStyle)))); 80 81 PheFontData = ^TheFontData; 82 TheFontData = record 83 Style: TFontStyles; 84 Font: TFont; 85 Handle: HFont; 86 CharAdv: Integer; // char advance of single-byte code 87 CharHeight: Integer; 88 NeedETO: Boolean; 89 end; 90 91 PheFontsData = ^TheFontsData; 92 TheFontsData = array[TheStockFontPatterns] of TheFontData; 93 94 PheSharedFontsInfo = ^TheSharedFontsInfo; 95 TheSharedFontsInfo = record 96 // reference counters 97 RefCount: Integer; 98 LockCount: Integer; 99 // font information 100 BaseFont: TFont; 101 IsDBCSFont: Boolean; 102 IsTrueType: Boolean; 103 FontsData: TheFontsData; 104 end; 105 106 { TheFontsInfoManager } 107 108 TheFontsInfoManager = class 109 private 110 FFontsInfo: TList; 111 function CreateFontsInfo(ABaseFont: TFont): PheSharedFontsInfo; 112 function FindFontsInfo(const BFont: TFont): PheSharedFontsInfo; 113 procedure DestroyFontHandles(pFontsInfo: PheSharedFontsInfo); 114 public 115 constructor Create; 116 destructor Destroy; override; 117 procedure LockFontsInfo(pFontsInfo: PheSharedFontsInfo); 118 procedure UnLockFontsInfo(pFontsInfo: PheSharedFontsInfo); 119 function GetFontsInfo(ABaseFont: TFont): PheSharedFontsInfo; 120 procedure ReleaseFontsInfo(var pFontsInfo: PheSharedFontsInfo); 121 end; 122 123 { TheFontStock } 124 125 TheExtTextOutProc = procedure (X, Y: Integer; fuOptions: UINT; 126 const ARect: TRect; Text: PChar; Length: Integer) of object; 127 128 EheFontStockException = class(Exception); 129 130 TheFontStock = class 131 private 132 // private DC 133 FDC: HDC; 134 FDCRefCount: Integer; 135 136 // Shared fonts 137 FpInfo: PheSharedFontsInfo; 138 FUsingFontHandles: Boolean; 139 140 // Current font 141 FCrntFont: HFONT; 142 FCrntStyle: TFontStyles; 143 FpCrntFontData: PheFontData; 144 // local font info 145 function GetBaseFont: TFont; 146 function GetIsDBCSFont: Boolean; 147 function GetIsTrueType: Boolean; 148 function GetNeedETO: Boolean; 149 protected 150 function InternalGetDC: HDC; virtual; 151 procedure InternalReleaseDC(Value: HDC); virtual; 152 Procedure CalcFontAdvance(DC: HDC; FontData: PheFontData; FontHeight: integer); 153 function GetCharAdvance: Integer; virtual; 154 function GetCharHeight: Integer; virtual; 155 function GetFontData(idx: Integer): PheFontData; virtual; 156 procedure UseFontHandles; 157 procedure ReleaseFontsInfo; 158 procedure SetBaseFont(Value: TFont); virtual; 159 procedure SetStyle(Value: TFontStyles); virtual; 160 property FontData[idx: Integer]: PheFontData read GetFontData; 161 property FontsInfo: PheSharedFontsInfo read FpInfo; 162 public 163 constructor Create(InitialFont: TFont); virtual; 164 destructor Destroy; override; 165 procedure ReleaseFontHandles; virtual; 166 public 167 // Info from the current font (per Style) 168 function MonoSpace: Boolean; 169 property Style: TFontStyles read FCrntStyle write SetStyle; 170 property FontHandle: HFONT read FCrntFont; 171 property CharAdvance: Integer read GetCharAdvance; 172 property CharHeight: Integer read GetCharHeight; 173 property NeedETO: Boolean read GetNeedETO; 174 public 175 // Info from the BaseFont 176 property BaseFont: TFont read GetBaseFont; 177 property IsDBCSFont: Boolean read GetIsDBCSFont; 178 property IsTrueType: Boolean read GetIsTrueType; 179 end; 180 181 { TEtoBuffer } 182 183 TEtoBuffer = class 184 public 185 EtoData: Array of Integer; 186 function Eto: PInteger; 187 function Len: Integer; 188 procedure Clear; 189 procedure SetMinLength(ALen: Integer); 190 end; 191 { TheTextDrawer } 192 EheTextDrawerException = class(Exception); 193 194 TheTextDrawer = class(TObject) 195 private 196 FDC: HDC; 197 FSaveDC: Integer; 198 FSavedFont: HFont; 199 200 // Font information 201 FFontStock: TheFontStock; 202 FCalcExtentBaseStyle: TFontStyles; 203 FBaseCharWidth: Integer; 204 FBaseCharHeight: Integer; 205 206 // current font and properties 207 FCrntFont: HFONT; 208 FEtoInitLen: Integer; 209 FEto: TEtoBuffer; 210 211 // current font attributes 212 FColor: TColor; 213 FBkColor: TColor; 214 FFrameColor: array[TLazSynBorderSide] of TColor; 215 FFrameStyle: array[TLazSynBorderSide] of TSynLineStyle; 216 FCharExtra: Integer; 217 218 // Begin/EndDrawing calling count 219 FDrawingCount: Integer; 220 ForceEto: Boolean; 221 222 FOnFontChangedHandlers: TMethodList; 223 FOnFontChangedLock: Integer; 224 function GetCharExtra: Integer; 225 function GetEto: TEtoBuffer; 226 protected 227 procedure ReleaseETODist; virtual; 228 procedure AfterStyleSet; virtual; 229 function GetUseUTF8: boolean; 230 function GetMonoSpace: boolean; 231 function CreateColorPen(AColor: TColor; AStyle: LongWord = PS_SOLID): HPen; 232 property DrawingCount: Integer read FDrawingCount; 233 property FontStock: TheFontStock read FFontStock; 234 property BaseCharWidth: Integer read FBaseCharWidth; 235 property BaseCharHeight: Integer read FBaseCharHeight; 236 public 237 constructor Create(CalcExtentBaseStyle: TFontStyles; ABaseFont: TFont); virtual; 238 destructor Destroy; override; 239 function GetCharWidth: Integer; virtual; 240 function GetCharHeight: Integer; virtual; 241 procedure BeginDrawing(DC: HDC); virtual; 242 procedure EndDrawing; virtual; 243 procedure TextOut(X, Y: Integer; Text: PChar; Length: Integer); virtual; 244 procedure ExtTextOut(X, Y: Integer; fuOptions: UINT; const ARect: TRect; 245 Text: PChar; Length: Integer; FrameBottom: Integer = -1); virtual; 246 procedure NewTextOut(X, Y: Integer; fuOptions: UINT; const ARect: TRect; 247 Text: PChar; Length: Integer; AnEto: TEtoBuffer); 248 procedure DrawFrame(const ARect: TRect); 249 procedure ForceNextTokenWithEto; 250 function NeedsEto: boolean; 251 procedure DrawLine(X, Y, X2, Y2: Integer; AColor: TColor); 252 procedure FillRect(const aRect: TRect); 253 procedure SetBaseFont(Value: TFont); virtual; 254 procedure SetBaseStyle(const Value: TFontStyles); virtual; 255 procedure SetStyle(Value: TFontStyles); virtual; 256 procedure SetForeColor(Value: TColor); virtual; 257 procedure SetBackColor(Value: TColor); virtual; 258 259 procedure SetFrameColor(Side: TLazSynBorderSide; AValue: TColor); virtual; overload; 260 procedure SetFrameColor(AValue: TColor); virtual; overload; //deprecated; 261 procedure SetFrameStyle(Side: TLazSynBorderSide; AValue: TSynLineStyle); virtual; overload; 262 //procedure SetFrameStyle(AValue: TSynLineStyle); virtual; overload; 263 264 procedure SetCharExtra(Value: Integer); virtual; 265 procedure ReleaseTemporaryResources; virtual; 266 267 procedure RegisterOnFontChangeHandler(AHandlerProc: TNotifyEvent); 268 procedure UnRegisterOnFontChangeHandler(AHandlerProc: TNotifyEvent); 269 270 property Eto: TEtoBuffer read GetEto; 271 property CharWidth: Integer read GetCharWidth; 272 property CharHeight: Integer read GetCharHeight; 273 property BaseFont: TFont write SetBaseFont; 274 property BaseStyle: TFontStyles write SetBaseStyle; 275 property ForeColor: TColor write SetForeColor; 276 property BackColor: TColor read FBkColor write SetBackColor; 277 property FrameColor[Side: TLazSynBorderSide]: TColor write SetFrameColor; 278 property FrameStyle[Side: TLazSynBorderSide]: TSynLineStyle write SetFrameStyle; 279 280 property Style: TFontStyles write SetStyle; 281 property CharExtra: Integer read GetCharExtra write SetCharExtra; 282 property UseUTF8: boolean read GetUseUTF8; 283 property MonoSpace: boolean read GetMonoSpace; 284 property StockDC: HDC read FDC; 285 end; 286 287 { TheTextDrawerEx } 288 289 TheTextDrawerEx = class(TheTextDrawer) 290 private 291 // current font properties 292 FCrntDx: Integer; 293 FCrntDBDx: Integer; // for a double-byte character 294 // Text drawing procedure reference for optimization 295 FExtTextOutProc: TheExtTextOutProc; 296 protected 297 procedure AfterStyleSet; override; 298 procedure TextOutOrExtTextOut(X, Y: Integer; fuOptions: UINT; 299 const ARect: TRect; Text: PChar; Length: Integer); virtual; 300 procedure ExtTextOutFixed(X, Y: Integer; fuOptions: UINT; 301 const ARect: TRect; Text: PChar; Length: Integer); virtual; 302 procedure ExtTextOutWithETO(X, Y: Integer; fuOptions: UINT; 303 const ARect: TRect; Text: PChar; Length: Integer); virtual; 304 procedure ExtTextOutForDBCS(X, Y: Integer; fuOptions: UINT; 305 const ARect: TRect; Text: PChar; Length: Integer); virtual; 306 public 307 procedure ExtTextOut(X, Y: Integer; fuOptions: UINT; const ARect: TRect; 308 Text: PChar; Length: Integer; FrameBottom: Integer = -1); override; 309 end; 310 311 function GetFontsInfoManager: TheFontsInfoManager; 312 313(* 314{$DEFINE HE_ASSERT} 315{$DEFINE HE_LEADBYTES} 316{$DEFINE HE_COMPAREMEM} 317*) 318 319{$IFNDEF HE_LEADBYTES} 320type 321 TheLeadByteChars = set of Char; 322 323 function SetLeadBytes(const Value: TheLeadByteChars): TheLeadByteChars; 324{$ENDIF} 325 326implementation 327 328const 329 DBCHAR_CALCULATION_FALED = $7FFFFFFF; 330 331var 332 gFontsInfoManager: TheFontsInfoManager; 333 SynTextDrawerFinalization: boolean; 334 335{$IFNDEF HE_LEADBYTES} 336 LeadBytes: TheLeadByteChars; 337{$ENDIF} 338 339{ utility routines } 340 341function GetFontsInfoManager: TheFontsInfoManager; 342begin 343 if (not Assigned(gFontsInfoManager)) 344 and (not SynTextDrawerFinalization) 345 then 346 gFontsInfoManager := TheFontsInfoManager.Create; 347 Result := gFontsInfoManager; 348end; 349 350function Min(x, y: integer): integer; 351begin 352 if x < y then Result := x else Result := y; 353end; 354 355{$IFNDEF HE_ASSERT} 356procedure ASSERT(Expression: Boolean); 357begin 358 if not Expression then 359 raise EheTextDrawerException.Create('Assertion failed.'); 360end; 361{$ENDIF} 362 363{$IFNDEF HE_LEADBYTES} 364function SetLeadBytes(const Value: TheLeadByteChars): TheLeadByteChars; 365begin 366 Result := LeadBytes; 367 LeadBytes := Value; 368end; 369{$ENDIF} 370 371{$IFNDEF HE_COMPAREMEM} 372function CompareMem(P1, P2: Pointer; Length: Integer): Boolean; 373begin 374 Result := CompareByte(P1^, P2^, Length) = 0; 375end; 376{$ENDIF} 377 378function GetStyleIndex(Value: TFontStyles): Integer; 379var 380 item: TFontStyle; 381begin 382 result := 0; 383 for item := low (TFontStyle) to high(TFontStyle) do 384 if item in Value then 385 result := result + 1 shl ord(item); 386end; 387 388{ TEtoBuffer } 389 390function TEtoBuffer.Eto: PInteger; 391begin 392 if Length(EtoData) > 0 then 393 Result := PInteger(@EtoData[0]) 394 else 395 Result := nil; 396end; 397 398function TEtoBuffer.Len: Integer; 399begin 400 Result := Length(EtoData); 401end; 402 403procedure TEtoBuffer.Clear; 404begin 405 SetLength(EtoData, 0); 406end; 407 408procedure TEtoBuffer.SetMinLength(ALen: Integer); 409const 410 EtoBlockSize = $80; 411begin 412 if Length(EtoData) >= ALen then exit; 413 SetLength(EtoData, ((not (EtoBlockSize - 1)) and ALen) + EtoBlockSize); 414end; 415 416{ TheFontsInfoManager } 417 418procedure TheFontsInfoManager.LockFontsInfo( 419 pFontsInfo: PheSharedFontsInfo); 420begin 421 Inc(pFontsInfo^.LockCount); 422end; 423 424constructor TheFontsInfoManager.Create; 425begin 426 inherited Create; 427 FFontsInfo := TList.Create; 428end; 429 430procedure TheFontsInfoManager.UnlockFontsInfo( 431 pFontsInfo: PheSharedFontsInfo); 432begin 433 with pFontsInfo^ do 434 begin 435 if LockCount>0 then begin 436 Dec(LockCount); 437 if 0 = LockCount then 438 DestroyFontHandles(pFontsInfo); 439 end; 440 end; 441end; 442 443destructor TheFontsInfoManager.Destroy; 444var APheSharedFontsInfo:PheSharedFontsInfo; 445begin 446 if Assigned(FFontsInfo) then 447 begin 448 while FFontsInfo.Count > 0 do 449 begin 450 ASSERT(1 = PheSharedFontsInfo(FFontsInfo[FFontsInfo.Count - 1])^.RefCount); 451 APheSharedFontsInfo:=PheSharedFontsInfo(FFontsInfo[FFontsInfo.Count - 1]); 452 ReleaseFontsInfo(APheSharedFontsInfo); 453 end; 454 FFontsInfo.Free; 455 FFontsInfo:=nil; 456 end; 457 458 inherited Destroy; 459 gFontsInfoManager := nil; 460end; 461 462procedure TheFontsInfoManager.DestroyFontHandles( 463 pFontsInfo: PheSharedFontsInfo); 464var 465 i: Integer; 466begin 467 with pFontsInfo^ do 468 for i := Low(TheStockFontPatterns) to High(TheStockFontPatterns) do 469 with FontsData[i] do 470 if Handle <> 0 then 471 begin 472 FreeAndNil(Font); 473 Handle := 0; 474 end; 475end; 476 477function TheFontsInfoManager.CreateFontsInfo(ABaseFont: TFont): PheSharedFontsInfo; 478var 479 DC: HDC; 480 hOldFont: HFont; 481begin 482 New(Result); 483 FillChar(Result^, SizeOf(TheSharedFontsInfo), 0); 484 with Result^ do 485 try 486 BaseFont := TFont.Create; 487 BaseFont.Assign(ABaseFont); 488 IsTrueType := False; // TODO: The old code returned always false too: (0 <> (TRUETYPE_FONTTYPE and LF.lfPitchAndFamily)); 489 // find out whether the font `IsDBCSFont' 490 DC := GetDC(0); 491 hOldFont := SelectObject(DC, ABaseFont.Reference.Handle); 492 IsDBCSFont := (0 <> (GCP_DBCS and GetFontLanguageInfo(DC))); 493 //debugln('TheFontsInfoManager.CreateFontsInfo IsDBCSFont=',IsDBCSFont); 494 SelectObject(DC, hOldFont); 495 ReleaseDC(0, DC); 496 except 497 Result^.BaseFont.Free; 498 Dispose(Result); 499 raise; 500 end; 501end; 502 503function TheFontsInfoManager.FindFontsInfo(const BFont: TFont): 504 PheSharedFontsInfo; 505var 506 i: Integer; 507begin 508 for i := 0 to FFontsInfo.Count - 1 do 509 begin 510 Result := PheSharedFontsInfo(FFontsInfo[i]); 511 if Result^.BaseFont.IsEqual(BFont) then 512 Exit; 513 end; 514 Result := nil; 515end; 516 517function TheFontsInfoManager.GetFontsInfo(ABaseFont: TFont): PheSharedFontsInfo; 518begin 519 ASSERT(Assigned(ABaseFont)); 520 521 Result := FindFontsInfo(ABaseFont); 522 if not Assigned(Result) then 523 begin 524 Result := CreateFontsInfo(ABaseFont); 525 FFontsInfo.Add(Result); 526 end; 527 528 if Assigned(Result) then 529 Inc(Result^.RefCount); 530end; 531 532procedure TheFontsInfoManager.ReleaseFontsInfo(var pFontsInfo: PheSharedFontsInfo); 533begin 534 ASSERT(Assigned(pFontsInfo)); 535 536 with pFontsInfo^ do 537 begin 538{$IFDEF HE_ASSERT} 539 ASSERT(LockCount < RefCount, 540 'Call DeactivateFontsInfo before calling this.'); 541{$ELSE} 542 ASSERT(LockCount < RefCount); 543{$ENDIF} 544 if RefCount > 1 then 545 Dec(RefCount) 546 else 547 begin 548 FFontsInfo.Remove(pFontsInfo); 549 // free all objects 550 BaseFont.Free; 551 Dispose(pFontsInfo); 552 end; 553 end; 554 pFontsInfo:=nil; 555 if SynTextDrawerFinalization and (FFontsInfo.Count=0) then 556 // the program is in the finalization phase 557 // and this object is not used anymore -> destroy it 558 Free; 559end; 560 561{ TheFontStock } 562 563// CalcFontAdvance : Calculation a advance of a character of a font. 564// [*]hCalcFont will be selected as FDC's font if FDC wouldn't be zero. 565Procedure TheFontStock.CalcFontAdvance(DC: HDC; FontData: PheFontData; 566 FontHeight: integer); 567 568 Procedure DebugFont(s: String; a: array of const); 569 begin 570 if FontData^.Font <> nil then begin 571 if FontData^.Font.Size = 0 then exit; 572 s := 'Font=' + FontData^.Font.Name + ' Size=' + IntToStr(FontData^.Font.Size) + ' ' + s; 573 end; 574 s := 'TheFontStock.CalcFontAdvance: ' + s; 575 DebugLn(Format(s, a)); 576 end; 577 578 procedure GetWHOForChar(s: char; out w, h ,o : Integer; var eto: Boolean); 579 var 580 s1, s2, s3: String; 581 Size1, Size2, Size3: TSize; 582 w2, w3: Integer; 583 begin 584 s1 := s; 585 s2 := s1 + s; 586 s3 := s2 + s; 587 if not(GetTextExtentPoint(DC, PChar(s1), 1, Size1{%H-}) and 588 GetTextExtentPoint(DC, PChar(s2), 2, Size2{%H-}) and 589 GetTextExtentPoint(DC, PChar(s3), 3, Size3{%H-})) then 590 begin 591 DebugFont('Failed to get GetTextExtentPoint for %s', [s1]); 592 w := 0; 593 h := 0; 594 o := 0; 595 eto := True; 596 exit; 597 end; 598 h := Size1.cy; 599 // Size may contain overhang (italic, bold) 600 // Size1 contains the size of 1 char + 1 overhang 601 // Size2 contains the width of 2 chars, with only 1 overhang 602 603 // Start simple 604 w := size1.cx; 605 o := 0; 606 607 w2 := Size2.cx - Size1.cx; 608 w3 := Size3.cx - Size2.cx; 609 {$IFDEF SYNFONTDEBUG} 610 DebugFont('Got TextExtends for %s=%d, %s=%d, %s=%d Height=%d', [s1, Size1.cx, s2, Size2.cx, s3, Size3.cx, h]); 611 {$ENDIF} 612 if (w2 = w) and (w3 = w) then exit; 613 614 if (w2 <= w) and (w3 <= w) then begin 615 // w includes overhang (may be fractional 616 if w2 <> w3 then begin 617 {$IFNDEF SYNFONTDEBUG} if abs(w3-w2) > 1 then {$ENDIF} 618 DebugFont('Variable Overhang w=%d w2=%d w3=%d', [w, w2, w3]); 619 w2 := Max(w2, w3); 620 end; 621 o := w - w2; 622 w := w2; 623 eto := True; 624 end 625 else 626 if (w2 >= w) or (w3 >= w) then begin 627 // Width may be fractional, check sanity and keep w 628 o := 1; 629 eto := True; 630 if Max(w2, w3) > w + 1 then begin 631 DebugFont('Size diff to bi for fractioanl (greater 1) w=%d w2=%d w3=%d', [w, w2, w3]); 632 // Take a guess/average 633 w2 := Max(w2, w3); 634 o := w2 - w; 635 w := Max(w, (w+w2-1) div 2); 636 end; 637 end 638 else begin 639 // broken font? one of w2/w3 is smaller, the other wider than w 640 w := Max(w, (w+w2+w3-1) div 3); 641 o := w div 2; 642 eto := True; 643 end; 644 {$IFDEF SYNFONTDEBUG} 645 DebugFont('Final result for %s Width=%d Overhang=%d eto=%s', [s1, w, o, dbgs(eto)]); 646 {$ENDIF} 647 end; 648 649 procedure AdjustWHOForChar(s: char; var w, h ,o : Integer; var eto: Boolean); 650 var 651 h2, w2, o2: Integer; 652 begin 653 GetWHOForChar(s, w2, h2, o2, eto); 654 h := Max(h, h2); 655 o := Max(o, o2); 656 if w <> w2 then begin 657 w := Max(w, w2); 658 eto := True; 659 end; 660 end; 661 662var 663 TM: TTextMetric; 664 Height, Width, OverHang: Integer; 665 ETO: Boolean; 666 Size1: TSize; 667 tmw: Integer; 668begin 669 // Calculate advance of a character. 670 671 // TextMetric may fail, because: 672 // tmMaxCharWidth may be the width of a single Width (Latin) char, like "M" 673 // or a double Width (Chinese) char 674 // tmAveCharWidth is to small for proprtional fonts, as we need he witdh of the 675 // widest Latin char ("M"). 676 // Even Monospace fonts, may have a smaller tmAveCharWidth (seen with Japanese) 677 678 // take several samples 679 ETO := False; 680 GetWHOForChar('M', Width, Height, OverHang, ETO); 681 AdjustWHOForChar('W', Width, Height, OverHang, ETO); 682 AdjustWHOForChar('@', Width, Height, OverHang, ETO); 683 AdjustWHOForChar('X', Width, Height, OverHang, ETO); 684 AdjustWHOForChar('m', Width, Height, OverHang, ETO); 685 // Small Chars to detect proportional fonts 686 AdjustWHOForChar('i', Width, Height, OverHang, ETO); 687 AdjustWHOForChar(':', Width, Height, OverHang, ETO); 688 AdjustWHOForChar('''', Width, Height, OverHang, ETO); 689 690 // Negative Overhang ? 691 if (not ETO) and GetTextExtentPoint(DC, PChar('Ta'), 2, Size1{%H-}) then 692 if Size1.cx < 2 * Width then begin 693 {$IFDEF SYNFONTDEBUG} 694 DebugFont('Negative Overhang for "Ta" cx=%d Width=%d Overhang=%d', [Size1.cx, Width, OverHang]); 695 {$ENDIF} 696 ETO := True; 697 end; 698 699 // Make sure we get the correct Height 700 if GetTextExtentPoint(DC, PChar('Tgq[_|^'), 7, Size1) then 701 Height := Max(Height, Size1.cy); 702 703 // DoubleCheck the result with GetTextMetrics 704 GetTextMetrics(DC, TM{%H-}); 705 {$IFDEF SYNFONTDEBUG} 706 DebugFont('TextMetrics tmHeight=%d, tmAve=%d, tmMax=%d, tmOver=%d', [TM.tmHeight, TM.tmAveCharWidth, TM.tmMaxCharWidth, TM.tmOverhang]); 707 {$ENDIF} 708 709 tmw := TM.tmMaxCharWidth + Max(TM.tmOverhang,0); 710 if Width = 0 then begin 711 DebugFont('No Width from GetTextExtentPoint', []); 712 Width := tmw; 713 end 714 else if (Width > tmw) and (TM.tmMaxCharWidth > 0) then begin 715 DebugFont('Width(%d) > tmMaxWidth+Over(%d)', [Width, tmw]); 716 // take a guess, this is probably a broken font 717 Width := Min(Width, round((TM.tmMaxCharWidth + Max(TM.tmOverhang,0)) * 1.2)); 718 ETO := True; 719 end; 720 721 if Height = 0 then begin 722 DebugFont('No Height from GetTextExtentPoint, tmHeight=%d', [TM.tmHeight]); 723 Height := TM.tmHeight; 724 end 725 else if Height < TM.tmHeight then begin 726 DebugFont('Height from GetTextExtentPoint to low Height=%d, tmHeight=%d', [Height, TM.tmHeight]); 727 Height := TM.tmHeight; 728 end; 729 if Height = 0 then begin 730 DebugFont('SynTextDrawer: Fallback on FontHeight', []); 731 Height := FontHeight; 732 end; 733 734 // If we have a broken font, make sure we return a positive value 735 if Width <= 0 then begin 736 DebugFont('SynTextDrawer: Fallback on Width', []); 737 Width := 1 + Height * 8 div 10; 738 end; 739 740 //if OverHang >0 then debugln(['SynTextDrawer: Overhang=', OverHang]);; 741 FontData^.CharAdv := Width; 742 FontData^.CharHeight := Height; 743 FontData^.NeedETO := ETO; 744end; 745 746constructor TheFontStock.Create(InitialFont: TFont); 747begin 748 inherited Create; 749 750 SetBaseFont(InitialFont); 751end; 752 753destructor TheFontStock.Destroy; 754begin 755 ReleaseFontsInfo; 756 ASSERT(FDCRefCount = 0); 757 758 inherited; 759end; 760 761function TheFontStock.GetBaseFont: TFont; 762begin 763 Result := FpInfo^.BaseFont; 764end; 765 766function TheFontStock.GetCharAdvance: Integer; 767begin 768 Result := FpCrntFontData^.CharAdv; 769end; 770 771function TheFontStock.GetCharHeight: Integer; 772begin 773 Result := FpCrntFontData^.CharHeight; 774end; 775 776function TheFontStock.GetFontData(idx: Integer): PheFontData; 777begin 778 Result := @FpInfo^.FontsData[idx]; 779end; 780 781function TheFontStock.GetIsDBCSFont: Boolean; 782begin 783 Result := FpInfo^.IsDBCSFont; 784end; 785 786function TheFontStock.GetIsTrueType: Boolean; 787begin 788 Result := FpInfo^.IsTrueType 789end; 790 791function TheFontStock.GetNeedETO: Boolean; 792begin 793 Result := FpCrntFontData^.NeedETO; 794end; 795 796function TheFontStock.InternalGetDC: HDC; 797begin 798 if FDCRefCount = 0 then 799 begin 800 ASSERT(FDC = 0); 801 FDC := GetDC(0); 802 end; 803 Inc(FDCRefCount); 804 Result := FDC; 805end; 806 807procedure TheFontStock.InternalReleaseDC(Value: HDC); 808begin 809 Dec(FDCRefCount); 810 if FDCRefCount <= 0 then 811 begin 812 ASSERT((FDC <> 0) and (FDC = Value)); 813 ReleaseDC(0, FDC); 814 FDC := 0; 815 ASSERT(FDCRefCount = 0); 816 end; 817end; 818 819procedure TheFontStock.ReleaseFontHandles; 820begin 821 if FUsingFontHandles then 822 with GetFontsInfoManager do 823 begin 824 UnlockFontsInfo(FpInfo); 825 FUsingFontHandles := False; 826 end; 827end; 828 829function TheFontStock.MonoSpace: Boolean; 830begin 831 FpCrntFontData^.Font.Reference; 832 Result := FpCrntFontData^.Font.IsMonoSpace; 833end; 834 835procedure TheFontStock.ReleaseFontsInfo; 836begin 837 if Assigned(FpInfo) then 838 with GetFontsInfoManager do 839 begin 840 if FUsingFontHandles then 841 begin 842 UnlockFontsInfo(FpInfo); 843 FUsingFontHandles := False; 844 end; 845 ReleaseFontsInfo(FpInfo); 846 end; 847end; 848 849procedure TheFontStock.SetBaseFont(Value: TFont); 850var 851 pInfo: PheSharedFontsInfo; 852begin 853 if Assigned(Value) then 854 begin 855 pInfo := GetFontsInfoManager.GetFontsInfo(Value); 856 if pInfo = FpInfo then begin 857 // GetFontsInfo has increased the refcount, but we already have the font 858 // -> decrease the refcount 859 GetFontsInfoManager.ReleaseFontsInfo(pInfo); 860 end else begin 861 ReleaseFontsInfo; 862 FpInfo := pInfo; 863 // clear styles 864 SetStyle(Value.Style); 865 end; 866 end 867 else 868 raise EheFontStockException.Create('SetBaseFont: ''Value'' must be specified.'); 869end; 870 871procedure TheFontStock.SetStyle(Value: TFontStyles); 872var 873 idx: Integer; 874 DC: HDC; 875 hOldFont: HFONT; 876 p: PheFontData; 877begin 878 idx := GetStyleIndex(Value); 879 {$IFDEF HE_ASSERT} 880 ASSERT(idx <= High(TheStockFontPatterns)); 881 {$ENDIF} 882 883 UseFontHandles; 884 p := FontData[idx]; 885 if FpCrntFontData = p then 886 Exit; 887 888 FpCrntFontData := p; 889 with p^ do 890 if Handle <> 0 then 891 begin 892 FCrntFont := Handle; 893 FCrntStyle := Style; 894 Exit; 895 end; 896 897 // create font 898 FpCrntFontData^.Font := TFont.Create; 899 FpCrntFontData^.Font.Assign(BaseFont); 900 FpCrntFontData^.Font.Style := Value; 901 FCrntFont := FpCrntFontData^.Font.Reference.Handle; 902 903 DC := InternalGetDC; 904 hOldFont := SelectObject(DC, FCrntFont); 905 906 // retrieve height and advances of new font 907 FpInfo^.IsDBCSFont := (0 <> (GCP_DBCS and GetFontLanguageInfo(DC))); 908 //debugln('TheFontStock.SetStyle A IsDBCSFont=',IsDBCSFont); 909 FpCrntFontData^.Handle := FCrntFont; 910 CalcFontAdvance(DC, FpCrntFontData, Max(BaseFont.Size, BaseFont.Height)); 911 //if FpCrntFontData^.NeedETO then debugln(['Needing ETO fot Font=',BaseFont.Name, ' Height=', BaseFont.Height, ' Style=', integer(Value) ]); 912 913 hOldFont:=SelectObject(DC, hOldFont); 914 if hOldFont<>FCrntFont then 915 RaiseGDBException('TheFontStock.SetStyle LCL interface lost the font'); 916 InternalReleaseDC(DC); 917end; 918 919procedure TheFontStock.UseFontHandles; 920begin 921 if not FUsingFontHandles then 922 with GetFontsInfoManager do 923 begin 924 LockFontsInfo(FpInfo); 925 FUsingFontHandles := True; 926 end; 927end; 928 929{ TheTextDrawer } 930 931constructor TheTextDrawer.Create(CalcExtentBaseStyle: TFontStyles; ABaseFont: TFont); 932var 933 Side: TLazSynBorderSide; 934begin 935 inherited Create; 936 937 FEto := TEtoBuffer.Create; 938 FFontStock := TheFontStock.Create(ABaseFont); 939 FCalcExtentBaseStyle := CalcExtentBaseStyle; 940 SetBaseFont(ABaseFont); 941 FColor := clWindowText; 942 FBkColor := clWindow; 943 944 for Side := Low(TLazSynBorderSide) to High(TLazSynBorderSide) do 945 begin 946 FFrameColor[Side] := clNone; 947 FFrameStyle[Side] := slsSolid; 948 end; 949 950 FOnFontChangedHandlers := TMethodList.Create; 951 FOnFontChangedLock := 0; 952end; 953 954destructor TheTextDrawer.Destroy; 955begin 956 FreeANdNil(FOnFontChangedHandlers); 957 FFontStock.Free; 958 ReleaseETODist; 959 FreeAndNil(FEto); 960 961 inherited; 962end; 963 964function TheTextDrawer.GetUseUTF8: boolean; 965begin 966 FFontStock.BaseFont.Reference; 967 Result:=FFontStock.BaseFont.CanUTF8; 968 //debugln('TheTextDrawer.GetUseUTF8 ',FFontStock.BaseFont.Name,' ',dbgs(FFontStock.BaseFont.CanUTF8),' ',dbgs(FFontStock.BaseFont.HandleAllocated)); 969end; 970 971function TheTextDrawer.GetMonoSpace: boolean; 972begin 973 FFontStock.BaseFont.Reference; 974 Result:=FFontStock.BaseFont.IsMonoSpace; 975 //debugln('TheTextDrawer.GetMonoSpace ',FFontStock.BaseFont.Name,' ',dbgs(FFontStock.BaseFont.IsMonoSpace),' ',dbgs(FFontStock.BaseFont.HandleAllocated)); 976end; 977 978function TheTextDrawer.CreateColorPen(AColor: TColor; AStyle: LongWord = PS_SOLID): HPen; 979var 980 ALogBrush: TLogBrush; 981begin 982 AStyle := AStyle + PS_ENDCAP_FLAT + PS_GEOMETRIC + PS_JOIN_MITER; 983 984 ALogBrush.lbStyle := BS_SOLID; 985 ALogBrush.lbColor := ColorToRGB(AColor); 986 ALogBrush.lbHatch := 0; 987 988 Result := ExtCreatePen(AStyle, 1, ALogBrush, 0, nil); 989end; 990 991procedure TheTextDrawer.SetFrameStyle(Side: TLazSynBorderSide; AValue: TSynLineStyle); 992begin 993 if FFrameStyle[Side] <> AValue then 994 begin 995 FFrameStyle[Side] := AValue; 996 end; 997end; 998 999//procedure TheTextDrawer.SetFrameStyle(AValue: TSynLineStyle); 1000//var 1001// Side: TLazSynBorderSide; 1002//begin 1003// for Side := Low(TLazSynBorderSide) to High(TLazSynBorderSide) do 1004// SetFrameStyle(Side, AValue); 1005//end; 1006 1007function TheTextDrawer.GetEto: TEtoBuffer; 1008begin 1009 Result := FEto; 1010 FEtoInitLen := 0; 1011end; 1012 1013function TheTextDrawer.GetCharExtra: Integer; 1014begin 1015 Result := Max(FCharExtra, -FBaseCharWidth + 1); 1016end; 1017 1018procedure TheTextDrawer.ReleaseETODist; 1019begin 1020 FEto.Clear; 1021end; 1022 1023procedure TheTextDrawer.BeginDrawing(DC: HDC); 1024begin 1025 if (FDC = DC) then 1026 ASSERT(FDC <> 0) 1027 else 1028 begin 1029 ASSERT((FDC = 0) and (DC <> 0) and (FDrawingCount = 0)); 1030 FDC := DC; 1031 FSaveDC := SaveDC(DC); 1032 FSavedFont := SelectObject(DC, FCrntFont); 1033 LCLIntf.SetTextColor(DC, TColorRef(FColor)); 1034 LCLIntf.SetBkColor(DC, TColorRef(FBkColor)); 1035 end; 1036 Inc(FDrawingCount); 1037end; 1038 1039procedure TheTextDrawer.EndDrawing; 1040begin 1041 ASSERT(FDrawingCount >= 1); 1042 Dec(FDrawingCount); 1043 if FDrawingCount <= 0 then 1044 begin 1045 if FDC <> 0 then 1046 begin 1047 if FSavedFont <> 0 then 1048 SelectObject(FDC, FSavedFont); 1049 RestoreDC(FDC, FSaveDC); 1050 end; 1051 FSaveDC := 0; 1052 FDC := 0; 1053 FDrawingCount := 0; 1054 end; 1055end; 1056 1057function TheTextDrawer.GetCharWidth: Integer; 1058begin 1059 Result := FBaseCharWidth + CharExtra; 1060end; 1061 1062function TheTextDrawer.GetCharHeight: Integer; 1063begin 1064 Result := FBaseCharHeight; 1065end; 1066 1067procedure TheTextDrawer.SetBaseFont(Value: TFont); 1068begin 1069 if Assigned(Value) then 1070 begin 1071 inc(FOnFontChangedLock); 1072 try 1073 {$IFDEF SYNFONTDEBUG} 1074 Debugln(['TheTextDrawer.SetBaseFont Name=', Value.Name, ' Size=', Value.Size, 'Style=', Integer(Value.Style)]); 1075 {$ENDIF} 1076 ReleaseETODist; 1077 with FFontStock do 1078 begin 1079 SetBaseFont(Value); 1080 //debugln('TheTextDrawer.SetBaseFont B ',Value.Name); 1081 FBaseCharWidth := 0; 1082 FBaseCharHeight := 0; 1083 end; 1084 BaseStyle := Value.Style; 1085 SetStyle(Value.Style); 1086 finally 1087 dec(FOnFontChangedLock); 1088 end; 1089 FOnFontChangedHandlers.CallNotifyEvents(Self); 1090 end 1091 else 1092 raise EheTextDrawerException.Create('SetBaseFont: ''Value'' must be specified.'); 1093end; 1094 1095procedure TheTextDrawer.SetBaseStyle(const Value: TFontStyles); 1096begin 1097 if (FCalcExtentBaseStyle <> Value) or (FBaseCharWidth = 0) then 1098 begin 1099 FCalcExtentBaseStyle := Value; 1100 ReleaseETODist; 1101 with FFontStock do 1102 begin 1103 Style := Value; 1104 FBaseCharWidth := Max(FBaseCharWidth, CharAdvance); 1105 FBaseCharHeight := Max(FBaseCharHeight, CharHeight); 1106 {$IFDEF SYNFONTDEBUG} 1107 Debugln(['TheTextDrawer.SetBaseStyle =', Integer(Value), 1108 ' CharAdvance=', CharAdvance, ' CharHeight=',CharHeight, 1109 ' FBaseCharWidth=', FBaseCharWidth, ' FBaseCharHeight=',FBaseCharHeight]); 1110 {$ENDIF} 1111 end; 1112 if FOnFontChangedLock = 0 then 1113 FOnFontChangedHandlers.CallNotifyEvents(Self); 1114 end; 1115end; 1116 1117procedure TheTextDrawer.SetStyle(Value: TFontStyles); 1118begin 1119 with FFontStock do 1120 begin 1121 SetStyle(Value); 1122 Self.FCrntFont := FontHandle; 1123 end; 1124 AfterStyleSet; 1125end; 1126 1127procedure TheTextDrawer.AfterStyleSet; 1128begin 1129 if FDC <> 0 then 1130 SelectObject(FDC, FCrntFont); 1131end; 1132 1133procedure TheTextDrawer.SetForeColor(Value: TColor); 1134begin 1135 if FColor <> Value then 1136 begin 1137 FColor := Value; 1138 if FDC <> 0 then 1139 SetTextColor(FDC, TColorRef(Value)); 1140 end; 1141end; 1142 1143procedure TheTextDrawer.SetBackColor(Value: TColor); 1144begin 1145 if FBkColor <> Value then 1146 begin 1147 FBkColor := Value; 1148 if FDC <> 0 then 1149 LCLIntf.SetBkColor(FDC, TColorRef(Value)); 1150 end; 1151end; 1152 1153procedure TheTextDrawer.SetFrameColor(Side: TLazSynBorderSide; AValue: TColor); 1154begin 1155 if FFrameColor[Side] <> AValue then 1156 begin 1157 FFrameColor[Side] := AValue; 1158 end; 1159end; 1160 1161procedure TheTextDrawer.SetFrameColor(AValue: TColor); 1162var 1163 Side: TLazSynBorderSide; 1164begin 1165 for Side := Low(TLazSynBorderSide) to High(TLazSynBorderSide) do 1166 SetFrameColor(Side, AValue); 1167end; 1168 1169procedure TheTextDrawer.SetCharExtra(Value: Integer); 1170begin 1171 if FCharExtra <> Value then 1172 begin 1173 FCharExtra := Value; 1174 FEtoInitLen := 0; 1175 end; 1176end; 1177 1178procedure TheTextDrawer.TextOut(X, Y: Integer; Text: PChar; 1179 Length: Integer); 1180begin 1181 LCLIntf.TextOut(FDC, X, Y, Text, Length); 1182end; 1183 1184procedure TheTextDrawer.ExtTextOut(X, Y: Integer; fuOptions: UINT; 1185 const ARect: TRect; Text: PChar; Length: Integer; FrameBottom: Integer = -1); 1186 1187 procedure InitETODist(InitValue: Integer); 1188 var 1189 i: Integer; 1190 begin 1191 FEto.SetMinLength(Length); 1192 for i := FEtoInitLen to FEto.Len-1 do 1193 FEto.EtoData[i] := InitValue; 1194 FEtoInitLen := FEto.Len; 1195 end; 1196 1197 function HasFrame: Boolean; 1198 var 1199 Side: TLazSynBorderSide; 1200 begin 1201 for Side := Low(TLazSynBorderSide) to High(TLazSynBorderSide) do 1202 if FFrameColor[Side] <> clNone then 1203 Exit(True); 1204 Result := False; 1205 end; 1206 1207var 1208 NeedDistArray: Boolean; 1209 DistArray: PInteger; 1210 RectFrame: TRect; 1211begin 1212 if HasFrame then // draw background // TODO: only if not default bg color 1213 begin 1214 InternalFillRect(FDC, ARect); 1215 if (fuOptions and ETO_OPAQUE) > 0 then 1216 fuOptions := fuOptions - ETO_OPAQUE; 1217 fuOptions := 0; 1218 1219 RectFrame := ARect; 1220 if FrameBottom >= 0 then 1221 RectFrame.Bottom := FrameBottom; 1222 DrawFrame(RectFrame); 1223 end; 1224 1225 NeedDistArray:= ForceEto or (CharExtra <> 0) or 1226 (FBaseCharWidth <> FFontStock.CharAdvance) or FFontStock.NeedETO; 1227 ForceEto := False; 1228 //DebugLn(['TheTextDrawer.ExtTextOut NeedDistArray=',NeedDistArray]); 1229 if NeedDistArray then begin 1230 if (FEtoInitLen < Length) then 1231 InitETODist(GetCharWidth); 1232 DistArray := FEto.Eto; 1233 end else begin 1234 DistArray:=nil; 1235 end; 1236 if UseUTF8 then 1237 LCLIntf.ExtUTF8Out(FDC, X, Y, fuOptions, @ARect, Text, Length, DistArray) 1238 else 1239 LCLIntf.ExtTextOut(FDC, X, Y, fuOptions, @ARect, Text, Length, DistArray); 1240end; 1241 1242procedure TheTextDrawer.NewTextOut(X, Y: Integer; fuOptions: UINT; const ARect: TRect; 1243 Text: PChar; Length: Integer; AnEto: TEtoBuffer); 1244var 1245 EtoArray: PInteger; 1246begin 1247 if AnEto <> nil then 1248 EtoArray := AnEto.Eto 1249 else 1250 EtoArray := nil; 1251 1252 if UseUTF8 then 1253 LCLIntf.ExtUTF8Out(FDC, X, Y, fuOptions, @ARect, Text, Length, EtoArray) 1254 else 1255 LCLIntf.ExtTextOut(FDC, X, Y, fuOptions, @ARect, Text, Length, EtoArray); 1256 1257end; 1258 1259procedure TheTextDrawer.DrawFrame(const ARect: TRect); 1260const 1261 WaveRadius = 3; 1262 PenStyle: array[TSynLineStyle] of LongWord = ( 1263 { slsSolid } PS_SOLID, 1264 { slsDashed } PS_DASH, 1265 { slsDotted } PS_DOT, 1266 { slsWaved } PS_SOLID // we draw a wave using solid pen 1267 ); 1268var 1269 Pen, OldPen: HPen; 1270 old: TPoint; 1271 Side: TLazSynBorderSide; 1272 LastColor: TColor; 1273 LastStyle: LongWord; 1274begin 1275 OldPen := 0; 1276 LastColor := clNone; 1277 LastStyle := PS_NULL; 1278 for Side := Low(TLazSynBorderSide) to High(TLazSynBorderSide) do 1279 begin 1280 if FFrameColor[Side] <> clNone then 1281 begin 1282 if (OldPen = 0) or (FFrameColor[Side] <> LastColor) or 1283 (PenStyle[FFrameStyle[Side]] <> LastStyle) then 1284 begin 1285 LastColor := FFrameColor[Side]; 1286 LastStyle := PenStyle[FFrameStyle[Side]]; 1287 if OldPen <> 0 then 1288 DeleteObject(SelectObject(FDC, OldPen)); 1289 Pen := CreateColorPen(LastColor, LastStyle); 1290 OldPen := SelectObject(FDC, Pen); 1291 end; 1292 1293 case Side of 1294 bsLeft: 1295 begin 1296 MoveToEx(FDC, ARect.Left, ARect.Top, @old); 1297 if FFrameStyle[Side] = slsWaved then 1298 WaveTo(FDC, ARect.Left, ARect.Bottom, WaveRadius) 1299 else 1300 LineTo(FDC, ARect.Left, ARect.Bottom); 1301 end; 1302 bsTop: 1303 begin 1304 MoveToEx(FDC, ARect.Left, ARect.Top, @old); 1305 if FFrameStyle[Side] = slsWaved then 1306 WaveTo(FDC, ARect.Right, ARect.Top, WaveRadius) 1307 else 1308 LineTo(FDC, ARect.Right, ARect.Top); 1309 end; 1310 bsRight: 1311 begin 1312 if FFrameStyle[Side] = slsWaved then 1313 begin 1314 MoveToEx(FDC, ARect.Right - WaveRadius, ARect.Top, @old); 1315 WaveTo(FDC, ARect.Right - WaveRadius, ARect.Bottom, WaveRadius) 1316 end 1317 else 1318 begin 1319 MoveToEx(FDC, ARect.Right - 1, ARect.Top, @old); 1320 LineTo(FDC, ARect.Right - 1, ARect.Bottom); 1321 end; 1322 end; 1323 bsBottom: 1324 begin 1325 if FFrameStyle[Side] = slsWaved then 1326 begin 1327 MoveToEx(FDC, ARect.Left, ARect.Bottom - WaveRadius, @old); 1328 WaveTo(FDC, ARect.Right, ARect.Bottom - WaveRadius, WaveRadius) 1329 end 1330 else 1331 begin 1332 MoveToEx(FDC, ARect.Left, ARect.Bottom - 1, @old); 1333 LineTo(FDC, ARect.Right, ARect.Bottom - 1); 1334 end; 1335 end; 1336 end; 1337 MoveToEx(FDC, ARect.Left, ARect.Top, @old); 1338 end; 1339 end; 1340 DeleteObject(SelectObject(FDC, OldPen)); 1341end; 1342 1343procedure TheTextDrawer.ForceNextTokenWithEto; 1344begin 1345 ForceEto := True; 1346end; 1347 1348function TheTextDrawer.NeedsEto: boolean; 1349begin 1350 Result := (CharExtra <> 0) or (FBaseCharWidth <> FFontStock.CharAdvance) or FFontStock.NeedETO; 1351end; 1352 1353procedure TheTextDrawer.DrawLine(X, Y, X2, Y2: Integer; AColor: TColor); 1354var 1355 Pen, OldPen: HPen; 1356 old : TPoint; 1357begin 1358 Pen := CreateColorPen(AColor); 1359 OldPen := SelectObject(FDC, Pen); 1360 MoveToEx(FDC, X, Y, @old); 1361 LineTo(FDC, X2, Y2); 1362 DeleteObject(SelectObject(FDC, OldPen)); 1363end; 1364 1365procedure TheTextDrawer.FillRect(const aRect: TRect); 1366begin 1367 InternalFillRect(FDC, aRect); 1368end; 1369 1370procedure TheTextDrawer.ReleaseTemporaryResources; 1371begin 1372 FFontStock.ReleaseFontHandles; 1373end; 1374 1375procedure TheTextDrawer.RegisterOnFontChangeHandler(AHandlerProc: TNotifyEvent); 1376begin 1377 FOnFontChangedHandlers.Add(TMethod(AHandlerProc)); 1378end; 1379 1380procedure TheTextDrawer.UnRegisterOnFontChangeHandler(AHandlerProc: TNotifyEvent); 1381begin 1382 FOnFontChangedHandlers.Remove(TMethod(AHandlerProc)); 1383end; 1384 1385{ TheTextDrawerEx } 1386 1387procedure TheTextDrawerEx.AfterStyleSet; 1388begin 1389 inherited; 1390 with FontStock do 1391 begin 1392 FCrntDx := BaseCharWidth - CharAdvance; 1393 case IsDBCSFont of 1394 False: 1395 begin 1396 if StockDC <> 0 then 1397 SetTextCharacterExtra(StockDC, CharExtra + FCrntDx); 1398 if IsTrueType or (not (fsItalic in Style)) then 1399 FExtTextOutProc := 1400 @TextOutOrExtTextOut 1401 else 1402 FExtTextOutProc := 1403 @ExtTextOutFixed; 1404 end; 1405 True: 1406 begin 1407 FCrntDBDx := DBCHAR_CALCULATION_FALED; 1408 FExtTextOutProc := 1409 @ExtTextOutWithETO; 1410 end; 1411 end; 1412 end; 1413end; 1414 1415procedure TheTextDrawerEx.ExtTextOut(X, Y: Integer; fuOptions: UINT; 1416 const ARect: TRect; Text: PChar; Length: Integer; FrameBottom: Integer = -1); 1417begin 1418 FExtTextOutProc(X, Y, fuOptions, ARect, Text, Length); 1419end; 1420 1421procedure TheTextDrawerEx.ExtTextOutFixed(X, Y: Integer; fuOptions: UINT; 1422 const ARect: TRect; Text: PChar; Length: Integer); 1423begin 1424 LCLIntf.ExtTextOut(StockDC, X, Y, fuOptions, @ARect, Text, Length, nil); 1425end; 1426 1427procedure TheTextDrawerEx.ExtTextOutForDBCS(X, Y: Integer; fuOptions: UINT; 1428 const ARect: TRect; Text: PChar; Length: Integer); 1429var 1430 pCrnt: PChar; 1431 pTail: PChar; 1432 pRun: PChar; 1433 1434 procedure GetSBCharRange; 1435 begin 1436 while (pRun <> pTail) and (not (pRun^ in LeadBytes)) do 1437 Inc(pRun); 1438 end; 1439 1440 procedure GetDBCharRange; 1441 begin 1442 while (pRun <> pTail) and (pRun^ in LeadBytes) do 1443 Inc(pRun, 2); 1444 end; 1445 1446var 1447 TmpRect: TRect; 1448 Len: Integer; 1449 n: Integer; 1450begin 1451 pCrnt := Text; 1452 pRun := Text; 1453 pTail := PChar(Pointer(Text) + Length); 1454 TmpRect := ARect; 1455 while pCrnt < pTail do 1456 begin 1457 GetSBCharRange; 1458 if pRun <> pCrnt then 1459 begin 1460 SetTextCharacterExtra(StockDC, CharExtra + FCrntDx); 1461 Len := PtrUInt(pRun) - PtrUInt(pCrnt); 1462 with TmpRect do 1463 begin 1464 n := GetCharWidth * Len; 1465 Right := Min(Left + n + GetCharWidth, ARect.Right); 1466 LCLIntf.ExtTextOut(StockDC, X, Y, fuOptions, @TmpRect, pCrnt, Len, nil); 1467 Inc(X, n); 1468 Inc(Left, n); 1469 end; 1470 end; 1471 pCrnt := pRun; 1472 if pRun = pTail then 1473 break; 1474 1475 GetDBCharRange; 1476 SetTextCharacterExtra(StockDC, CharExtra + FCrntDBDx); 1477 Len := PtrUInt(pRun) - PtrUInt(pCrnt); 1478 with TmpRect do 1479 begin 1480 n := GetCharWidth * Len; 1481 Right := Min(Left + n + GetCharWidth, ARect.Right); 1482 LCLIntf.ExtTextOut(StockDC, X, Y, fuOptions, @TmpRect, pCrnt, Len, nil); 1483 Inc(X, n); 1484 Inc(Left, n); 1485 end; 1486 pCrnt := pRun; 1487 end; 1488 1489 if (pCrnt = Text) or // maybe Text is not assigned or Length is 0 1490 (TmpRect.Right < ARect.Right) then 1491 begin 1492 SetTextCharacterExtra(StockDC, CharExtra + FCrntDx); 1493 LCLIntf.ExtTextOut(StockDC, X, Y, fuOptions, @TmpRect, nil, 0, nil); 1494 end; 1495end; 1496 1497procedure TheTextDrawerEx.ExtTextOutWithETO(X, Y: Integer; fuOptions: UINT; 1498 const ARect: TRect; Text: PChar; Length: Integer); 1499begin 1500 inherited ExtTextOut(X, Y, fuOptions, ARect, Text, Length); 1501end; 1502 1503procedure TheTextDrawerEx.TextOutOrExtTextOut(X, Y: Integer; 1504 fuOptions: UINT; const ARect: TRect; Text: PChar; Length: Integer); 1505begin 1506 // this function may be used when: 1507 // a. the text does not containing any multi-byte characters 1508 // AND 1509 // a-1. current font is TrueType. 1510 // a-2. current font is RasterType and it is not italic. 1511 with ARect do 1512 if Assigned(Text) and (Length > 0) 1513 and (Left = X) and (Top = Y) 1514 and ((Bottom - Top) = GetCharHeight) 1515 and 1516 (Left + GetCharWidth * (Length + 1) > Right) 1517 then 1518 LCLIntf.TextOut(StockDC, X, Y, Text, Length) 1519 else 1520 LCLIntf.ExtTextOut(StockDC, X, Y, fuOptions, @ARect, Text, Length, nil) 1521end; 1522 1523{$IFNDEF HE_LEADBYTES} 1524procedure InitializeLeadBytes; 1525var 1526 c: Char; 1527begin 1528 for c := Low(Char) to High(Char) do 1529 if IsDBCSLeadByte(Byte(c)) then 1530 Include(LeadBytes, c); 1531end; 1532{$ENDIF} // HE_LEADBYTES 1533 1534initialization 1535 SynTextDrawerFinalization:=false; 1536{$IFNDEF HE_LEADBYTES} 1537 InitializeLeadBytes; 1538{$ENDIF} 1539 1540finalization 1541 // MG: We can't free the gFontsInfoManager here, because the synedit 1542 // components need it and will be destroyed with the Application object in 1543 // the lcl after this finalization section. 1544 // So, the flag SynTextDrawerFinalization is set and the gFontsInfoManager 1545 // will destroy itself, as soon, as it is not used anymore. 1546 SynTextDrawerFinalization:=true; 1547 if Assigned(gFontsInfoManager) and (gFontsInfoManager.FFontsInfo.Count=0) 1548 then 1549 FreeAndNil(gFontsInfoManager); 1550 1551end. 1552 1553