1{%MainUnit ../graphics.pp} 2{****************************************************************************** 3 TCANVAS 4 ****************************************************************************** 5 6 ***************************************************************************** 7 This file is part of the Lazarus Component Library (LCL) 8 9 See the file COPYING.modifiedLGPL.txt, included in this distribution, 10 for details about the license. 11 ***************************************************************************** 12} 13 14const 15 csAllValid = [csHandleValid..csBrushValid]; 16 17{-----------------------------------------------} 18{-- TCanvas.Draw --} 19{-----------------------------------------------} 20procedure TCanvas.Draw(X, Y: Integer; SrcGraphic: TGraphic); 21var 22 ARect: TRect; 23begin 24 if not Assigned(SrcGraphic) then exit; 25 ARect:=Bounds(X,Y,SrcGraphic.Width,SrcGraphic.Height); 26 StretchDraw(ARect,SrcGraphic); 27end; 28 29{-----------------------------------------------} 30{-- TCanvas.DrawFocusRect --} 31{-----------------------------------------------} 32procedure TCanvas.DrawFocusRect(const ARect: TRect); 33begin 34 Changing; 35 RequiredState([csHandleValid]); 36 LCLIntf.DrawFocusRect(FHandle, ARect); 37 Changed; 38end; 39 40{-----------------------------------------------} 41{-- TCanvas.StretchDraw --} 42{-----------------------------------------------} 43procedure TCanvas.StretchDraw(const DestRect: TRect; SrcGraphic: TGraphic); 44begin 45 if not Assigned(SrcGraphic) then exit; 46 Changing; 47 RequiredState([csHandleValid]); 48 SrcGraphic.Draw(Self, DestRect); 49 Changed; 50end; 51 52{-----------------------------------------------} 53{-- TCanvas.GetClipRect --} 54{-----------------------------------------------} 55function TCanvas.GetClipRect: TRect; 56begin 57 // return actual clipping rectangle 58 if GetClipBox(FHandle, @Result) = ERROR then 59 Result := Rect(0, 0, 2000, 2000);{Just in Case} 60end; 61 62procedure TCanvas.SetClipRect(const ARect: TRect); 63var 64 RGN: HRGN; 65 LogicalRect: TRect; 66begin 67 inherited SetClipRect(ARect); 68 if inherited GetClipping then 69 begin 70 // ARect is in logical coords. CreateRectRGN accepts device coords. 71 // So we need to translate them 72 LogicalRect := ARect; 73 LPtoDP(Handle, LogicalRect, 2); 74 with LogicalRect do 75 RGN := CreateRectRGN(Left, Top, Right, Bottom); 76 SelectClipRGN(Handle, RGN); 77 DeleteObject(RGN); 78 end; 79end; 80 81function TCanvas.GetClipping: Boolean; 82var 83 R: TRect; 84begin 85 Result := GetClipBox(FHandle, @R) > NullRegion; 86end; 87 88procedure TCanvas.SetClipping(const AValue: boolean); 89begin 90 inherited SetClipping(AValue); 91 if AValue then 92 SetClipRect(inherited GetClipRect) 93 else 94 SelectClipRGN(Handle, 0); 95end; 96 97 98{-----------------------------------------------} 99{-- TCanvas.CopyRect --} 100{-----------------------------------------------} 101procedure TCanvas.CopyRect(const Dest: TRect; SrcCanvas: TCanvas; 102 const Source: TRect); 103var 104 SH, SW, DH, DW: Integer; 105Begin 106 if SrcCanvas= nil then exit; 107 108 SH := Source.Bottom - Source.Top; 109 SW := Source.Right - Source.Left; 110 if (SH=0) or (SW=0) then exit; 111 DH := Dest.Bottom - Dest.Top; 112 DW := Dest.Right - Dest.Left; 113 if (Dh=0) or (DW=0) then exit; 114 115 SrcCanvas.RequiredState([csHandleValid]); 116 Changing; 117 RequiredState([csHandleValid]); 118 119 //DebugLn('TCanvas.CopyRect ',ClassName,' SrcCanvas=',SrcCanvas.ClassName,' ', 120 // ' Src=',Source.Left,',',Source.Top,',',SW,',',SH, 121 // ' Dest=',Dest.Left,',',Dest.Top,',',DW,',',DH); 122 StretchBlt(FHandle, Dest.Left, Dest.Top, DW, DH, 123 SrcCanvas.FHandle, Source.Left, Source.Top, SW, SH, CopyMode); 124 Changed; 125end; 126{-----------------------------------------------} 127{-- TCanvas.GetPixel --} 128{-----------------------------------------------} 129function TCanvas.GetPixel(X, Y: Integer): TColor; 130begin 131 RequiredState([csHandleValid]); 132 Result := WidgetSet.DCGetPixel(FHandle, X, Y); 133end; 134 135{-----------------------------------------------} 136{-- TCanvas.SetPixel --} 137{-----------------------------------------------} 138procedure TCanvas.SetPixel(X, Y: Integer; Value: TColor); 139begin 140 Changing; 141 RequiredState([csHandleValid, csPenvalid]); 142 WidgetSet.DCSetPixel(FHandle, X, Y, Value); 143 Changed; 144end; 145 146{------------------------------------------------------------------------------ 147 procedure TCanvas.RealizeAutoRedraw; 148 ------------------------------------------------------------------------------} 149procedure TCanvas.RealizeAutoRedraw; 150begin 151 if FAutoRedraw and HandleAllocated then 152 WidgetSet.DCRedraw(Handle); 153end; 154 155procedure TCanvas.RealizeAntialiasing; 156begin 157 if HandleAllocated then 158 begin 159 // do not call Changed, the content has not changed 160 case FAntialiasingMode of 161 amOn: WidgetSet.DCSetAntialiasing(FHandle, True); 162 amOff: WidgetSet.DCSetAntialiasing(FHandle, False); 163 else 164 WidgetSet.DCSetAntialiasing(FHandle, Boolean(WidgetSet.GetLCLCapability(lcAntialiasingEnabledByDefault)) ) 165 end; 166 end; 167end; 168 169{------------------------------------------------------------------------------ 170 Method: TCanvas.CreateBrush 171 Params: None 172 Returns: Nothing 173 174 ------------------------------------------------------------------------------} 175procedure TCanvas.CreateBrush; 176const 177 HatchBrushes = [bsHorizontal, bsVertical, bsFDiagonal, bsBDiagonal, bsCross, bsDiagCross]; 178var 179 OldHandle: HBRUSH; 180begin 181 OldHandle := SelectObject(FHandle, HGDIOBJ(Brush.Reference.Handle)); 182 if (OldHandle <> HBRUSH(Brush.Reference.Handle)) and (FSavedBrushHandle=0) then 183 FSavedBrushHandle := OldHandle; 184 Include(FState, csBrushValid); 185 // do not use color for hatched brushes. windows cannot draw hatches when SetBkColor is called 186 if ([Brush.Style] * HatchBrushes) = [] then 187 SetBkColor(FHandle, TColorRef(Brush.GetColor)); 188 if Brush.Style = bsSolid then 189 SetBkMode(FHandle, OPAQUE) 190 else 191 SetBkMode(FHandle, TRANSPARENT); 192end; 193 194{------------------------------------------------------------------------------ 195 Method: TCanvas.CreatePen 196 Params: None 197 Returns: Nothing 198 199 ------------------------------------------------------------------------------} 200procedure TCanvas.CreatePen; 201var 202 OldHandle: HPEN; 203 204const 205 PenModes: array[TPenMode] of Integer = 206 ( 207{pmBlack } R2_BLACK, 208{pmWhite } R2_WHITE, 209{pmNop } R2_NOP, 210{pmNot } R2_NOT, 211{pmCopy } R2_COPYPEN, 212{pmNotCopy } R2_NOTCOPYPEN, 213{pmMergePenNot} R2_MERGEPENNOT, 214{pmMaskPenNot } R2_MASKPENNOT, 215{pmMergeNotPen} R2_MERGENOTPEN, 216{pmMaskNotPen } R2_MASKNOTPEN, 217{pmMerge } R2_MERGEPEN, 218{pmNotMerge } R2_NOTMERGEPEN, 219{pmMask } R2_MASKPEN, 220{pmNotMask } R2_NOTMASKPEN, 221{pmXor } R2_XORPEN, 222{pmNotXor } R2_NOTXORPEN 223 ); 224begin 225//DebugLn('[TCanvas.CreatePen] ',Classname,' Self=',DbgS(Self) 226// ,' Pen=',DbgS(Pen)); 227 OldHandle := SelectObject(FHandle, HGDIOBJ(Pen.Reference.Handle)); 228 if (OldHandle <> HPEN(Pen.Reference.Handle)) and (FSavedPenHandle=0) then 229 FSavedPenHandle := OldHandle; 230 MoveTo(PenPos.X, PenPos.Y); 231 Include(FState, csPenValid); 232 SetROP2(FHandle, PenModes[Pen.Mode]); 233end; 234 235{------------------------------------------------------------------------------ 236 Method: TCanvas.CreateFont 237 Params: None 238 Returns: Nothing 239 240 ------------------------------------------------------------------------------} 241procedure TCanvas.CreateFont; 242var 243 OldHandle: HFONT; 244begin 245 // The first time the font handle is selected, the default font handle 246 // is returned. Save this font handle to restore it later in DeselectHandles. 247 // The TFont will call DeleteObject itself, so we never need to call it. 248 OldHandle := SelectObject(FHandle, HGDIOBJ(Font.Reference.Handle)); 249 //DebugLn(['TCanvas.CreateFont OldHandle=',dbghex(OldHandle),' Font.Handle=',dbghex(Font.Handle)]); 250 if (OldHandle <> HFONT(Font.Reference.Handle)) and (FSavedFontHandle = 0) then 251 FSavedFontHandle := OldHandle; 252 Include(FState, csFontValid); 253 SetTextColor(FHandle, TColorRef(Font.GetColor)); 254end; 255 256{------------------------------------------------------------------------------ 257 procedure TCanvas.CreateRegion; 258 ------------------------------------------------------------------------------} 259procedure TCanvas.CreateRegion; 260var 261 OldHandle: HRGN; 262begin 263 OldHandle := SelectObject(FHandle, HGDIOBJ(Region.Reference.Handle)); 264 if (OldHandle <> HRGN(Region.Reference.Handle)) and (FSavedRegionHandle=0) then 265 FSavedRegionHandle := OldHandle; 266 Include(FState, csRegionValid); 267end; 268 269{------------------------------------------------------------------------------ 270 Method: TCanvas.SetAutoReDraw 271 Params: Value 272 Returns: Nothing 273 274 ------------------------------------------------------------------------------} 275procedure TCanvas.SetAutoRedraw(Value : Boolean); 276begin 277 if FAutoRedraw=Value then exit; 278 FAutoRedraw := Value; 279 RealizeAutoRedraw; 280end; 281 282{------------------------------------------------------------------------------ 283 procedure TCanvas.SetInternalPenPos(const Value: TPoint); 284 ------------------------------------------------------------------------------} 285procedure TCanvas.SetInternalPenPos(const Value: TPoint); 286begin 287 inherited SetPenPos(Value); 288end; 289 290{------------------------------------------------------------------------------ 291 Method: TCanvas.SetLazBrush 292 Params: Value 293 Returns: Nothing 294 295 ------------------------------------------------------------------------------} 296procedure TCanvas.SetLazBrush(Value : TBrush); 297begin 298 FLazBrush.Assign(Value); 299end; 300 301procedure TCanvas.SetPenPos(const AValue: TPoint); 302begin 303 MoveTo(AValue.X,AValue.Y); 304end; 305 306{------------------------------------------------------------------------------ 307 Method: TCanvas.SetLazFont 308 Params: Value 309 Returns: Nothing 310 311 ------------------------------------------------------------------------------} 312procedure TCanvas.SetLazFont(Value : TFont); 313begin 314 FLazFont.Assign(Value); 315end; 316 317{------------------------------------------------------------------------------ 318 Method: TCanvas.SetLazPen 319 Params: Value 320 Returns: Nothing 321 322 ------------------------------------------------------------------------------} 323procedure TCanvas.SetLazPen(Value : TPen); 324begin 325 FLazPen.Assign(Value); 326end; 327 328{------------------------------------------------------------------------------ 329 Method: TCanvas.SetRegion 330 Params: Value 331 Returns: Nothing 332 333 ------------------------------------------------------------------------------} 334procedure TCanvas.SetRegion(Value: TRegion); 335begin 336 FRegion.Assign(Value); 337end; 338 339function TCanvas.DoCreateDefaultFont: TFPCustomFont; 340begin 341 Result:=TFont.Create; 342end; 343 344function TCanvas.DoCreateDefaultPen: TFPCustomPen; 345begin 346 Result:=TPen.Create; 347end; 348 349function TCanvas.DoCreateDefaultBrush: TFPCustomBrush; 350begin 351 Result:=TBrush.Create; 352end; 353 354procedure TCanvas.SetColor(x, y: integer; const Value: TFPColor); 355begin 356 Pixels[x,y]:=FPColorToTColor(Value); 357end; 358 359function TCanvas.GetColor(x, y: integer): TFPColor; 360begin 361 Result:=TColorToFPColor(Pixels[x,y]); 362end; 363 364procedure TCanvas.SetHeight(AValue: integer); 365begin 366 RaiseGDBException('TCanvas.SetHeight not allowed for LCL canvas'); 367end; 368 369function TCanvas.GetHeight: integer; 370var 371 p: TPoint; 372begin 373 if HandleAllocated then begin 374 GetDeviceSize(Handle,p); 375 Result:=p.y; 376 end else 377 Result:=0; 378end; 379 380procedure TCanvas.SetWidth(AValue: integer); 381begin 382 RaiseGDBException('TCanvas.SetWidth not allowed for LCL canvas'); 383end; 384 385function TCanvas.GetWidth: integer; 386var 387 p: TPoint; 388begin 389 if HandleAllocated then begin 390 GetDeviceSize(Handle,p); 391 Result:=p.x; 392 end else 393 Result:=0; 394end; 395 396procedure TCanvas.GradientFill(ARect: TRect; AStart, AStop: TColor; 397 ADirection: TGradientDirection); 398var 399 RStart, RStop: Byte; 400 GStart, GStop: Byte; 401 BStart, BStop: Byte; 402 RDiff, GDiff, BDiff: Integer; 403 Count, I: Integer; 404begin 405 if IsRectEmpty(ARect) then 406 Exit; 407 408 RedGreenBlue(ColorToRGB(AStart), RStart, GStart, BStart); 409 RedGreenBlue(ColorToRGB(AStop), RStop, GStop, BStop); 410 411 RDiff := RStop - RStart; 412 GDiff := GStop - GStart; 413 BDiff := BStop - BStart; 414 415 if ADirection = gdVertical then 416 Count := ARect.Bottom - ARect.Top 417 else 418 Count := ARect.Right - ARect.Left; 419 420 Changing; 421 for I := 0 to Count-1 do 422 begin 423 Pen.Color := RGBToColor(RStart + (i * RDiff) div Count, 424 GStart + (i * GDiff) div Count, 425 BStart + (i * BDiff) div Count); 426 427 RequiredState([csHandleValid, csPenValid]); 428 if ADirection = gdHorizontal 429 then begin 430 // draw top to bottom, because LineTo does not draw last pixel 431 LCLIntf.MoveToEx(FHandle, ARect.Left+I, ARect.Top, nil); 432 LCLIntf.LineTo(FHandle, ARect.Left+I, ARect.Bottom); 433 end 434 else begin 435 // draw left to right, because LineTo does not draw last pixel 436 LCLIntf.MoveToEx(FHandle, ARect.Left, ARect.Top+I, nil); 437 LCLIntf.LineTo(FHandle, ARect.Right, ARect.Top+I); 438 end; 439 end; 440 Changed; 441end; 442 443procedure TCanvas.DoLockCanvas; 444begin 445 if FLock=0 then InitializeCriticalSection(FLock); 446 EnterCriticalSection(FLock); 447 inherited DoLockCanvas; 448end; 449 450procedure TCanvas.DoUnlockCanvas; 451begin 452 LeaveCriticalSection(FLock); 453 inherited DoUnlockCanvas; 454end; 455 456procedure TCanvas.DoTextOut(x, y: integer; Text: string); 457begin 458 TextOut(X,Y,Text); 459end; 460 461procedure TCanvas.DoGetTextSize(Text: string; var w, h: integer); 462var 463 TxtSize: TSize; 464begin 465 TxtSize:=TextExtent(Text); 466 w:=TxtSize.cx; 467 h:=TxtSize.cy; 468end; 469 470function TCanvas.DoGetTextHeight(Text: string): integer; 471begin 472 Result:=TextHeight(Text); 473end; 474 475function TCanvas.DoGetTextWidth(Text: string): integer; 476begin 477 Result:=TextWidth(Text); 478end; 479 480procedure TCanvas.DoRectangle(const Bounds: TRect); 481begin 482 Frame(Bounds); 483end; 484 485procedure TCanvas.DoRectangleFill(const Bounds: TRect); 486begin 487 FillRect(Bounds); 488end; 489 490procedure TCanvas.DoRectangleAndFill(const Bounds: TRect); 491begin 492 Rectangle(Bounds); 493end; 494 495procedure TCanvas.DoEllipse(const Bounds: TRect); 496var 497 x1: Integer; 498 y1: Integer; 499 x2: Integer; 500 y2: Integer; 501begin 502 if Bounds.Left < Bounds.Right then 503 begin 504 x1 := Bounds.Left; 505 x2 := Bounds.Right; 506 end else 507 begin 508 x1 := Bounds.Right; 509 x2 := Bounds.Left; 510 end; 511 if Bounds.Top < Bounds.Bottom then 512 begin 513 y1 := Bounds.Top; 514 y2 := Bounds.Bottom; 515 end else 516 begin 517 y1 := Bounds.Bottom; 518 y2 := Bounds.Top; 519 end; 520 Arc(x1, y1, x2, y2, 0, 360*16); 521end; 522 523procedure TCanvas.DoEllipseFill(const Bounds: TRect); 524begin 525 Ellipse(Bounds); 526end; 527 528procedure TCanvas.DoEllipseAndFill(const Bounds: TRect); 529begin 530 inherited DoEllipseAndFill(Bounds); 531end; 532 533procedure TCanvas.DoPolygon(const Points: array of TPoint); 534begin 535 Polyline(Points); 536end; 537 538procedure TCanvas.DoPolygonFill(const Points: array of TPoint); 539begin 540 Polygon(Points); 541end; 542 543procedure TCanvas.DoPolygonAndFill(const Points: array of TPoint); 544begin 545 inherited DoPolygonAndFill(Points); 546end; 547 548procedure TCanvas.DoPolyline(const Points: array of TPoint); 549begin 550 Polyline(Points); 551end; 552 553procedure TCanvas.DoPolyBezier(Points: PPoint; NumPts: Integer; 554 Filled: boolean; Continuous: boolean); 555begin 556 PolyBezier(Points,NumPts,Filled,Continuous); 557end; 558 559procedure TCanvas.DoFloodFill(x, y: integer); 560begin 561 FloodFill(x, y, Brush.Color, fsSurface); 562end; 563 564procedure TCanvas.DoMoveTo(x, y: integer); 565begin 566 RequiredState([csHandleValid]); 567 if LCLIntf.MoveToEx(FHandle, X, Y, nil) then 568 SetInternalPenPos(Point(X, Y)); 569end; 570 571procedure TCanvas.DoLineTo(x, y: integer); 572begin 573 Changing; 574 RequiredState([csHandleValid, csPenValid]); 575 if LCLIntf.LineTo(FHandle, X, Y) then 576 SetInternalPenPos(Point(X, Y)); 577 Changed; 578end; 579 580procedure TCanvas.DoLine(x1, y1, x2, y2: integer); 581begin 582 MoveTo(x1,y1); 583 LineTo(x2,y2); 584end; 585 586procedure TCanvas.DoCopyRect(x, y: integer; SrcCanvas: TFPCustomCanvas; 587 const SourceRect: TRect); 588 589 procedure WarnNotSupported; 590 begin 591 debugln('WARNING: TCanvas.DoCopyRect from ',DbgSName(SrcCanvas)); 592 end; 593 594var 595 SH: Integer; 596 SW: Integer; 597Begin 598 if SrcCanvas=nil then exit; 599 if SrcCanvas is TCanvas then begin 600 SW := SourceRect.Right - SourceRect.Left; 601 SH := SourceRect.Bottom - SourceRect.Top; 602 if (SH=0) or (SW=0) then exit; 603 CopyRect(Rect(x,y,x+SW,y+SH),TCanvas(SrcCanvas),SourceRect); 604 end else begin 605 WarnNotSupported; 606 end; 607end; 608 609procedure TCanvas.DoDraw(x, y: integer; const Image: TFPCustomImage); 610var 611 LazImg: TLazIntfImage; 612 BitmapHnd, DummyHnd: HBitmap; 613begin 614 if Image=nil then exit; 615 616 BitmapHnd:=0; 617 try 618 if Image is TLazIntfImage 619 then begin 620 LazImg := TLazIntfImage(Image); 621 end 622 else begin 623 LazImg := TLazIntfImage.Create(0,0,[]); 624 RequiredState([csHandleValid]); 625 LazImg.DataDescription := GetDescriptionFromDevice(Handle, 0, 0); 626 LazImg.Assign(Image); 627 end; 628 LazImg.CreateBitmaps(BitmapHnd, DummyHnd, True); 629 if BitmapHnd=0 then exit; 630 631 Changing; 632 RequiredState([csHandleValid]); 633 StretchBlt(FHandle,x,y,LazImg.Width,LazImg.Height, 634 BitmapHnd, 0,0,LazImg.Width,LazImg.Height, CopyMode); 635 Changed; 636 finally 637 if Image <> LazImg then LazImg.Free; 638 if BitmapHnd <> 0 then DeleteObject(BitmapHnd); 639 end; 640end; 641 642procedure TCanvas.CheckHelper(AHelper: TFPCanvasHelper); 643begin 644 debugln('TCanvas.CheckHelper ignored for ',DbgSName(AHelper)); 645end; 646 647function TCanvas.GetDefaultColor(const ADefaultColorType: TDefaultColorType): TColor; 648begin 649 Result := clDefault; 650end; 651 652{------------------------------------------------------------------------------ 653 Method: TCanvas.Arc 654 Params: ALeft, ATop, ARight, ABottom, Angle, AngleLength 655 Returns: Nothing 656 657 Use Arc to draw an elliptically curved line with the current Pen. 658 The angles Angle and AngleLength are 1/16th of a degree. For example, a full 659 circle equals 5760 (16*360). Positive values of Angle and AngleLength mean 660 counter-clockwise while negative values mean clockwise direction. 661 Zero degrees is at the 3'o clock position. 662 663 ------------------------------------------------------------------------------} 664procedure TCanvas.Arc(ALeft, ATop, ARight, ABottom, 665 Angle16Deg, Angle16DegLength: Integer); 666begin 667 Changing; 668 RequiredState([csHandleValid, csPenValid]); 669 LCLIntf.Arc(FHandle, ALeft, ATop, ARight, ABottom, Angle16Deg, Angle16DegLength); 670 Changed; 671end; 672 673procedure TCanvas.ArcTo(ALeft, ATop, ARight, ABottom, SX, SY, EX, EY: Integer); 674var 675 r: TRect; 676begin 677 r:=Rect(ALeft, ATop, ARight, ABottom); 678 LineTo(RadialPoint(EccentricAngle(Point(SX, SY), r), r)); 679 Arc(ALeft, ATop, ARight, ABottom, SX, SY, EX, EY); 680 MoveTo(RadialPoint(EccentricAngle(Point(EX, EY), r), r)); 681end; 682 683procedure TCanvas.AngleArc(X, Y: Integer; Radius: Longword; StartAngle, SweepAngle: Single); 684var x1, y1, x2, y2: integer; 685begin 686 x1:=trunc(x+cos(pi*StartAngle/180)*Radius); 687 y1:=trunc(y-sin(pi*StartAngle/180)*Radius); 688 x2:=trunc(x+cos(pi*(StartAngle+SweepAngle)/180)*Radius); 689 y2:=trunc(y-sin(pi*(StartAngle+SweepAngle)/180)*Radius); 690 LineTo(x1,y1); 691 if SweepAngle>0 then 692 Arc(x-Radius, y-Radius, x+Radius, y+Radius, x1, y1, x2, y2) 693 else 694 Arc(x-Radius, y-Radius, x+Radius, y+Radius, x2, y2, x1, y1); 695 MoveTo(x2,y2); 696end; 697 698{------------------------------------------------------------------------------ 699 Method: TCanvas.Arc 700 Params: ALeft, ATop, ARight, ABottom, sx, sy, ex, ey 701 Returns: Nothing 702 703 Use Arc to draw an elliptically curved line with the current Pen. The 704 values sx,sy, and ex,ey represent the starting and ending radial-points 705 between which the Arc is drawn. 706 707------------------------------------------------------------------------------} 708procedure TCanvas.Arc(ALeft, ATop, ARight, ABottom, SX, SY, EX, EY: Integer); 709begin 710 Changing; 711 RequiredState([csHandleValid, csBrushValid, csPenValid]); 712 LCLIntf.RadialArc(FHandle, ALeft, ATop, ARight, ABottom, sx, sy, ex, ey); 713 Changed; 714end; 715 716{------------------------------------------------------------------------------ 717 Method: TCanvas.BrushCopy 718 Params: ADestRect, ABitmap, ASourceRect, ATransparentColor 719 Returns: Nothing 720 721 Makes a stretch draw operation while substituting a color of the source bitmap 722 with the color of the brush of the canvas 723 ------------------------------------------------------------------------------} 724procedure TCanvas.BrushCopy(ADestRect: TRect; ABitmap: TBitmap; ASourceRect: TRect; 725 ATransparentColor: TColor); 726var 727 lIntfImage: TLazIntfImage; 728 lTransparentColor, lBrushColor, lPixelColor: TFPColor; 729 lPaintedBitmap: TBitmap; 730 x, y: Integer; 731 lSrcWidth, lSrcHeight: Integer; 732begin 733 // Preparation of data 734 //lDestWidth := ADestRect.Right - ADestRect.Left; 735 //lDestHeight := ADestRect.Bottom - ADestRect.Top; 736 lSrcWidth := ASourceRect.Right - ASourceRect.Left; 737 lSrcHeight := ASourceRect.Bottom - ASourceRect.Top; 738 lTransparentColor := TColorToFPColor(ColorToRGB(ATransparentColor)); 739 lBrushColor := TColorToFPColor(ColorToRGB(Brush.Color)); 740 741 lPaintedBitmap := TBitmap.Create; 742 lIntfImage := TLazIntfImage.Create(0, 0); 743 try 744 // First copy the source rectangle to another bitmap 745 // So that we don't have to iterate in pixels which wont be used changing the color 746 lPaintedBitmap.Width := lSrcWidth; 747 lPaintedBitmap.Height := lSrcHeight; 748 lPaintedBitmap.Canvas.Draw(-ASourceRect.Left, -ASourceRect.Top, ABitmap); 749 750 // Next copy the bitmap to a intfimage to be able to make the color change 751 lIntfImage.LoadFromBitmap(lPaintedBitmap.Handle, 0); 752 for x := 0 to lSrcWidth-1 do 753 for y := 0 to lSrcHeight-1 do 754 begin 755 lPixelColor := lIntfImage.Colors[x, y]; 756 if (lPixelColor.red = lTransparentColor.red) and 757 (lPixelColor.green = lTransparentColor.green) and 758 (lPixelColor.blue = lTransparentColor.blue) then 759 lIntfImage.Colors[x, y] := lBrushColor; 760 end; 761 762 // Now obtain a bitmap with the new image 763 lPaintedBitmap.LoadFromIntfImage(lIntfImage); 764 765 // And stretch draw it 766 Self.StretchDraw(ADestRect, lPaintedBitmap); 767 finally 768 lIntfImage.Free; 769 lPaintedBitmap.Free; 770 end; 771end; 772 773{------------------------------------------------------------------------------ 774 Method: TCanvas.RadialPie 775 Params: x1, y1, x2, y2, StartAngle16Deg, Angle16DegLength: Integer 776 Returns: Nothing 777 778 Use RadialPie to draw a filled pie-shaped wedge on the canvas. 779 The angles StartAngle16Deg and Angle16DegLength are 1/16th of a degree. 780 For example, a full circle equals 5760 (16*360). 781 Positive values of Angle and AngleLength mean 782 counter-clockwise while negative values mean clockwise direction. 783 Zero degrees is at the 3'o clock position. 784 785 ------------------------------------------------------------------------------} 786procedure TCanvas.RadialPie(x1, y1, x2, y2, 787 StartAngle16Deg, Angle16DegLength: Integer); 788begin 789 Changing; 790 RequiredState([csHandleValid, csBrushValid, csPenValid]); 791 LCLIntf.RadialPie(FHandle, x1, y1, x2, y2, StartAngle16Deg,Angle16DegLength); 792 Changed; 793end; 794 795{------------------------------------------------------------------------------ 796 Method: TCanvas.Pie 797 Params: EllipseX1, EllipseY1, EllipseX2, EllipseY2, 798 StartX, StartY, EndX, EndY 799 Returns: Nothing 800 801 Use Pie to draw a filled Pie-shaped wedge on the canvas. The pie is part of 802 an ellipse between the points EllipseX1, EllipseY1, EllipseX2, EllipseY2. 803 The values StartX, StartY and EndX, EndY represent the starting and ending 804 radial-points between which the Bounding-Arc is drawn. 805 806------------------------------------------------------------------------------} 807procedure TCanvas.Pie(EllipseX1, EllipseY1, EllipseX2, EllipseY2, 808 StartX, StartY, EndX, EndY: Integer); 809begin 810 Changing; 811 RequiredState([csHandleValid, csBrushValid, csPenValid]); 812 LCLIntf.Pie(FHandle,EllipseX1,EllipseY1,EllipseX2,EllipseY2, 813 StartX,StartY,EndX,EndY); 814 Changed; 815end; 816 817{------------------------------------------------------------------------------ 818 Method: TCanvas.PolyBezier 819 Params: Points, Filled, Continous 820 Returns: Boolean 821 822 Use Polybezier to draw cubic Bézier curves. The first curve is drawn from the 823 first point to the fourth point with the second and third points being the 824 control points. If the Continuous flag is TRUE then each subsequent curve 825 requires three more points, using the end-point of the previous Curve as its 826 starting point, the first and second points being used as its control points, 827 and the third point its end-point. If the continous flag is set to FALSE, 828 then each subsequent Curve requires 4 additional points, which are used 829 exactly as in the first curve. Any additonal points which do not add up to 830 a full bezier(4 for Continuous, 3 otherwise) are ignored. There must be at 831 least 4 points for an drawing to occur. If the Filled Flag is set to TRUE 832 then the resulting Poly-Bézier will be drawn as a Polygon. 833 834 ------------------------------------------------------------------------------} 835procedure TCanvas.PolyBezier(const Points: array of TPoint; 836 Filled: boolean = False; 837 Continuous: boolean = True); 838var NPoints, i: integer; 839 PointArray: ^TPoint; 840begin 841 NPoints:=High(Points)-Low(Points)+1; 842 if NPoints<4 then exit; // Curve must have at least 4 points 843 GetMem(PointArray,SizeOf(TPoint)*NPoints); 844 try 845 for i:=0 to NPoints-1 do 846 PointArray[i]:=Points[i+Low(Points)]; 847 PolyBezier(PointArray, NPoints, Filled, Continuous); 848 finally 849 FreeMem(PointArray); 850 end; 851end; 852 853procedure TCanvas.PolyBezier(Points: PPoint; NumPts: Integer; 854 Filled: boolean = False; 855 Continuous: boolean = True); 856begin 857 Changing; 858 RequiredState([csHandleValid, csBrushValid, csPenValid]); 859 LCLIntf.PolyBezier(FHandle,Points,NumPts,Filled, Continuous); 860 Changed; 861end; 862 863 864{------------------------------------------------------------------------------ 865 Method: TCanvas.Polygon 866 Params: Points: array of TPoint; Winding: Boolean = False; 867 StartIndex: Integer = 0; NumPts: Integer = -1 868 Returns: Nothing 869 870 Use Polygon to draw a closed, many-sided shape on the canvas, using the value 871 of Pen. After drawing the complete shape, Polygon fills the shape using the 872 value of Brush. 873 The Points parameter is an array of points that give the vertices of the 874 polygon. 875 Winding determines how the polygon is filled. When Winding is True, Polygon 876 fills the shape using the Winding fill algorithm. When Winding is False, 877 Polygon uses the even-odd (alternative) fill algorithm. 878 StartIndex gives the index of the first point in the array to use. All points 879 before this are ignored. 880 NumPts indicates the number of points to use, starting at StartIndex. 881 If NumPts is -1 (the default), Polygon uses all points from StartIndex to the 882 end of the array. 883 The first point is always connected to the last point. 884 To draw a polygon on the canvas, without filling it, use the Polyline method, 885 specifying the first point a second time at the end. 886} 887procedure TCanvas.Polygon(const Points: array of TPoint; Winding: Boolean; 888 StartIndex: Integer; NumPts: Integer); 889var 890 NPoints: integer; 891begin 892 if NumPts < 0 then 893 NPoints := High(Points) - StartIndex + 1 894 else 895 NPoints := NumPts; 896 if NPoints <= 0 then Exit; 897 Polygon(@Points[StartIndex], NPoints, Winding); 898end; 899 900procedure TCanvas.Polygon(Points: PPoint; NumPts: Integer; 901 Winding: boolean = False); 902begin 903 if NumPts <= 0 then Exit; 904 Changing; 905 RequiredState([csHandleValid, csBrushValid, csPenValid]); 906 LCLIntf.Polygon(FHandle, Points, NumPts, Winding); 907 Changed; 908end; 909 910{------------------------------------------------------------------------------ 911 Method: TCanvas.Polygon 912 Params: Points 913 Returns: Nothing 914 915 ------------------------------------------------------------------------------} 916procedure TCanvas.Polygon(const Points: array of TPoint); 917begin 918 Polygon(Points, True, Low(Points), High(Points) - Low(Points) + 1); 919end; 920 921{------------------------------------------------------------------------------ 922 Method: TCanvas.Polyline 923 Params: Points: array of TPoint; 924 StartIndex: Integer = 0; NumPts: Integer = -1 925 Returns: Nothing 926 927 Use Polyline to connect a set of points on the canvas. If you specify only two 928 points, Polyline draws a single line. 929 The Points parameter is an array of points to be connected. 930 StartIndex identifies the first point in the array to use. 931 NumPts indicates the number of points to use. If NumPts is -1 (the default), 932 PolyLine uses all the points from StartIndex to the end of the array. 933 Calling the MoveTo function with the value of the first point, and then 934 repeatedly calling LineTo with all subsequent points will draw the same image 935 on the canvas. However, unlike LineTo, Polyline does not change the value of 936 PenPos. 937} 938procedure TCanvas.Polyline(const Points: array of TPoint; StartIndex: Integer; 939 NumPts: Integer); 940var 941 NPoints : integer; 942begin 943 if NumPts<0 then 944 NPoints:=High(Points)-StartIndex+1 945 else 946 NPoints:=NumPts; 947 if NPoints<=0 then exit; 948 Polyline(@Points[StartIndex], NPoints); 949end; 950 951procedure TCanvas.Polyline(Points: PPoint; NumPts: Integer); 952begin 953 Changing; 954 RequiredState([csHandleValid, csPenValid]); 955 LCLIntf.Polyline(FHandle,Points,NumPts); 956 Changed; 957end; 958 959{------------------------------------------------------------------------------ 960 Method: TCanvas.Polyline 961 Params: Points 962 Returns: Nothing 963 964 ------------------------------------------------------------------------------} 965procedure TCanvas.Polyline(const Points: array of TPoint); 966begin 967 Polyline(Points, Low(Points), High(Points) - Low(Points) + 1); 968end; 969 970{------------------------------------------------------------------------------ 971 Method: TCanvas.Ellipse 972 Params: X1, Y1, X2, Y2 973 Returns: Nothing 974 975 Use Ellipse to draw a filled circle or ellipse on the canvas. 976 977 ------------------------------------------------------------------------------} 978procedure TCanvas.Ellipse(x1, y1, x2, y2: Integer); 979begin 980 Changing; 981 RequiredState([csHandleValid, csBrushValid, csPenValid]); 982 LCLIntf.Ellipse(FHandle,x1,y1,x2,y2); 983 Changed; 984end; 985 986{------------------------------------------------------------------------------ 987 Method: TCanvas.Ellipse 988 Params: ARect: TRect 989 Returns: Nothing 990 991 Use Ellipse to draw a filled circle or ellipse on the canvas. 992 993 ------------------------------------------------------------------------------} 994procedure TCanvas.Ellipse(const ARect: TRect); 995begin 996 Ellipse(ARect.Left,ARect.Top,ARect.Right,ARect.Bottom); 997end; 998 999{------------------------------------------------------------------------------ 1000 Method: TCanvas.FillRect 1001 Params: ARect 1002 Returns: Nothing 1003 1004 ------------------------------------------------------------------------------} 1005procedure TCanvas.FillRect(const ARect : TRect); 1006begin 1007 Changing; 1008 RequiredState([csHandleValid, csBrushValid]); 1009 LCLIntf.FillRect(FHandle, ARect, HBRUSH(Brush.Reference.Handle)); 1010 Changed; 1011end; 1012 1013{------------------------------------------------------------------------------ 1014 procedure TCanvas.FillRect(X1,Y1,X2,Y2 : Integer); 1015 ------------------------------------------------------------------------------} 1016procedure TCanvas.FillRect(X1,Y1,X2,Y2 : Integer); 1017begin 1018 FillRect(Rect(X1,Y1,X2,Y2)); 1019end; 1020 1021{------------------------------------------------------------------------------ 1022 Method: TCanvas.FillRect 1023 Params: X, Y: Integer; Color: TColor; FillStyle: TFillStyle 1024 Returns: Nothing 1025 1026 1027 ------------------------------------------------------------------------------} 1028procedure TCanvas.FloodFill(X, Y: Integer; FillColor: TColor; 1029 FillStyle: TFillStyle); 1030begin 1031 Changing; 1032 RequiredState([csHandleValid, csBrushValid]); 1033 LCLIntf.FloodFill(FHandle, X, Y, FillColor, FillStyle, HBRUSH(Brush.Reference.Handle)); 1034 Changed; 1035end; 1036 1037{------------------------------------------------------------------------------ 1038 Method: TCanvas.Frame3d 1039 Params: Rect 1040 Returns: the inflated rectangle (the inner rectangle without the frame) 1041 1042 ------------------------------------------------------------------------------} 1043procedure TCanvas.Frame3d(var ARect: TRect; const FrameWidth : integer; 1044 const Style : TGraphicsBevelCut); 1045begin 1046 Changing; 1047 RequiredState([csHandleValid,csBrushValid,csPenValid]); 1048 LCLIntf.Frame3d(FHandle, ARect, FrameWidth, Style); 1049 Changed; 1050end; 1051 1052{------------------------------------------------------------------------------ 1053 Method: TCanvas.Frame3D 1054 Params: Rect 1055 Returns: the inflated rectangle (the inner rectangle without the frame) 1056 1057 ------------------------------------------------------------------------------} 1058procedure TCanvas.Frame3D(var ARect: TRect; TopColor, BottomColor: TColor; 1059 const FrameWidth: integer); 1060var 1061 W, ii : Integer; 1062begin 1063 if ARect.Bottom-ARect.Top > ARect.Right-ARect.Left 1064 then 1065 W := ARect.Right-ARect.Left+1 1066 else 1067 W := ARect.Bottom-ARect.Top+1; 1068 1069 if FrameWidth > W then 1070 W := W-1 1071 else 1072 W := FrameWidth; 1073 1074 for ii := 1 to W do 1075 begin 1076 Pen.Color := TopColor; 1077 MoveTo(ARect.Left, ARect.Bottom-1); 1078 LineTo(ARect.Left, ARect.Top); 1079 LineTo(ARect.Right-1, ARect.Top); 1080 Pen.Color := BottomColor; 1081 LineTo(ARect.Right-1, ARect.Bottom-1); 1082 LineTo(ARect.Left, ARect.Bottom-1); 1083 1084 Inc(ARect.Left); 1085 Inc(ARect.Top); 1086 Dec(ARect.Right); 1087 Dec(ARect.Bottom); 1088 end; 1089end; 1090 1091{------------------------------------------------------------------------------ 1092 procedure TCanvas.Frame(const ARect: TRect); 1093 1094 Drawing the border of a rectangle with the current pen 1095 ------------------------------------------------------------------------------} 1096procedure TCanvas.Frame(const ARect: TRect); 1097var 1098 OldBrushStyle: TFPBrushStyle; 1099begin 1100 Changing; 1101 RequiredState([csHandleValid, csPenValid]); 1102 OldBrushStyle := Brush.Style; 1103 Brush.Style := bsClear; 1104 Rectangle(ARect); 1105 Brush.Style := OldBrushStyle; 1106 Changed; 1107end; 1108 1109{------------------------------------------------------------------------------ 1110 procedure TCanvas.Frame(const ARect: TRect); 1111 1112 Drawing the border of a rectangle with the current pen 1113 ------------------------------------------------------------------------------} 1114procedure TCanvas.Frame(X1, Y1, X2, Y2: Integer); 1115begin 1116 Frame(Rect(X1, Y1, X2, Y2)); 1117end; 1118 1119{------------------------------------------------------------------------------ 1120 procedure TCanvas.FrameRect(const ARect: TRect); 1121 1122 Drawing the border of a rectangle with the current brush 1123 ------------------------------------------------------------------------------} 1124procedure TCanvas.FrameRect(const ARect: TRect); 1125begin 1126 Changing; 1127 RequiredState([csHandleValid, csBrushValid]); 1128 LCLIntf.FrameRect(FHandle, ARect, Brush.GetHandle); 1129 Changed; 1130end; 1131 1132{------------------------------------------------------------------------------ 1133 procedure TCanvas.FrameRect(const ARect: TRect); 1134 1135 Drawing the border of a rectangle with the current brush 1136 ------------------------------------------------------------------------------} 1137procedure TCanvas.FrameRect(X1, Y1, X2, Y2: Integer); 1138begin 1139 FrameRect(Rect(X1, Y1, X2, Y2)); 1140end; 1141 1142function TCanvas.GetTextMetrics(out TM: TLCLTextMetric): boolean; 1143var 1144 TTM: TTextMetric; 1145begin 1146 RequiredState([csHandleValid, csFontValid]); // csFontValid added in patch from bug 17555 1147 Fillchar(TM, SizeOf(TM), 0); 1148 Result := LCLIntf.GetTextMetrics(FHandle, TTM); 1149 if Result then begin 1150 TM.Ascender := TTM.tmAscent; 1151 TM.Descender := TTM.tmDescent; 1152 TM.Height := TTM.tmHeight; 1153 end; 1154end; 1155 1156{------------------------------------------------------------------------------ 1157 Method: TCanvas.Rectangle 1158 Params: X1,Y1,X2,Y2 1159 Returns: Nothing 1160 1161 ------------------------------------------------------------------------------} 1162procedure TCanvas.Rectangle(X1,Y1,X2,Y2 : Integer); 1163begin 1164 Changing; 1165 RequiredState([csHandleValid, csBrushValid, csPenValid]); 1166 LCLIntf.Rectangle(FHandle, X1, Y1, X2, Y2); 1167 Changed; 1168end; 1169 1170{------------------------------------------------------------------------------ 1171 Method: TCanvas.Rectangle 1172 Params: Rect 1173 Returns: Nothing 1174 1175 ------------------------------------------------------------------------------} 1176procedure TCanvas.Rectangle(const ARect: TRect); 1177begin 1178 Rectangle(ARect.Left, ARect.Top, ARect.Right, ARect.Bottom); 1179end; 1180 1181{------------------------------------------------------------------------------ 1182 Method: TCanvas.RoundRect 1183 Params: X1, Y1, X2, Y2, RX, RY 1184 Returns: Nothing 1185 1186 ------------------------------------------------------------------------------} 1187procedure TCanvas.RoundRect(X1, Y1, X2, Y2: Integer; RX,RY : Integer); 1188begin 1189 Changing; 1190 RequiredState([csHandleValid, csBrushValid, csPenValid]); 1191 LCLIntf.RoundRect(FHandle, X1, Y1, X2, Y2, RX, RY); 1192 Changed; 1193end; 1194 1195{------------------------------------------------------------------------------ 1196 Method: TCanvas.RoundRect 1197 Params: Rect, RX, RY 1198 Returns: Nothing 1199 1200 ------------------------------------------------------------------------------} 1201procedure TCanvas.RoundRect(const Rect : TRect; RX,RY : Integer); 1202begin 1203 RoundRect(Rect.Left, Rect.Top, Rect.Right, Rect.Bottom, RX, RY); 1204end; 1205 1206{------------------------------------------------------------------------------ 1207 Method: TCanvas.TextRect 1208 Params: ARect, X, Y, Text 1209 Returns: Nothing 1210 1211 ------------------------------------------------------------------------------} 1212procedure TCanvas.TextRect(const ARect: TRect; X, Y: integer; const Text: string 1213 ); 1214begin 1215 TextRect(ARect,X,Y,Text,TextStyle); 1216end; 1217 1218{------------------------------------------------------------------------------ 1219 Method: TCanvas.TextRect 1220 Params: ARect, X, Y, Text, Style 1221 Returns: Nothing 1222 1223 ------------------------------------------------------------------------------} 1224procedure TCanvas.TextRect(ARect: TRect; X, Y: integer; const Text: string; 1225 const Style: TTextStyle); 1226var 1227 Options : Longint; 1228 fRect : TRect; 1229 DCIndex: Integer; 1230 DC: HDC; 1231 ReqState: TCanvasState; 1232 1233 procedure SaveState; 1234 begin 1235 if DCIndex<>0 then exit; 1236 DCIndex:=SaveDC(DC); 1237 end; 1238 1239 procedure RestoreState; 1240 begin 1241 if DCIndex=0 then exit; 1242 RestoreDC(DC,DCIndex); 1243 end; 1244 1245begin 1246 //debugln(['TCanvas.TextRect ',DbgSName(Self),' Text="',Text,'" ',dbgs(ARect),' X=',X,',Y=',Y]); 1247 1248 if Font.Name = '' then // Empty name is allowed in Delphi. 1249 Font.Name := 'default'; 1250 1251 Changing; 1252 1253 Options := 0; 1254 case Style.Alignment of 1255 taRightJustify : Options := DT_RIGHT; 1256 taCenter : Options := DT_CENTER; 1257 end; 1258 case Style.Layout of 1259 tlCenter : Options := Options or DT_VCENTER; 1260 tlBottom : Options := Options or DT_BOTTOM; 1261 end; 1262 if Style.EndEllipsis then 1263 Options := Options or DT_END_ELLIPSIS; 1264 if Style.WordBreak then begin 1265 Options := Options or DT_WORDBREAK; 1266 if Style.EndEllipsis then 1267 Options := Options and not DT_END_ELLIPSIS; 1268 end; 1269 1270 if Style.SingleLine then 1271 Options := Options or DT_SINGLELINE; 1272 1273 if not Style.Clipping then 1274 Options := Options or DT_NOCLIP; 1275 1276 if Style.ExpandTabs then 1277 Options := Options or DT_EXPANDTABS; 1278 1279 if not Style.ShowPrefix then 1280 Options := Options or DT_NOPREFIX; 1281 1282 if Style.RightToLeft then 1283 Options := Options or DT_RTLREADING; 1284 1285 ReqState:=[csHandleValid]; 1286 if not Style.SystemFont then 1287 Include(ReqState,csFontValid); 1288 if Style.Opaque then 1289 Include(ReqState,csBrushValid); 1290 DC:=GetUpdatedHandle(ReqState); 1291 1292 DCIndex:=0; 1293 if Style.SystemFont or Style.Clipping or (not Style.Opaque) then 1294 SaveState; 1295 1296 if Style.SystemFont then 1297 SelectObject(DC, OnGetSystemFont()); 1298 1299 // calculate text rectangle 1300 fRect := ARect; 1301 if Style.Alignment = taLeftJustify then 1302 fRect.Left := X; 1303 if Style.Layout = tlTop then 1304 fRect.Top := Y; 1305 1306 if (Style.Alignment in [taRightJustify,taCenter]) or 1307 (Style.Layout in [tlCenter,tlBottom]) then 1308 begin 1309 DrawText(DC, pChar(Text), Length(Text), fRect, DT_CALCRECT or Options); 1310 case Style.Alignment of 1311 taRightJustify : OffsetRect(fRect, ARect.Right - fRect.Right, 0); 1312 taCenter : OffsetRect(fRect, (ARect.Right - fRect.Right) div 2, 0); 1313 end; 1314 case Style.Layout of 1315 tlCenter : OffsetRect(fRect, 0, 1316 ((ARect.Bottom - ARect.Top) - (fRect.Bottom - fRect.Top)) div 2); 1317 tlBottom : OffsetRect(fRect, 0, ARect.Bottom - fRect.Bottom); 1318 end; 1319 end; 1320 1321 if Style.Clipping then 1322 begin 1323 with ARect do 1324 InterSectClipRect(DC, Left, Top, Right, Bottom); 1325 Options := Options or DT_NOCLIP; // no clipping as we are handling it here 1326 end; 1327 1328 if Style.Opaque then 1329 FillRect(fRect) 1330 else 1331 SetBkMode(DC, TRANSPARENT); 1332 1333 if Style.SystemFont then 1334 SetTextColor(DC, TColorRef(Font.GetColor)); 1335 1336 //debugln('TCanvas.TextRect DRAW Text="',Text,'" ',dbgs(fRect)); 1337 DrawText(DC, pChar(Text), Length(Text), fRect, Options); 1338 1339 if Style.Opaque and (csBrushValid in FState) then 1340 begin 1341 if Brush.Style=bsSolid then // restore BKMode 1342 SetBkMode(DC, OPAQUE) 1343 end; 1344 1345 RestoreState; 1346 1347 Changed; 1348end; 1349 1350 1351{------------------------------------------------------------------------------ 1352 Method: TCanvas.TextOut 1353 Params: X,Y,Text 1354 Returns: Nothing 1355 1356 ------------------------------------------------------------------------------} 1357procedure TCanvas.TextOut(X,Y: Integer; const Text: String); 1358var 1359 Flags : Cardinal; 1360begin 1361 Changing; 1362 RequiredState([csHandleValid, csFontValid, csBrushValid]); 1363 Flags := 0; 1364 if TextStyle.Opaque then 1365 Flags := ETO_Opaque; 1366 if TextStyle.RightToLeft then 1367 Flags := Flags or ETO_RTLREADING; 1368 ExtUTF8Out(FHandle, X, Y, Flags, nil, PChar(Text), Length(Text), nil); 1369 MoveTo(X + TextWidth(Text), Y); 1370 Changed; 1371end; 1372 1373{------------------------------------------------------------------------------ 1374 function TCanvas.HandleAllocated: boolean; 1375 ------------------------------------------------------------------------------} 1376function TCanvas.HandleAllocated: boolean; 1377begin 1378 Result:=(FHandle<>0); 1379end; 1380 1381{------------------------------------------------------------------------------ 1382 function TCanvas.GetUpdatedHandle(ReqState: TCanvasState): HDC; 1383 ------------------------------------------------------------------------------} 1384function TCanvas.GetUpdatedHandle(ReqState: TCanvasState): HDC; 1385begin 1386 RequiredState(ReqState+[csHandleValid]); 1387 Result:=FHandle; 1388end; 1389 1390{------------------------------------------------------------------------------ 1391 Method: TCanvas.BrushChanged 1392 Params: ABrush: The changed brush 1393 Returns: Nothing 1394 1395 Notify proc for a brush change 1396 ------------------------------------------------------------------------------} 1397procedure TCanvas.BrushChanged(ABrush: TObject); 1398begin 1399 if csBrushValid in FState then 1400 Exclude(FState, csBrushValid); 1401end; 1402 1403{------------------------------------------------------------------------------ 1404 Method: TCanvas.FontChanged 1405 Params: AFont: the changed font 1406 Returns: Nothing 1407 1408 Notify proc for a font change 1409 ------------------------------------------------------------------------------} 1410procedure TCanvas.FontChanged(AFont: TObject); 1411begin 1412 if csFontValid in FState then 1413 Exclude(FState, csFontValid); 1414end; 1415 1416{------------------------------------------------------------------------------ 1417 Method: TCanvas.PenChanging 1418 Params: APen: The changing pen 1419 Returns: Nothing 1420 1421 Notify proc for a pen change 1422 ------------------------------------------------------------------------------} 1423procedure TCanvas.PenChanging(APen: TObject); 1424begin 1425 if [csPenValid, csHandleValid] * FState = [csPenValid, csHandleValid] then 1426 begin 1427 Exclude(FState, csPenValid); 1428 SelectObject(FHandle, FSavedPenHandle); 1429 FSavedPenHandle := 0; 1430 end; 1431end; 1432 1433procedure TCanvas.FontChanging(AFont: TObject); 1434begin 1435 if [csFontValid, csHandleValid] * FState = [csFontValid, csHandleValid] then 1436 begin 1437 Exclude(FState, csFontValid); 1438 SelectObject(FHandle, FSavedFontHandle); 1439 FSavedFontHandle := 0; 1440 end; 1441end; 1442 1443procedure TCanvas.BrushChanging(ABrush: TObject); 1444begin 1445 if [csBrushValid, csHandleValid] * FState = [csBrushValid, csHandleValid] then 1446 begin 1447 Exclude(FState, csBrushValid); 1448 SelectObject(FHandle, FSavedBrushHandle); 1449 FSavedBrushHandle := 0; 1450 end; 1451end; 1452 1453procedure TCanvas.RegionChanging(ARegion: TObject); 1454begin 1455 if [csRegionValid, csHandleValid] * FState = [csRegionValid, csHandleValid] then 1456 begin 1457 Exclude(FState, csRegionValid); 1458 SelectObject(FHandle, FSavedRegionHandle); 1459 FSavedRegionHandle := 0; 1460 end; 1461end; 1462 1463{------------------------------------------------------------------------------ 1464 Method: TCanvas.PenChanged 1465 Params: APen: The changed pen 1466 Returns: Nothing 1467 1468 Notify proc for a pen change 1469 ------------------------------------------------------------------------------} 1470procedure TCanvas.PenChanged(APen: TObject); 1471begin 1472 if csPenValid in FState then 1473 Exclude(FState, csPenValid); 1474end; 1475 1476{------------------------------------------------------------------------------ 1477 Method: TCanvas.RegionChanged 1478 Params: ARegion: The changed Region 1479 Returns: Nothing 1480 1481 Notify proc for a region change 1482 ------------------------------------------------------------------------------} 1483procedure TCanvas.RegionChanged(ARegion: TObject); 1484begin 1485 if csRegionValid in FState then 1486 Exclude(FState, csRegionValid); 1487end; 1488 1489{------------------------------------------------------------------------------ 1490 Method: TCanvas.Create 1491 Params: none 1492 Returns: Nothing 1493 1494 Constructor for the class. 1495 ------------------------------------------------------------------------------} 1496constructor TCanvas.Create; 1497begin 1498 FHandle := 0; 1499 ManageResources := true; 1500 inherited Create; 1501 FLazFont := TFont(inherited Font); 1502 FLazPen := TPen(inherited Pen); 1503 FLazBrush := TBrush(inherited Brush); 1504 FLazFont.OnChanging := @FontChanging; 1505 FLazFont.OnChange := @FontChanged; 1506 FSavedFontHandle := 0; 1507 FLazPen.OnChanging := @PenChanging; 1508 FLazPen.OnChange := @PenChanged; 1509 FSavedPenHandle := 0; 1510 FLazBrush.OnChanging := @BrushChanging; 1511 FLazBrush.OnChange := @BrushChanged; 1512 FSavedBrushHandle := 0; 1513 FRegion := TRegion.Create; 1514 FRegion.OnChanging := @RegionChanging; 1515 FRegion.OnChange := @RegionChanged; 1516 FSavedRegionHandle := 0; 1517 FCopyMode := cmSrcCopy; 1518 FAntialiasingMode := amDontCare; 1519 // FLock will be initialized on demand, because most canvas don't use it 1520 with FTextStyle do 1521 begin 1522 Alignment := taLeftJustify; 1523 Layout := tlTop; 1524 WordBreak := True; 1525 SingleLine := True; 1526 Clipping := True; 1527 ShowPrefix := False; 1528 Opaque := False; 1529 end; 1530end; 1531 1532{------------------------------------------------------------------------------ 1533 Method: TCanvas.Chord 1534 Params: x1, y1, x2, y2, StartAngle16Deg, EndAngle16Deg 1535 Returns: Nothing 1536 1537 Use Chord to draw a filled Chord-shape on the canvas. The angles angle1 and 1538 angle2 are 1/16th of a degree. For example, a full circle equals 5760(16*360). 1539 Positive values of Angle and AngleLength mean counter-clockwise while negative 1540 values mean clockwise direction. Zero degrees is at the 3'o clock position. 1541 1542------------------------------------------------------------------------------} 1543procedure TCanvas.Chord(x1, y1, x2, y2, 1544 Angle16Deg, Angle16DegLength: Integer); 1545begin 1546 Changing; 1547 RequiredState([csHandleValid, csBrushValid, csPenValid]); 1548 LCLIntf.AngleChord(FHandle, x1, y1, x2, y2, Angle16Deg, Angle16DegLength); 1549 Changed; 1550end; 1551 1552{------------------------------------------------------------------------------ 1553 Method: TCanvas.Chord 1554 Params: x1, y1, x2, y2, sx, sy, ex, ey 1555 Returns: Nothing 1556 1557 Use Chord to draw a filled Chord-shape on the canvas. The values sx,sy, 1558 and ex,ey represent a starting and ending radial-points between which 1559 the Arc is draw. 1560 1561------------------------------------------------------------------------------} 1562procedure TCanvas.Chord(x1, y1, x2, y2, SX, SY, EX, EY: Integer); 1563begin 1564 Changing; 1565 RequiredState([csHandleValid, csBrushValid, csPenValid]); 1566 LCLIntf.RadialChord(FHandle, x1, y1, x2, y2, sx, sy, ex, ey); 1567 Changed; 1568end; 1569 1570{------------------------------------------------------------------------------ 1571 Method: TCanvas.Destroy 1572 Params: None 1573 Returns: Nothing 1574 1575 Destructor for the class. 1576 ------------------------------------------------------------------------------} 1577destructor TCanvas.Destroy; 1578begin 1579//DebugLn('[TCanvas.Destroy] ',ClassName,' Self=',DbgS(Self)); 1580 Handle := 0; 1581 {$IF FPC_FULLVERSION>=20602} 1582 FreeThenNil(FClipRegion); {issue #24980 looks like TFPCustomCanvas bug} 1583 {$ENDIF} 1584 FreeThenNil(FRegion); 1585 FreeThenNil(FSavedHandleStates); 1586 if FLock <> 0 then 1587 DeleteCriticalSection(FLock); 1588 inherited Destroy; 1589 // set resources to nil, so that dangling pointers are spotted early 1590 FLazFont:=nil; 1591 FLazPen:=nil; 1592 FLazBrush:=nil; 1593end; 1594 1595{------------------------------------------------------------------------------ 1596 Function: TCanvas.GetHandle 1597 Params: None 1598 Returns: A handle to the GUI object 1599 1600 Checks if a handle is allocated, otherwise create it 1601 ------------------------------------------------------------------------------} 1602function TCanvas.GetHandle : HDC; 1603begin 1604 //DebugLn('[TCanvas.GetHandle] ',ClassName); 1605 RequiredState(csAllValid); 1606 Result := FHandle; 1607end; 1608 1609procedure TCanvas.SetAntialiasingMode(const AValue: TAntialiasingMode); 1610begin 1611 if FAntialiasingMode <> AValue then 1612 begin 1613 FAntialiasingMode := AValue; 1614 RealizeAntialiasing; 1615 end; 1616end; 1617 1618{------------------------------------------------------------------------------ 1619 Method: TCanvas.SetHandle 1620 Params: NewHandle - the new device context 1621 Returns: nothing 1622 1623 Deselect sub handles and sets the Handle 1624 ------------------------------------------------------------------------------} 1625procedure TCanvas.SetHandle(NewHandle: HDC); 1626begin 1627 if FHandle = NewHandle then Exit; 1628 1629 //DebugLn('[TCanvas.SetHandle] Self=',DbgS(Self),' Old=',DbgS(FHandle,8),' New=',DbgS(NewHandle,8)); 1630 if FHandle <> 0 then 1631 begin 1632 DeselectHandles; 1633 Exclude(FState, csHandleValid); 1634 end; 1635 1636 FHandle := NewHandle; 1637 if FHandle <> 0 then 1638 begin 1639 RealizeAntialiasing; 1640 Include(FState, csHandleValid); 1641 end; 1642 //DebugLn('[TCanvas.SetHandle] END Self=',DbgS(Self),' Handle=',DbgS(FHandle,8)); 1643end; 1644 1645{------------------------------------------------------------------------------ 1646 Method: TCanvas.DeselectHandles 1647 Params: none 1648 Returns: nothing 1649 1650 Deselect all subhandles in the current device context 1651 ------------------------------------------------------------------------------} 1652procedure TCanvas.DeselectHandles; 1653begin 1654 //debugln('TCanvas.DeselectHandles ',ClassName,' Self=',DbgS(Self),' Handle=',DbgS(FHandle),' FSavedBrushHandle=',DbgS(Cardinal(FSavedBrushHandle))); 1655 if (FHandle <> 0) then 1656 begin 1657 // select default sub handles in the device context without deleting owns 1658 if FSavedBrushHandle <> 0 then 1659 SelectObject(FHandle, FSavedBrushHandle); 1660 if FSavedPenHandle <> 0 then 1661 SelectObject(FHandle, FSavedPenHandle); 1662 if FSavedFontHandle <> 0 then 1663 SelectObject(FHandle, FSavedFontHandle); 1664 FState := FState - [csPenValid, csBrushValid, csFontValid]; 1665 end; 1666 FSavedBrushHandle:=0; 1667 FSavedPenHandle:=0; 1668 FSavedFontHandle:=0; 1669end; 1670 1671{------------------------------------------------------------------------------ 1672 Method: TCanvas.CreateHandle 1673 Params: None 1674 Returns: Nothing 1675 1676 Creates the handle ( = object). 1677 ------------------------------------------------------------------------------} 1678procedure TCanvas.CreateHandle; 1679begin 1680 // Plain canvas does nothing 1681end; 1682 1683procedure TCanvas.FreeHandle; 1684begin 1685 Handle:=0; 1686end; 1687 1688{------------------------------------------------------------------------------ 1689 Method: TCanvas.RequiredState 1690 Params: ReqState: The required state 1691 Returns: Nothing 1692 1693 Ensures that all handles needed are valid; 1694 ------------------------------------------------------------------------------} 1695procedure TCanvas.RequiredState(ReqState: TCanvasState); 1696var 1697 Needed: TCanvasState; 1698begin 1699 Needed := ReqState - FState; 1700 //DebugLn('[TCanvas.RequiredState] ',ClassName,' ',csHandleValid in ReqState,' ',csHandleValid in FState,' Needed=',Needed<>[]); 1701 if Needed <> [] then 1702 begin 1703 //DebugLn('[TCanvas.RequiredState] B ',ClassName,' ',csHandleValid in Needed,',',csFontValid in Needed,',',csPenValid in Needed,',',csBrushValid in Needed); 1704 if csHandleValid in Needed then 1705 begin 1706 CreateHandle; 1707 if FHandle = 0 then 1708 raise EInvalidOperation.Create(rsCanvasDoesNotAllowDrawing); 1709 RealizeAntialiasing; 1710 Include(FState, csHandleValid); 1711 end; 1712 if csFontValid in Needed then 1713 begin 1714 CreateFont; 1715 Include(FState, csFontValid); 1716 end; 1717 if csPenValid in Needed then 1718 begin 1719 CreatePen; 1720 if Pen.Style in [psDash, psDot, psDashDot, psDashDotDot] then 1721 Include(Needed, csBrushValid); 1722 Include(FState, csPenValid); 1723 end; 1724 if csBrushValid in Needed then 1725 begin 1726 CreateBrush; 1727 Include(FState, csBrushValid); 1728 end; 1729 end; 1730end; 1731 1732procedure TCanvas.Changed; 1733begin 1734 if Assigned(FOnChange) then FOnChange(Self); 1735end; 1736 1737procedure TCanvas.SaveHandleState; 1738var 1739 DCIndex: LongInt; 1740begin 1741 if FSavedHandleStates = nil then 1742 FSavedHandleStates := TFPList.Create; 1743 DeselectHandles; 1744 RequiredState([csHandleValid]); 1745 DCIndex := SaveDC(Handle); 1746 FSavedHandleStates.Add(Pointer(PtrInt(DCIndex))); 1747end; 1748 1749procedure TCanvas.RestoreHandleState; 1750var 1751 DCIndex: LongInt; 1752begin 1753 DCIndex := LongInt(PtrUInt(FSavedHandleStates[FSavedHandleStates.Count-1])); 1754 FSavedHandleStates.Delete(FSavedHandleStates.Count-1); 1755 DeselectHandles; 1756 RestoreDC(Handle, DCIndex); 1757end; 1758 1759procedure TCanvas.Changing; 1760begin 1761 if Assigned(FOnChanging) then FOnChanging(Self); 1762end; 1763 1764{------------------------------------------------------------------------------ 1765 Function: TCanvas.TextExtent 1766 Params: Text: The text to measure 1767 Returns: The size 1768 1769 Gets the width and height of a text 1770 ------------------------------------------------------------------------------} 1771function TCanvas.TextExtent(const Text: string): TSize; 1772var 1773 DCIndex: Integer; 1774 ARect: TRect; 1775 1776 procedure SaveState; 1777 begin 1778 if DCIndex <> 0 then exit; 1779 DCIndex := SaveDC(FHandle); 1780 end; 1781 1782 procedure RestoreState; 1783 begin 1784 if DCIndex = 0 then exit; 1785 RestoreDC(FHandle, DCIndex); 1786 end; 1787 1788begin 1789 Result.cX := 0; 1790 Result.cY := 0; 1791 if Text='' then exit; 1792 RequiredState([csHandleValid, csFontValid]); 1793 1794 DCIndex := 0; 1795 if Font.IsDefault then 1796 begin 1797 SaveState; 1798 SelectObject(FHandle, OnGetSystemFont()); 1799 end; 1800 1801 ARect := Rect(0, 0, 0, 0); 1802 GetTextExtentPoint(FHandle, PChar(Text), Length(Text), Result); 1803 1804 RestoreState; 1805end; 1806 1807{------------------------------------------------------------------------------ 1808 Function: TCanvas.TextWidth 1809 Params: Text: The text to measure 1810 Returns: The width 1811 1812 Gets the width of a text 1813 ------------------------------------------------------------------------------} 1814function TCanvas.TextWidth(const Text: string): Integer; 1815begin 1816 Result := TextExtent(Text).cX; 1817end; 1818 1819{------------------------------------------------------------------------------ 1820 Function: TCanvas.TextFitInfo 1821 Params: Text: The text in consideration 1822 MaxWidth: The size, the major input 1823 Returns: The number of characters which will fit into MaxWidth 1824 1825 Returns how many characters will fit in a specified width 1826 ------------------------------------------------------------------------------} 1827function TCanvas.TextFitInfo(const Text: string; MaxWidth: Integer): Integer; 1828var 1829 lSize: TSize; 1830begin 1831 LCLIntf.GetTextExtentExPoint(Self.Handle, PChar(Text), Length(Text), 1832 MaxWidth, @Result, nil, lSize); 1833end; 1834 1835{------------------------------------------------------------------------------ 1836 Function: TCanvas.TextHeight 1837 Params: Text: The text to measure 1838 Returns: A handle to the GUI object 1839 1840 Gets the height of a text 1841 ------------------------------------------------------------------------------} 1842function TCanvas.TextHeight(const Text: string): Integer; 1843begin 1844 Result := TextExtent(Text).cY; 1845end; 1846 1847{------------------------------------------------------------------------------ 1848 Function: TCanvas.Lock 1849 Params: none 1850 Returns: nothing 1851 ------------------------------------------------------------------------------} 1852procedure TCanvas.Lock; 1853begin 1854 LockCanvas; 1855end; 1856 1857function TCanvas.TryLock: Boolean; 1858begin 1859 Result := not Locked; 1860 if Result then 1861 Lock; 1862end; 1863 1864{------------------------------------------------------------------------------ 1865 Function: TCanvas.Unlock 1866 Params: none 1867 Returns: nothing 1868 ------------------------------------------------------------------------------} 1869procedure TCanvas.Unlock; 1870begin 1871 UnlockCanvas; 1872end; 1873 1874{------------------------------------------------------------------------------ 1875 procedure TCanvas.Refresh; 1876 ------------------------------------------------------------------------------} 1877procedure TCanvas.Refresh; 1878begin 1879 DeselectHandles; 1880end; 1881