unit SpkGUITools; {$mode ObjFpc} {$H+} {$DEFINE SPKGUITOOLS} {.$define EnhancedRecordSupport} //the fpcbugworkaround is only necessary when using inline for DrawRoundRect {.$define FpcBugWorkAround} interface {$MESSAGE HINT 'Every rect in this module are exact rectanges (not like in WINAPI without right and bottom)'} uses LCLType, LCLVersion, Graphics, SysUtils, Classes, Controls, StdCtrls, SpkGraphTools, SpkMath; type TCornerPos = (cpLeftTop, cpRightTop, cpLeftBottom, cpRightBottom); TCornerKind = (cpRound, cpNormal); TBackgroundKind = (bkSolid, bkVerticalGradient, bkHorizontalGradient, bkConcave); TSpkButtonState = (bsIdle, bsBtnHottrack, bsBtnPressed, bsDropdownHottrack, bsDropdownPressed); TSpkCheckboxStyle = (cbsCheckbox, cbsRadioButton); // TSpkCheckboxState = (cbsIdle, cbsHotTrack, cbsPressed, cbsDisabled); TGUITools = class(TObject) protected class procedure FillGradientRectangle(ACanvas: TCanvas; Rect: T2DIntRect; ColorFrom, ColorTo: TColor; GradientKind: TBackgroundKind); class procedure SaveClipRgn(DC: HDC; out OrgRgnExists: boolean; out OrgRgn: HRGN); class procedure RestoreClipRgn(DC: HDC; OrgRgnExists: boolean; var OrgRgn: HRGN); public // *** Lines *** // Performance: // w/ClipRect: Bitmap is faster (2x) // wo/ClipRect: Canvas is faster (a little) class procedure DrawHLine(ABitmap : TBitmap; x1, x2 : integer; y : integer; Color : TColor); overload; class procedure DrawHLine(ABitmap : TBitmap; x1, x2 : integer; y : integer; Color : TColor; ClipRect : T2DIntRect); overload; class procedure DrawHLine(ACanvas : TCanvas; x1, x2 : integer; y : integer; Color : TColor); overload; class procedure DrawHLine(ACanvas : TCanvas; x1, x2 : integer; y : integer; Color : TColor; ClipRect : T2DIntRect); overload; // Performance: // w/ClipRect: Bitmap is faster (2x) // wo/ClipRect: Canvas is faster (a little) class procedure DrawVLine(ABitmap : TBitmap; x : integer; y1, y2 : integer; Color : TColor); overload; class procedure DrawVLine(ABitmap : TBitmap; x : integer; y1, y2 : integer; Color : TColor; ClipRect : T2DIntRect); overload; class procedure DrawVLine(ACanvas : TCanvas; x : integer; y1, y2 : integer; Color : TColor); overload; class procedure DrawVLine(ACanvas : TCanvas; x : integer; y1, y2 : integer; Color : TColor; ClipRect : T2DIntRect); overload; // *** Background and frame tools *** // Performance: // w/ClipRect: Bitmap is faster (extremely) // wo/ClipRect: Bitmap is faster (extremely) class procedure DrawAARoundCorner(ABitmap : TBitmap; Point : T2DIntVector; Radius : integer; CornerPos : TCornerPos; Color : TColor); overload; class procedure DrawAARoundCorner(ABitmap : TBitmap; Point : T2DIntVector; Radius : integer; CornerPos : TCornerPos; Color : TColor; ClipRect : T2DIntRect); overload; class procedure DrawAARoundCorner(ACanvas : TCanvas; Point : T2DIntVector; Radius : integer; CornerPos : TCornerPos; Color : TColor); overload; class procedure DrawAARoundCorner(ACanvas : TCanvas; Point : T2DIntVector; Radius : integer; CornerPos : TCornerPos; Color : TColor; ClipRect : T2DIntRect); overload; // Performance: // w/ClipRect: Bitmap is faster (extremely) // wo/ClipRect: Bitmap is faster (extremely) class procedure DrawAARoundFrame(ABitmap : TBitmap; Rect : T2DIntRect; Radius : integer; Color : TColor); overload; class procedure DrawAARoundFrame(ABitmap : TBitmap; Rect : T2DIntRect; Radius : integer; Color : TColor; ClipRect : T2DIntRect); overload; class procedure DrawAARoundFrame(ACanvas : TCanvas; Rect : T2DIntRect; Radius : integer; Color : TColor); overload; class procedure DrawAARoundFrame(ACanvas : TCanvas; Rect : T2DIntRect; Radius : integer; Color : TColor; ClipRect : T2DIntRect); overload; class procedure RenderBackground(ABuffer : TBitmap; Rect : T2DIntRect; Color1, Color2 : TColor; BackgroundKind : TBackgroundKind); class procedure CopyRoundCorner(ABuffer : TBitmap; ABitmap : TBitmap; SrcPoint : T2DIntVector; DstPoint : T2DIntVector; Radius : integer; CornerPos : TCornerPos; Convex : boolean = true); overload; class procedure CopyRoundCorner(ABuffer : TBitmap; ABitmap : TBitmap; SrcPoint : T2DIntVector; DstPoint : T2DIntVector; Radius : integer; CornerPos : TCornerPos; ClipRect : T2DIntRect; Convex : boolean = true); overload; class procedure CopyCorner(ABuffer : TBitmap; ABitmap: TBitmap; SrcPoint : T2DIntVector; DstPoint: T2DIntVector; Radius: integer); overload; inline; class procedure CopyCorner(ABuffer : TBitmap; ABitmap: TBitmap; SrcPoint : T2DIntVector; DstPoint: T2DIntVector; Radius: integer; ClipRect : T2DIntRect); overload; inline; class procedure CopyRectangle(ABuffer : TBitmap; ABitmap: TBitmap; SrcPoint : T2DIntVector; DstPoint: T2DIntVector; Width: integer; Height : integer); overload; class procedure CopyRectangle(ABuffer : TBitmap; ABitmap : TBitmap; SrcPoint : T2DIntVector; DstPoint : T2DIntVector; Width : integer; Height : integer; ClipRect : T2DIntRect); overload; class procedure CopyMaskRectangle(ABuffer : TBitmap; AMask : TBitmap; ABitmap : TBitmap; SrcPoint : T2DIntVector; DstPoint : T2DIntVector; Width : integer; Height : integer); overload; class procedure CopyMaskRectangle(ABuffer : TBitmap; AMask : TBitmap; ABitmap : TBitmap; SrcPoint : T2DIntVector; DstPoint : T2DIntVector; Width : integer; Height : integer; ClipRect : T2DIntRect); overload; // Performance (RenderBackground + CopyRoundRect vs DrawRoundRect): // w/ClipRect : Bitmap faster for smaller radiuses, Canvas faster for larger // wo/ClipRect : Bitmap faster for smaller radiuses, Canvas faster for larger class procedure CopyRoundRect(ABuffer : TBitmap; ABitmap : TBitmap; SrcPoint : T2DIntVector; DstPoint : T2DIntVector; Width, Height : integer; Radius : integer; LeftTopRound : boolean = true; RightTopRound : boolean = true; LeftBottomRound : boolean = true; RightBottomRound : boolean = true); overload; class procedure CopyRoundRect(ABuffer : TBitmap; ABitmap : TBitmap; SrcPoint : T2DIntVector; DstPoint : T2DIntVector; Width, Height : integer; Radius : integer; ClipRect : T2DIntRect; LeftTopRound : boolean = true; RightTopRound : boolean = true; LeftBottomRound : boolean = true; RightBottomRound : boolean = true); overload; class procedure DrawRoundRect(ACanvas : TCanvas; Rect : T2DIntRect; Radius : integer; ColorFrom : TColor; ColorTo : TColor; GradientKind : TBackgroundKind; LeftTopRound : boolean = true; RightTopRound : boolean = true; LeftBottomRound : boolean = true; RightBottomRound : boolean = true); overload; class procedure DrawRoundRect(ACanvas : TCanvas; Rect : T2DIntRect; Radius : integer; ColorFrom : TColor; ColorTo : TColor; GradientKind : TBackgroundKind; ClipRect : T2DIntRect; LeftTopRound : boolean = true; RightTopRound : boolean = true; LeftBottomRound : boolean = true; RightBottomRound : boolean = true); overload; class procedure DrawRegion(ACanvas : TCanvas; Region : HRGN; Rect : T2DIntRect; ColorFrom : TColor; ColorTo : TColor; GradientKind : TBackgroundKind); overload; class procedure DrawRegion(ACanvas : TCanvas; Region : HRGN; Rect : T2DIntRect; ColorFrom : TColor; ColorTo : TColor; GradientKind : TBackgroundKind; ClipRect : T2DIntRect); overload; // Imagelist tools class procedure DrawImage(ABitmap : TBitmap; Imagelist : TImageList; ImageIndex : integer; Point : T2DIntVector); overload; inline; class procedure DrawImage(ABitmap : TBitmap; Imagelist : TImageList; ImageIndex : integer; Point : T2DIntVector; ClipRect : T2DIntRect); overload; inline; class procedure DrawImage(ACanvas : TCanvas; Imagelist : TImageList; ImageIndex : integer; Point : T2DIntVector); overload; inline; class procedure DrawImage(ACanvas : TCanvas; Imagelist : TImageList; ImageIndex : integer; Point : T2DIntVector; ClipRect : T2DIntRect); overload; class procedure DrawImage(ACanvas: TCanvas; Imagelist: TImageList; ImageIndex: integer; Point : T2DIntVector; ClipRect: T2DIntRect; AImageWidthAt96PPI, ATargetPPI: Integer; ACanvasFactor: Double); overload; class procedure DrawDisabledImage(ABitmap : TBitmap; Imagelist : TImageList; ImageIndex : integer; Point : T2DIntVector); overload; inline; class procedure DrawDisabledImage(ABitmap : TBitmap; Imagelist : TImageList; ImageIndex : integer; Point : T2DIntVector; ClipRect : T2DIntRect); overload; inline; class procedure DrawDisabledImage(ACanvas : TCanvas; Imagelist : TImageList; ImageIndex : integer; Point : T2DIntVector); overload; class procedure DrawDisabledImage(ACanvas : TCanvas; Imagelist : TImageList; ImageIndex : integer; Point : T2DIntVector; ClipRect : T2DIntRect); overload; inline; // Checkbox class procedure DrawCheckbox(ACanvas: TCanvas; x,y: Integer; AState: TCheckboxState; AButtonState: TSpkButtonState; AStyle: TSpkCheckboxStyle); overload; class procedure DrawCheckbox(ACanvas: TCanvas; x,y: Integer; AState: TCheckboxState; AButtonState: TSpkButtonState; AStyle: TSpkCheckboxStyle; ClipRect: T2DIntRect); overload; // Text tools class procedure DrawText(ABitmap : TBitmap; x, y : integer; const AText : string; TextColor: TColor); overload; class procedure DrawText(ABitmap : TBitmap; x, y : integer; const AText : string; TextColor : TColor; ClipRect: T2DIntRect); overload; class procedure DrawMarkedText(ACanvas : TCanvas; x, y : integer; const AText, AMarkPhrase : string; TextColor : TColor; CaseSensitive : boolean = false); overload; class procedure DrawMarkedText(ACanvas : TCanvas; x, y : integer; const AText, AMarkPhrase : string; TextColor : TColor; ClipRect : T2DIntRect; CaseSensitive : boolean = false); overload; class procedure DrawText(ACanvas : TCanvas; x, y : integer; const AText : string; TextColor : TColor); overload; class procedure DrawText(ACanvas : TCanvas; x, y : integer; const AText : string; TextColor : TColor; ClipRect : T2DIntRect); overload; class procedure DrawFitWText(ABitmap : TBitmap; x1, x2 : integer; y : integer; const AText : string; TextColor : TColor; Align : TAlignment); overload; class procedure DrawFitWText(ACanvas : TCanvas; x1, x2 : integer; y : integer; const AText : string; TextColor : TColor; Align : TAlignment); overload; class procedure DrawOutlinedText(ABitmap : TBitmap; x, y : integer; const AText : string; TextColor : TColor; OutlineColor : TColor); overload; class procedure DrawOutlinedText(ABitmap : TBitmap; x, y : integer; const AText : string; TextColor : TColor; OutlineColor : TColor; ClipRect : T2DIntRect); overload; class procedure DrawOutlinedText(ACanvas : TCanvas; x, y : integer; const AText : string; TextColor : TColor; OutlineColor : TColor); overload; class procedure DrawOutlinedText(ACanvas : TCanvas; x, y : integer; const AText : string; TextColor : TColor; OutlineColor : TColor; ClipRect : T2DIntRect); overload; class procedure DrawFitWOutlinedText(ABitmap: TBitmap; x1, x2 : integer; y: integer; const AText: string; TextColor, OutlineColor: TColor; Align: TAlignment); overload; class procedure DrawFitWOutlinedText(ACanvas: TCanvas; x1, x2 : integer; y: integer; const AText: string; TextColor, OutlineColor: TColor; Align: TAlignment); overload; end; implementation uses Types, LCLIntf, IntfGraphics, Themes; { TSpkGUITools } class procedure TGUITools.CopyRoundCorner(ABuffer, ABitmap: TBitmap; SrcPoint, DstPoint: T2DIntVector; Radius: integer; CornerPos: TCornerPos; ClipRect: T2DIntRect; Convex: boolean); var BufferRect, BitmapRect, TempRect: T2DIntRect; OrgSrcRect, UnClippedDstRect, OrgDstRect: T2DIntRect; SrcRect: T2DIntRect; Offset: T2DIntVector; Center: T2DIntVector; y: Integer; SrcLine: Pointer; DstLine: Pointer; SrcPtr, DstPtr : PByte; x: Integer; Dist : double; SrcImg, DestImg: TLazIntfImage; begin if (ABuffer.PixelFormat <> pf24Bit) or (ABitmap.PixelFormat <> pf24Bit) then raise Exception.Create('TSpkGUITools.CopyRoundCorner: Only 24-bit bitmaps are accepted!'); // Validation if Radius < 1 then exit; if (ABuffer.Width = 0) or (ABuffer.Height = 0) or (ABitmap.Width = 0) or (ABitmap.Height = 0) then exit; //todo minimize use of temps here {$ifdef EnhancedRecordSupport} BufferRect := T2DIntRect.Create(0, 0, ABuffer.width-1, ABuffer.height-1); if not BufferRect.IntersectsWith( T2DIntRect.Create(SrcPoint.x, SrcPoint.y, SrcPoint.x+Radius-1, SrcPoint.y+Radius-1), OrgSrcRect ) then exit; {$else} BufferRect.Create(0, 0, ABuffer.Width-1, ABuffer.Height-1); TempRect.Create(SrcPoint.x, SrcPoint.y, SrcPoint.x+Radius-1, SrcPoint.y+Radius-1); if not BufferRect.IntersectsWith(TempRect, OrgSrcRect) then exit; {$endif} {$ifdef EnhancedRecordSupport} BitmapRect := T2DIntRect.Create(0, 0, ABitmap.Width-1, ABitmap.Height-1); if not BitmapRect.IntersectsWith( T2DIntRect.Create(DstPoint.x, DstPoint.y, DstPoint.x+Radius-1, DstPoint.y+Radius-1), UnClippedDstRect ) then exit; {$else} BitmapRect.Create(0, 0, ABitmap.Width-1, ABitmap.Height-1); //todo: calling create twice TempRect.Create(DstPoint.x, DstPoint.y, DstPoint.x+Radius-1, DstPoint.y+Radius-1); if not(BitmapRect.IntersectsWith(TempRect, UnClippedDstRect)) then exit; {$endif} if not(ClipRect.IntersectsWith(UnClippedDstRect, OrgDstRect)) then exit; Offset := DstPoint - SrcPoint; if not(OrgSrcRect.IntersectsWith(OrgDstRect - Offset, SrcRect)) then exit; // We position the center of the arc {$ifdef EnhancedRecordSupport} case CornerPos of cpLeftTop: Center := T2DIntVector.Create(SrcPoint.x + Radius - 1, SrcPoint.y + Radius - 1); cpRightTop: Center := T2DIntVector.Create(SrcPoint.x, SrcPoint.y + Radius - 1); cpLeftBottom: Center := T2DIntVector.Create(SrcPoint.x + Radius - 1, SrcPoint.y); cpRightBottom: Center := T2DIntVector.Create(SrcPoint.x, SrcPoint.y); end; {$else} case CornerPos of cpLeftTop: Center.Create(SrcPoint.x + Radius - 1, SrcPoint.y + Radius - 1); cpRightTop: Center.Create(SrcPoint.x, SrcPoint.y + Radius - 1); cpLeftBottom: Center.Create(SrcPoint.x + Radius - 1, SrcPoint.y); cpRightBottom: Center.Create(SrcPoint.x, SrcPoint.y); end; {$endif} // Is there anything to be processed? if Convex then begin //todo: remove the check since is not necessary if (SrcRect.Left <= SrcRect.right) and (SrcRect.Top <= SrcRect.Bottom) then begin SrcImg := ABuffer.CreateIntfImage; DestImg := ABitmap.CreateIntfImage; for y := SrcRect.Top to SrcRect.Bottom do begin SrcLine := SrcImg.GetDataLineStart(y); DstLine := DestImg.GetDataLineStart(y+Offset.y); SrcPtr := {%H-}pointer({%H-}PtrInt(SrcLine) + SrcRect.Left*3); DstPtr := {%H-}pointer({%H-}PtrInt(DstLine) + 3*(SrcRect.Left + Offset.x)); for x := SrcRect.Left to SrcRect.Right do begin {$ifdef EnhancedRecordSupport} Dist := Center.DistanceTo(T2DIntVector.Create(x, y)); {$else} Dist := Center.DistanceTo(x, y); {$endif} if Dist <= (Radius-1) then Move(SrcPtr^, DstPtr^, 3); inc(SrcPtr, 3); inc(DstPtr, 3); end; end; ABitmap.LoadFromIntfImage(DestImg); SrcImg.Destroy; DestImg.Destroy; end; end else begin if (SrcRect.Left <= SrcRect.Right) and (SrcRect.Top <= SrcRect.Bottom) then begin SrcImg := ABuffer.CreateIntfImage; DestImg := ABitmap.CreateIntfImage; for y := SrcRect.Top to SrcRect.Bottom do begin SrcLine := SrcImg.GetDataLineStart(y); DstLine := DestImg.GetDataLineStart(y+Offset.y); SrcPtr := {%H-}pointer({%H-}PtrInt(SrcLine) + 3*SrcRect.Left); DstPtr := {%H-}pointer({%H-}PtrInt(DstLine) + 3*(SrcRect.Left + Offset.x)); for x := SrcRect.Left to SrcRect.Right do begin {$ifdef EnhancedRecordSupport} Dist := Center.DistanceTo(T2DIntVector.Create(x, y)); {$else} Dist := Center.DistanceTo(x, y); {$endif} if Dist >= (Radius-1) then Move(SrcPtr^, DstPtr^, 3); inc(SrcPtr,3); inc(DstPtr,3); end; end; ABitmap.LoadFromIntfImage(DestImg); SrcImg.Destroy; DestImg.Destroy; end; end; end; class procedure TGUITools.CopyRoundRect(ABuffer, ABitmap: TBitmap; SrcPoint, DstPoint: T2DIntVector; Width, Height, Radius: integer; ClipRect: T2DIntRect; LeftTopRound, RightTopRound, LeftBottomRound, RightBottomRound: boolean); begin if (ABuffer.PixelFormat <> pf24Bit) or (ABitmap.PixelFormat <> pf24Bit) then raise Exception.Create('TSpkGUITools.CopyBackground: Only 24 bit bitmaps are accepted!'); if Radius < 0 then exit; if (Radius > Width div 2) or (Radius > Height div 2) then exit; if (ABuffer.Width = 0) or (ABuffer.Height = 0) or (ABitmap.Width = 0) or (ABitmap.Height = 0) then exit; {$REGION 'We fill the rectangles'} // Mountain /???? // Góra CopyRectangle(ABuffer, ABitmap, {$ifdef EnhancedRecordSupport} T2DIntPoint.Create(SrcPoint.x + Radius, SrcPoint.y), T2DIntPoint.Create(DstPoint.x + Radius, DstPoint.y), {$else} Create2DIntPoint(SrcPoint.x + Radius, SrcPoint.y), Create2DIntPoint(DstPoint.x + Radius, DstPoint.y), {$endif} Width - 2*Radius, Radius, ClipRect); // Down // Dó³ CopyRectangle(ABuffer, ABitmap, {$IFDEF EnhancedRecordSupport} T2DIntPoint.Create(SrcPoint.x + Radius, SrcPoint.y + Height - Radius), T2DIntPoint.Create(DstPoint.x + Radius, DstPoint.y + Height - Radius), {$ELSE} Create2DIntPoint(SrcPoint.x + Radius, SrcPoint.y + Height - Radius), Create2DIntPoint(DstPoint.x + Radius, DstPoint.y + Height - Radius), {$ENDIF} Width - 2*Radius, Radius, ClipRect); // Agent (???) // Œrodek CopyRectangle(ABuffer, ABitmap, {$IFDEF EnhancedRecordSupport} T2DIntPoint.Create(SrcPoint.x, SrcPoint.y + Radius), T2DIntPoint.Create(DstPoint.x, DstPoint.y + Radius), {$ELSE} Create2DIntPoint(SrcPoint.x, SrcPoint.y + Radius), Create2DIntPoint(DstPoint.x, DstPoint.y + Radius), {$ENDIF} Width, Height - 2*Radius, ClipRect); {$ENDREGION} // We fill the corners {$REGION 'Left upper'} if LeftTopRound then TGUITools.CopyRoundCorner(ABuffer, ABitmap, {$IFDEF EnhancedRecordSupport} T2DIntPoint.Create(SrcPoint.x, SrcPoint.y), T2DIntPoint.Create(DstPoint.x, DstPoint.y), {$ELSE} Create2DIntPoint(SrcPoint.x, SrcPoint.y), Create2DIntPoint(DstPoint.x, DstPoint.y), {$ENDIF} Radius, cpLeftTop, ClipRect, true) else TGUITools.CopyCorner(ABuffer, ABitmap, {$IFDEF EnhancedRecordSupport} T2DIntPoint.Create(SrcPoint.x, SrcPoint.y), T2DIntPoint.Create(DstPoint.x, DstPoint.y), {$ELSE} Create2DIntPoint(SrcPoint.x, SrcPoint.y), Create2DIntPoint(DstPoint.x, DstPoint.y), {$ENDIF} Radius, ClipRect); {$ENDREGION} {$REGION 'Right upper'} if RightTopRound then TGUITools.CopyRoundCorner(ABuffer, ABitmap, {$IFDEF EnhancedRecordSupport} T2DIntPoint.Create(SrcPoint.x + Width - Radius, SrcPoint.y), T2DIntPoint.Create(DstPoint.x + Width - Radius, DstPoint.y), {$ELSE} Create2DIntPoint(SrcPoint.x + Width - Radius, SrcPoint.y), Create2DIntPoint(DstPoint.x + Width - Radius, DstPoint.y), {$ENDIF} Radius, cpRightTop, ClipRect, true) else TGUITools.CopyCorner(ABuffer, ABitmap, {$IFDEF EnhancedRecordSupport} T2DIntPoint.Create(SrcPoint.x + Width - Radius, SrcPoint.y), T2DIntPoint.Create(DstPoint.x + Width - Radius, DstPoint.y), {$ELSE} Create2DIntPoint(SrcPoint.x + Width - Radius, SrcPoint.y), Create2DIntPoint(DstPoint.x + Width - Radius, DstPoint.y), {$ENDIF} Radius, ClipRect); {$ENDREGION} {$REGION 'Left bottom'} if LeftBottomRound then TGUITools.CopyRoundCorner(ABuffer, ABitmap, {$IFDEF EnhancedRecordSupport} T2DIntPoint.Create(SrcPoint.x, SrcPoint.y + Height - Radius), T2DIntPoint.Create(DstPoint.x, DstPoint.y + Height - Radius), {$ELSE} Create2DIntPoint(SrcPoint.x, SrcPoint.y + Height - Radius), Create2DIntPoint(DstPoint.x, DstPoint.y + Height - Radius), {$ENDIF} Radius, cpLeftBottom, ClipRect, true) else TGUITools.CopyCorner(ABuffer, ABitmap, {$IFDEF EnhancedRecordSupport} T2DIntPoint.Create(SrcPoint.x, SrcPoint.y + Height - Radius), T2DIntPoint.Create(DstPoint.x, DstPoint.y + Height - Radius), {$ELSE} Create2DIntPoint(SrcPoint.x, SrcPoint.y + Height - Radius), Create2DIntPoint(DstPoint.x, DstPoint.y + Height - Radius), {$ENDIF} Radius, ClipRect); {$ENDREGION} {$REGION 'Right bottom'} if RightBottomRound then TGUITools.CopyRoundCorner(ABuffer, ABitmap, {$IFDEF EnhancedRecordSupport} T2DIntPoint.Create(SrcPoint.x + Width - Radius, SrcPoint.y + Height - Radius), T2DIntPoint.Create(DstPoint.x + Width - Radius, DstPoint.y + Height - Radius), {$ELSE} Create2DIntPoint(SrcPoint.x + Width - Radius, SrcPoint.y + Height - Radius), Create2DIntPoint(DstPoint.x + Width - Radius, DstPoint.y + Height - Radius), {$ENDIF} Radius, cpRightBottom, ClipRect, true) else TGUITools.CopyCorner(ABuffer, ABitmap, {$IFDEF EnhancedRecordSupport} T2DIntPoint.Create(SrcPoint.x + Width - Radius, SrcPoint.y + Height - Radius), T2DIntPoint.Create(DstPoint.x + Width - Radius, DstPoint.y + Height - Radius), {$ELSE} Create2DIntPoint(SrcPoint.x + Width - Radius, SrcPoint.y + Height - Radius), Create2DIntPoint(DstPoint.x + Width - Radius, DstPoint.y + Height - Radius), {$ENDIF} Radius, ClipRect); {$ENDREGION'} end; class procedure TGUITools.CopyRoundRect(ABuffer : TBitmap; ABitmap: TBitmap; SrcPoint, DstPoint: T2DIntVector; Width, Height, Radius: integer; LeftTopRound, RightTopRound, LeftBottomRound, RightBottomRound: boolean); begin if (ABuffer.PixelFormat <> pf24bit) or (ABitmap.PixelFormat <> pf24bit) then raise exception.create('TSpkGUITools.CopyBackground: Only 24 bit bitmaps are accepted!'); if Radius < 0 then exit; if (Radius > Width div 2) or (Radius > Height div 2) then exit; if (ABuffer.Width = 0) or (ABuffer.Height = 0) or (ABitmap.Width = 0) or (ABitmap.Height = 0) then exit; {$REGION 'We fill the rectangles'} // Góra CopyRectangle(ABuffer, ABitmap, {$IFDEF EnhancedRecordSupport} T2DIntPoint.Create(SrcPoint.x + Radius, SrcPoint.y), T2DIntPoint.Create(DstPoint.x + Radius, DstPoint.y), {$ELSE} Create2DIntPoint(SrcPoint.x + Radius, SrcPoint.y), Create2DIntPoint(DstPoint.x + Radius, DstPoint.y), {$ENDIF} Width - 2*Radius, Radius); // Dó³ CopyRectangle(ABuffer, ABitmap, {$IFDEF EnhancedRecordSupport} T2DIntPoint.Create(SrcPoint.x + Radius, SrcPoint.y + Height - radius), T2DIntPoint.Create(DstPoint.x + Radius, DstPoint.y + Height - radius), {$ELSE} Create2DIntPoint(SrcPoint.x + Radius, SrcPoint.y + Height - radius), Create2DIntPoint(DstPoint.x + Radius, DstPoint.y + Height - radius), {$ENDIF} Width - 2*Radius, Radius); // Œrodek CopyRectangle(ABuffer, ABitmap, {$IFDEF EnhancedRecordSupport} T2DIntPoint.Create(SrcPoint.x, SrcPoint.y + Radius), T2DIntPoint.Create(DstPoint.x, DstPoint.y + Radius), {$ELSE} Create2DIntPoint(SrcPoint.x, SrcPoint.y + Radius), Create2DIntPoint(DstPoint.x, DstPoint.y + Radius), {$ENDIF} Width, Height - 2*Radius); {$ENDREGION} // We fill the corners {$REGION 'Left upper'} if LeftTopRound then TGUITools.CopyRoundCorner(ABuffer, ABitmap, {$IFDEF EnhancedRecordSupport} T2DIntPoint.Create(SrcPoint.x, SrcPoint.y), T2DIntPoint.Create(DstPoint.x, DstPoint.y), {$ELSE} Create2DIntPoint(SrcPoint.x, SrcPoint.y), Create2DIntPoint(DstPoint.x, DstPoint.y), {$ENDIF} Radius, cpLeftTop, true) else TGUITools.CopyCorner(ABuffer, ABitmap, {$IFDEF EnhancedRecordSupport} T2DIntPoint.Create(SrcPoint.x, SrcPoint.y), T2DIntPoint.Create(DstPoint.x, DstPoint.y), {$ELSE} Create2DIntPoint(SrcPoint.x, SrcPoint.y), Create2DIntPoint(DstPoint.x, DstPoint.y), {$ENDIF} Radius); {$ENDREGION} {$REGION 'Right upper'} if RightTopRound then TGUITools.CopyRoundCorner(ABuffer, ABitmap, {$IFDEF EnhancedRecordSupport} T2DIntPoint.Create(SrcPoint.x + Width - Radius, SrcPoint.y), T2DIntPoint.Create(DstPoint.x + Width - Radius, DstPoint.y), {$ELSE} Create2DIntPoint(SrcPoint.x + Width - Radius, SrcPoint.y), Create2DIntPoint(DstPoint.x + Width - Radius, DstPoint.y), {$ENDIF} Radius, cpRightTop, true) else TGUITools.CopyCorner(ABuffer, ABitmap, {$IFDEF EnhancedRecordSupport} T2DIntPoint.Create(SrcPoint.x + Width - Radius, SrcPoint.y), T2DIntPoint.Create(DstPoint.x + Width - Radius, DstPoint.y), {$ELSE} Create2DIntPoint(SrcPoint.x + Width - Radius, SrcPoint.y), Create2DIntPoint(DstPoint.x + Width - Radius, DstPoint.y), {$ENDIF} Radius); {$ENDREGION} {$REGION 'Left bottom'} if LeftBottomRound then TGUITools.CopyRoundCorner(ABuffer, ABitmap, {$IFDEF EnhancedRecordSupport} T2DIntPoint.Create(SrcPoint.x, SrcPoint.y + Height - Radius), T2DIntPoint.Create(DstPoint.x, DstPoint.y + Height - Radius), {$ELSE} Create2DIntPoint(SrcPoint.x, SrcPoint.y + Height - Radius), Create2DIntPoint(DstPoint.x, DstPoint.y + Height - Radius), {$ENDIF} Radius, cpLeftBottom, true) else TGUITools.CopyCorner(ABuffer, ABitmap, {$IFDEF EnhancedRecordSupport} T2DIntPoint.Create(SrcPoint.x, SrcPoint.y + Height - Radius), T2DIntPoint.Create(DstPoint.x, DstPoint.y + Height - Radius), {$ELSE} Create2DIntPoint(SrcPoint.x, SrcPoint.y + Height - Radius), Create2DIntPoint(DstPoint.x, DstPoint.y + Height - Radius), {$ENDIF} Radius); {$ENDREGION} {$REGION 'Right bottom'} if RightBottomRound then TGUITools.CopyRoundCorner(ABuffer, ABitmap, {$IFDEF EnhancedRecordSupport} T2DIntPoint.Create(SrcPoint.x + Width - Radius, SrcPoint.y + Height - Radius), T2DIntPoint.Create(DstPoint.x + Width - Radius, DstPoint.y + Height - Radius), {$ELSE} Create2DIntPoint(SrcPoint.x + Width - Radius, SrcPoint.y + Height - Radius), Create2DIntPoint(DstPoint.x + Width - Radius, DstPoint.y + Height - Radius), {$ENDIF} Radius, cpRightBottom, true) else TGUITools.CopyCorner(ABuffer, ABitmap, {$IFDEF EnhancedRecordSupport} T2DIntPoint.Create(SrcPoint.x + Width - Radius, SrcPoint.y + Height - Radius), T2DIntPoint.Create(DstPoint.x + Width - Radius, DstPoint.y + Height - Radius), {$ELSE} Create2DIntPoint(SrcPoint.x + Width - Radius, SrcPoint.y + Height - Radius), Create2DIntPoint(DstPoint.x + Width - Radius, DstPoint.y + Height - Radius), {$ENDIF} Radius); {$ENDREGION} end; class procedure TGUITools.CopyRectangle(ABuffer, ABitmap: TBitmap; SrcPoint, DstPoint: T2DIntVector; Width, Height: integer); var BufferRect, BitmapRect: T2DIntRect; SrcRect, DstRect: T2DIntRect; ClippedSrcRect: T2DIntRect; Offset: T2DIntVector; y: Integer; SrcLine: Pointer; DstLine: Pointer; SrcImg: TLazIntfImage; DestImg: TLazIntfImage; begin if (ABuffer.PixelFormat <> pf24Bit) or (ABitmap.PixelFormat <> pf24Bit) then raise exception.create('TSpkGUITools.CopyRoundCorner: Only 24 bit bitmaps are accepted!'); // Validation if (Width < 1) or (Height < 1) then exit; if (ABuffer.Width = 0) or (ABuffer.Height = 0) or (ABitmap.Width = 0) or (ABitmap.Height = 0) then exit; {$IFDEF EnhancedRecordSupport} // Truncate the source rect to the source bitmap BufferRect := T2DIntRect.Create(0, 0, ABuffer.Width-1, ABuffer.Height-1); if not BufferRect.IntersectsWith( T2DIntRect.Create(SrcPoint.x, SrcPoint.y, SrcPoint.x+Width-1, SrcPoint.y+Height-1), SrcRect ) then exit; // We cut the target rect to the target bitmap BitmapRect := T2DIntRect.Create(0, 0, ABitmap.Width-1, ABitmap.Height-1); if not BitmapRect.IntersectsWith( T2DIntRect.Create(DstPoint.x, DstPoint.y, DstPoint.x+Width-1, DstPoint.y+Height-1), DstRect ) then exit; {$ELSE} // Truncate the source rect to the source bitmap BufferRect.Create(0, 0, ABuffer.Width-1, ABuffer.Height-1); if not BufferRect.IntersectsWith( Create2DIntRect(SrcPoint.x, SrcPoint.y, SrcPoint.x+Width-1, SrcPoint.y+Height-1), SrcRect ) then exit; // We cut the target rect to the target bitmap BitmapRect.Create(0, 0, ABitmap.Width-1, ABitmap.Height-1); if not BitmapRect.IntersectsWith( Create2DIntRect(DstPoint.x, DstPoint.y, DstPoint.x+Width-1, DstPoint.y+Height-1), DstRect ) then exit; {$ENDIF} // We are counting the source offset to the target recta Offset := DstPoint - SrcPoint; // Sprawdzamy, czy na³o¿one na siebie recty: Ÿród³owy i docelowy przesuniêty o // offset maj¹ jak¹œ czêœæ wspóln¹ // Google-translated: // Verify that the rectangular overhead: source and target shifted by offset have some common if not SrcRect.IntersectsWith(DstRect - Offset, ClippedSrcRect) then exit; // If there is anything to process, do the operation if (ClippedSrcRect.Left <= ClippedSrcRect.Right) and (ClippedSrcRect.Top <= ClippedSrcRect.Bottom) then begin SrcImg := ABuffer.CreateIntfImage; DestImg := ABitmap.CreateIntfImage; for y := ClippedSrcRect.Top to ClippedSrcRect.Bottom do begin SrcLine := SrcImg.GetDataLineStart(y); DstLine := DestImg.GetDataLineStart(y+Offset.y); Move({%H-}pointer({%H-}PtrInt(SrcLine) + 3*ClippedSrcRect.Left)^, {%H-}pointer({%H-}PtrInt(DstLine) + 3*(ClippedSrcRect.Left + Offset.x))^, 3*ClippedSrcRect.Width); end; ABitmap.LoadFromIntfImage(DestImg); SrcImg.Destroy; DestImg.Destroy; end; end; class procedure TGUITools.CopyCorner(ABuffer, ABitmap: TBitmap; SrcPoint, DstPoint: T2DIntVector; Radius: integer); begin CopyRectangle(ABuffer, ABitmap, SrcPoint, DstPoint, Radius, Radius); end; class procedure TGUITools.CopyCorner(ABuffer, ABitmap: TBitmap; SrcPoint, DstPoint: T2DIntVector; Radius: integer; ClipRect: T2DIntRect); begin CopyRectangle(ABuffer, ABitmap, SrcPoint, DstPoint, Radius, Radius, ClipRect); end; class procedure TGUITools.CopyMaskRectangle(ABuffer, AMask, ABitmap: TBitmap; SrcPoint, DstPoint: T2DIntVector; Width, Height: integer); var BufferRect, BitmapRect: T2DIntRect; SrcRect, DstRect: T2DIntRect; ClippedSrcRect: T2DIntRect; Offset: T2DIntVector; y: Integer; SrcLine: Pointer; MaskLine: Pointer; DstLine: Pointer; SrcImg: TLazIntfImage; MaskImg: TLazIntfImage; DestImg: TLazIntfImage; i: Integer; begin if (ABuffer.PixelFormat <> pf24Bit) or (ABitmap.PixelFormat <> pf24Bit) then raise Exception.Create('TSpkGUITools.CopyRoundCorner: Only 24 bit bitmaps are accepted!'); if (AMask.PixelFormat <> pf8bit) then raise Exception.Create('TSpkGUITools.CopyRoundCorner: Only 8-bit masks are accepted!'); // Validation if (Width < 1) or (Height < 1) then exit; if (ABuffer.Width = 0) or (ABuffer.Height = 0) or (ABitmap.Width = 0) or (ABitmap.Height = 0) then exit; if (ABuffer.Width <> AMask.Width) or (ABuffer.Height <> AMask.Height) then exit; {$IFDEF EnhancedRecordSupport} // Truncate the source rect to the source bitmap BufferRect := T2DIntRect.Create(0, 0, ABuffer.Width-1, ABuffer.Height-1); if not BufferRect.IntersectsWith( T2DIntRect.Create(SrcPoint.x, SrcPoint.y, SrcPoint.x+Width-1, SrcPoint.y+Height-1), SrcRect ) then exit; // We cut the target rect to the target bitmap BitmapRect := T2DIntRect.Create(0, 0, ABitmap.Width-1, ABitmap.Height-1); if not BitmapRect.IntersectsWith( T2DIntRect.Create(DstPoint.x, DstPoint.y, DstPoint.x+Width-1, DstPoint.y+Height-1), DstRect ) then exit; {$ELSE} // Truncate the source rect to the source bitmap BufferRect.Create(0, 0, ABuffer.Width-1, ABuffer.Height-1); if not BufferRect.IntersectsWith( Create2DIntRect(SrcPoint.x, SrcPoint.y, SrcPoint.x+Width-1, SrcPoint.y+Height-1), SrcRect ) then exit; // Trim the target rect to the target bitmap BitmapRect.Create(0, 0, ABitmap.Width-1, ABitmap.Height-1); if not BitmapRect.IntersectsWith( Create2DIntRect(DstPoint.x, DstPoint.y, DstPoint.x+Width-1, DstPoint.y+Height-1), DstRect ) then exit; {$ENDIF} // We are counting the source offset to the target recta Offset := DstPoint - SrcPoint; // Sprawdzamy, czy na³o¿one na siebie recty: Ÿród³owy i docelowy przesuniêty o // offset maj¹ jak¹œ czêœæ wspóln¹ // Google-translated: // We check that the rectangles that are superimposed on each other: // source and target shifted by offset have some common if not(SrcRect.IntersectsWith(DstRect - Offset, ClippedSrcRect)) then exit; // If there is anything to process, do the operation if (ClippedSrcRect.Left <= ClippedSrcRect.Right) and (ClippedSrcRect.Top <= ClippedSrcRect.Bottom) then begin SrcImg := ABuffer.CreateIntfImage; DestImg := ABitmap.CreateIntfImage; MaskImg := AMask.CreateIntfImage; for y := ClippedSrcRect.Top to ClippedSrcRect.Bottom do begin SrcLine := SrcImg.GetDataLineStart(y); SrcLine := {%H-}pointer({%H-}PtrInt(SrcLine) + 3 * ClippedSrcRect.left); MaskLine := MaskImg.GetDataLineStart(y); MaskLine := {%H-}pointer({%H-}PtrInt(MaskLine) + ClippedSrcRect.left); DstLine := DestImg.GetDataLineStart(y+Offset.y); DstLine := {%H-}pointer({%H-}PtrInt(DstLine) + 3 * (ClippedSrcRect.left + Offset.x)); for i := 0 to ClippedSrcRect.Width - 1 do begin if PByte(MaskLine)^ < 128 then Move(SrcLine^, DstLine^, 3); SrcLine := {%H-}pointer({%H-}PtrInt(SrcLine)+3); DstLine := {%H-}pointer({%H-}PtrInt(DstLine)+3); MaskLine := {%H-}pointer({%H-}PtrInt(MaskLine)+1); end; end; ABitmap.LoadFromIntfImage(DestImg); DestImg.Destroy; SrcImg.Destroy; MaskImg.Destroy; end; end; class procedure TGUITools.CopyMaskRectangle(ABuffer, AMask, ABitmap: TBitmap; SrcPoint, DstPoint: T2DIntVector; Width, Height: integer; ClipRect: T2DIntRect); var BufferRect, BitmapRect: T2DIntRect; SrcRect, DstRect: T2DIntRect; ClippedSrcRect, ClippedDstRect: T2DIntRect; Offset: T2DIntVector; y: Integer; SrcImg: TLazIntfImage; MaskImg: TLazIntfImage; DestImg: TLazIntfImage; SrcLine: Pointer; DstLine: Pointer; i: Integer; MaskLine: Pointer; begin if (ABuffer.PixelFormat <> pf24Bit) or (ABitmap.PixelFormat <> pf24Bit) then raise Exception.Create('TSpkGUITools.CopyMaskRectangle: Only 24 bit bitmaps are accepted!'); if AMask.PixelFormat<>pf8bit then raise Exception.Create('TSpkGUITools.CopyMaskRectangle: Only 8-bit masks are accepted!'); // Validation if (Width < 1) or (Height < 1) then exit; if (ABuffer.Width = 0) or (ABuffer.Height = 0) or (ABitmap.Width = 0) or (ABitmap.Height = 0) then exit; if (ABuffer.Width <> AMask.Width) or (ABuffer.Height <> AMask.Height) then raise Exception.Create('TSpkGUITools.CopyMaskRectangle: The mask has incorrect dimensions!'); {$IFDEF EnhancedRecordSupport} // Truncate the source rect to the source bitmap BufferRect := T2DIntRect.Create(0, 0, ABuffer.Width-1, ABuffer.Height-1); if not BufferRect.IntersectsWith( T2DIntRect.Create(SrcPoint.x, SrcPoint.y, SrcPoint.x+Width-1, SrcPoint.y+Height-1), SrcRect ) then exit; // Przycinamy docelowy rect do obszaru docelowej bitmapy BitmapRect:=T2DIntRect.create(0, 0, ABitmap.width-1, ABitmap.height-1); if not(BitmapRect.IntersectsWith(T2DIntRect.create(DstPoint.x, DstPoint.y, DstPoint.x+Width-1, DstPoint.y+Height-1), DstRect)) then exit; {$ELSE} // Przycinamy Ÿród³owy rect do obszaru Ÿród³owej bitmapy BufferRect.create(0, 0, ABuffer.width-1, ABuffer.height-1); if not(BufferRect.IntersectsWith(Create2DIntRect(SrcPoint.x, SrcPoint.y, SrcPoint.x+Width-1, SrcPoint.y+Height-1), SrcRect)) then exit; // Przycinamy docelowy rect do obszaru docelowej bitmapy BitmapRect.create(0, 0, ABitmap.width-1, ABitmap.height-1); if not(BitmapRect.IntersectsWith(Create2DIntRect(DstPoint.x, DstPoint.y, DstPoint.x+Width-1, DstPoint.y+Height-1), DstRect)) then exit; {$ENDIF} // Dodatkowo przycinamy docelowy rect if not(DstRect.IntersectsWith(ClipRect, ClippedDstRect)) then Exit; // Liczymy offset Ÿród³owego do docelowego recta Offset:=DstPoint - SrcPoint; // Sprawdzamy, czy na³o¿one na siebie recty: Ÿród³owy i docelowy przesuniêty o // offset maj¹ jak¹œ czêœæ wspóln¹ if not(SrcRect.IntersectsWith(ClippedDstRect - Offset, ClippedSrcRect)) then exit; // Jeœli jest cokolwiek do przetworzenia, wykonaj operacjê if (ClippedSrcRect.left<=ClippedSrcRect.right) and (ClippedSrcRect.top<=ClippedSrcRect.bottom) then begin SrcImg := ABuffer.CreateIntfImage; DestImg := ABitmap.CreateIntfImage; MaskImg := ABitmap.CreateIntfImage; for y := ClippedSrcRect.top to ClippedSrcRect.bottom do begin SrcLine:=SrcImg.GetDataLineStart(y); SrcLine:={%H-}pointer({%H-}PtrInt(SrcLine) + 3 * ClippedSrcRect.left); MaskLine:=MaskImg.GetDataLineStart(y); MaskLine:={%H-}pointer({%H-}PtrInt(MaskLine) + ClippedSrcRect.left); DstLine:=DestImg.GetDataLineStart(y+Offset.y); DstLine:={%H-}pointer({%H-}PtrInt(DstLine) + 3 * (ClippedSrcRect.left + Offset.x)); for i := 0 to ClippedSrcRect.width - 1 do begin if PByte(MaskLine)^<128 then Move(SrcLine^, DstLine^, 3); SrcLine:={%H-}pointer({%H-}PtrInt(SrcLine)+3); DstLine:={%H-}pointer({%H-}PtrInt(DstLine)+3); MaskLine:={%H-}pointer({%H-}PtrInt(MaskLine)+1); end; end; ABitmap.LoadFromIntfImage(DestImg); SrcImg.Destroy; DestImg.Destroy; MaskImg.Destroy; end; end; class procedure TGUITools.CopyRectangle(ABuffer, ABitmap: TBitmap; SrcPoint, DstPoint: T2DIntVector; Width, Height: integer; ClipRect: T2DIntRect); var BufferRect, BitmapRect : T2DIntRect; SrcRect, DstRect : T2DIntRect; ClippedSrcRect, ClippedDstRect : T2DIntRect; Offset : T2DIntVector; y: Integer; DestImg: TLazIntfImage; SrcImg: TLazIntfImage; SrcLine: Pointer; DstLine: Pointer; begin if (ABuffer.PixelFormat<>pf24bit) or (ABitmap.PixelFormat<>pf24bit) then raise exception.create('TSpkGUITools.CopyRoundCorner: Tylko 24-bitowe bitmapy s¹ akceptowane!'); // Sprawdzanie poprawnoœci if (Width<1) or (Height<1) then exit; if (ABuffer.width=0) or (ABuffer.height=0) or (ABitmap.width=0) or (ABitmap.height=0) then exit; {$IFDEF EnhancedRecordSupport} // Przycinamy Ÿród³owy rect do obszaru Ÿród³owej bitmapy BufferRect:=T2DIntRect.create(0, 0, ABuffer.width-1, ABuffer.height-1); if not(BufferRect.IntersectsWith(T2DIntRect.create(SrcPoint.x, SrcPoint.y, SrcPoint.x+Width-1, SrcPoint.y+Height-1), SrcRect)) then exit; // Przycinamy docelowy rect do obszaru docelowej bitmapy BitmapRect:=T2DIntRect.create(0, 0, ABitmap.width-1, ABitmap.height-1); if not(BitmapRect.IntersectsWith(T2DIntRect.create(DstPoint.x, DstPoint.y, DstPoint.x+Width-1, DstPoint.y+Height-1), DstRect)) then exit; {$ELSE} // Przycinamy Ÿród³owy rect do obszaru Ÿród³owej bitmapy BufferRect.create(0, 0, ABuffer.width-1, ABuffer.height-1); if not(BufferRect.IntersectsWith(Create2DIntRect(SrcPoint.x, SrcPoint.y, SrcPoint.x+Width-1, SrcPoint.y+Height-1), SrcRect)) then exit; // Przycinamy docelowy rect do obszaru docelowej bitmapy BitmapRect.create(0, 0, ABitmap.width-1, ABitmap.height-1); if not(BitmapRect.IntersectsWith(Create2DIntRect(DstPoint.x, DstPoint.y, DstPoint.x+Width-1, DstPoint.y+Height-1), DstRect)) then exit; {$ENDIF} // Dodatkowo przycinamy docelowy rect if not(DstRect.IntersectsWith(ClipRect, ClippedDstRect)) then Exit; // Liczymy offset Ÿród³owego do docelowego recta Offset:=DstPoint - SrcPoint; // Sprawdzamy, czy na³o¿one na siebie recty: Ÿród³owy i docelowy przesuniêty o // offset maj¹ jak¹œ czêœæ wspóln¹ if not(SrcRect.IntersectsWith(ClippedDstRect - Offset, ClippedSrcRect)) then exit; // Jeœli jest cokolwiek do przetworzenia, wykonaj operacjê if (ClippedSrcRect.left<=ClippedSrcRect.right) and (ClippedSrcRect.top<=ClippedSrcRect.bottom) then begin SrcImg := ABuffer.CreateIntfImage; DestImg := ABitmap.CreateIntfImage; for y := ClippedSrcRect.top to ClippedSrcRect.bottom do begin SrcLine:=SrcImg.GetDataLineStart(y); DstLine:=DestImg.GetDataLineStart(y+Offset.y); Move({%H-}pointer({%H-}PtrInt(SrcLine) + 3*ClippedSrcRect.left)^, {%H-}pointer({%H-}PtrInt(DstLine) + 3*(ClippedSrcRect.left + Offset.x))^, 3*ClippedSrcRect.Width); end; ABitmap.LoadFromIntfImage(DestImg); DestImg.Destroy; SrcImg.Destroy; end; end; class procedure TGUITools.CopyRoundCorner(ABuffer: TBitmap; ABitmap: TBitmap; SrcPoint, DstPoint: T2DIntVector; Radius: integer; CornerPos: TCornerPos; Convex: boolean); var BufferRect, BitmapRect : T2DIntRect; OrgSrcRect, OrgDstRect : T2DIntRect; SrcRect : T2DIntRect; Offset : T2DIntVector; Center: T2DIntVector; y: Integer; SrcImg: TLazIntfImage; DestImg: TLazIntfImage; SrcLine: Pointer; DstLine: Pointer; SrcPtr, DstPtr : PByte; x: Integer; Dist : double; begin if (ABuffer.PixelFormat<>pf24bit) or (ABitmap.PixelFormat<>pf24bit) then raise exception.create('TSpkGUITools.CopyRoundCorner: Tylko 24-bitowe bitmapy s¹ akceptowane!'); // Sprawdzanie poprawnoœci if Radius<1 then exit; if (ABuffer.width=0) or (ABuffer.height=0) or (ABitmap.width=0) or (ABitmap.height=0) then exit; {$IFDEF EnhancedRecordSupport} BufferRect:=T2DIntRect.create(0, 0, ABuffer.width-1, ABuffer.height-1); if not(BufferRect.IntersectsWith(T2DIntRect.create(SrcPoint.x, SrcPoint.y, SrcPoint.x+Radius-1, SrcPoint.y+Radius-1), OrgSrcRect)) then exit; BitmapRect:=T2DIntRect.create(0, 0, ABitmap.width-1, ABitmap.height-1); if not(BitmapRect.IntersectsWith(T2DIntRect.create(DstPoint.x, DstPoint.y, DstPoint.x+Radius-1, DstPoint.y+Radius-1), OrgDstRect)) then exit; {$ELSE} BufferRect.create(0, 0, ABuffer.width-1, ABuffer.height-1); if not(BufferRect.IntersectsWith(Create2DIntRect(SrcPoint.x, SrcPoint.y, SrcPoint.x+Radius-1, SrcPoint.y+Radius-1), OrgSrcRect)) then exit; BitmapRect.create(0, 0, ABitmap.width-1, ABitmap.height-1); if not(BitmapRect.IntersectsWith(Create2DIntRect(DstPoint.x, DstPoint.y, DstPoint.x+Radius-1, DstPoint.y+Radius-1), OrgDstRect)) then exit; {$ENDIF} Offset:=DstPoint - SrcPoint; if not(OrgSrcRect.IntersectsWith(OrgDstRect - Offset, SrcRect)) then exit; // Ustalamy pozycjê œrodka ³uku {$IFDEF EnhancedRecordSupport} case CornerPos of cpLeftTop: Center:=T2DIntVector.create(SrcPoint.x + radius - 1, SrcPoint.y + Radius - 1); cpRightTop: Center:=T2DIntVector.create(SrcPoint.x, SrcPoint.y + Radius - 1); cpLeftBottom: Center:=T2DIntVector.Create(SrcPoint.x + radius - 1, SrcPoint.y); cpRightBottom: Center:=T2DIntVector.Create(SrcPoint.x, SrcPoint.y); end; {$ELSE} case CornerPos of cpLeftTop: Center.create(SrcPoint.x + radius - 1, SrcPoint.y + Radius - 1); cpRightTop: Center.create(SrcPoint.x, SrcPoint.y + Radius - 1); cpLeftBottom: Center.Create(SrcPoint.x + radius - 1, SrcPoint.y); cpRightBottom: Center.Create(SrcPoint.x, SrcPoint.y); end; {$ENDIF} // Czy jest cokolwiek do przetworzenia? if Convex then begin if (SrcRect.left<=SrcRect.right) and (SrcRect.top<=SrcRect.bottom) then begin SrcImg := ABuffer.CreateIntfImage; DestImg := ABitmap.CreateIntfImage; for y := SrcRect.top to SrcRect.bottom do begin SrcLine:=SrcImg.GetDataLineStart(y); DstLine:=DestImg.GetDataLineStart(y+Offset.y); SrcPtr:={%H-}pointer({%H-}PtrInt(SrcLine) + 3*SrcRect.left); DstPtr:={%H-}pointer({%H-}PtrInt(DstLine) + 3*(SrcRect.left + Offset.x)); for x := SrcRect.left to SrcRect.right do begin {$IFDEF EnhancedRecordSupport} Dist:=Center.DistanceTo(T2DVector.create(x, y)); {$ELSE} Dist:=Center.DistanceTo(x, y); {$ENDIF} if Dist <= (Radius-1) then Move(SrcPtr^,DstPtr^,3); inc(SrcPtr,3); inc(DstPtr,3); end; end; ABitmap.LoadFromIntfImage(DestImg); SrcImg.Destroy; DestImg.Destroy; end; end else begin if (SrcRect.left<=SrcRect.right) and (SrcRect.top<=SrcRect.bottom) then begin SrcImg := ABuffer.CreateIntfImage; DestImg := ABitmap.CreateIntfImage; for y := SrcRect.top to SrcRect.bottom do begin SrcLine:=SrcImg.GetDataLineStart(y); DstLine:=DestImg.GetDataLineStart(y+Offset.y); SrcPtr:={%H-}pointer({%H-}PtrInt(SrcLine) + 3*SrcRect.left); DstPtr:={%H-}pointer({%H-}PtrInt(DstLine) + 3*(SrcRect.left + Offset.x)); for x := SrcRect.left to SrcRect.right do begin {$IFDEF EnhancedRecordSupport} Dist:=Center.DistanceTo(T2DVector.create(x, y)); {$ELSE} Dist:=Center.DistanceTo(x, y); {$ENDIF} if Dist >= (Radius-1) then Move(SrcPtr^,DstPtr^,3); inc(SrcPtr,3); inc(DstPtr,3); end; end; ABitmap.LoadFromIntfImage(DestImg); SrcImg.Destroy; DestImg.Destroy; end; end; end; class procedure TGUITools.DrawAARoundCorner(ABitmap: TBitmap; Point: T2DIntVector; Radius: integer; CornerPos: TCornerPos; Color: TColor); var CornerRect: T2DIntRect; Center: T2DIntVector; colorR, colorG, colorB: byte; x, y: integer; RadiusDist: double; OrgCornerRect: T2DIntRect; BitmapRect: T2DIntRect; cr, cg, cb: Byte; begin if ABitmap.PixelFormat <> pf24bit then raise Exception.Create('TSpkGUITools.DrawAARoundCorner: Bitmapa musi byæ w trybie 24-bitowym!'); // Sprawdzamy poprawnoœæ if Radius < 1 then exit; if (ABitmap.Width=0) or (ABitmap.Height=0) then exit; {$IFDEF EnhancedRecordSupport} // �?ród³owy rect... OrgCornerRect := T2DIntRect.Create(Point.x, Point.y, Point.x + radius - 1, Point.y + radius - 1); // ...przycinamy do rozmiarów bitmapy BitmapRect := T2DIntRect.Create(0, 0, ABitmap.Width-1, ABitmap.Height-1); {$ELSE} // �?ród³owy rect... OrgCornerRect.Create(Point.x, Point.y, Point.x + radius - 1, Point.y + radius - 1); // ...przycinamy do rozmiarów bitmapy BitmapRect.Create(0, 0, ABitmap.Width-1, ABitmap.Height-1); {$ENDIF} if not BitmapRect.intersectsWith(OrgCornerRect, CornerRect) then exit; // Jeœli nie ma czego rysowaæ, wychodzimy if (CornerRect.Left > CornerRect.Right) or (CornerRect.Top > CornerRect.Bottom) then exit; // Szukamy œrodka ³uku - zale¿nie od rodzaju naro¿nika {$IFDEF EnhancedRecordSupport} case CornerPos of cpLeftTop: Center := T2DIntVector.Create(Point.x + radius - 1, Point.y + Radius - 1); cpRightTop: Center := T2DIntVector.Create(Point.x, Point.y + Radius - 1); cpLeftBottom: Center := T2DIntVector.Create(Point.x + radius - 1, Point.y); cpRightBottom: Center := T2DIntVector.Create(Point.x, Point.y); end; {$ELSE} case CornerPos of cpLeftTop: Center.Create(Point.x + radius - 1, Point.y + Radius - 1); cpRightTop: Center.Create(Point.x, Point.y + Radius - 1); cpLeftBottom: Center.Create(Point.x + radius - 1, Point.y); cpRightBottom: Center.Create(Point.x, Point.y); end; {$ENDIF} Color := ColorToRGB(Color); colorR := GetRValue(Color); colorG := GetGValue(Color); colorB := GetBValue(Color); for y := CornerRect.Top to CornerRect.Bottom do begin for x := CornerRect.Left to CornerRect.Right do begin {$IFDEF EnhancedRecordSupport} RadiusDist := 1 - abs((Radius - 1) - Center.DistanceTo(T2DIntVector.create(x, y))); {$ELSE} RadiusDist := 1 - abs((Radius - 1) - Center.DistanceTo(x, y)); {$ENDIF} if RadiusDist > 0 then begin RedGreenBlue(ColorToRGB(ABitmap.Canvas.Pixels[x,y]), cr, cg, cb); cb := round(cb + (ColorB - cb) * RadiusDist); cg := round(cg + (ColorG - cg) * RadiusDist); cr := round(cr + (ColorR - cr) * RadiusDist); ABitmap.Canvas.Pixels[x,y] := RGBToColor(cr,cg,cb); end; end; end; end; class procedure TGUITools.DrawAARoundCorner(ABitmap: TBitmap; Point: T2DIntVector; Radius: integer; CornerPos: TCornerPos; Color: TColor; ClipRect: T2DIntRect); var CornerRect: T2DIntRect; Center: T2DIntVector; colorR, colorG, colorB: byte; x, y: integer; RadiusDist: double; OrgCornerRect: T2DIntRect; UnClippedCornerRect : T2DIntRect; BitmapRect: T2DIntRect; cr,cb,cg: byte; begin if ABitmap.PixelFormat<>pf24bit then raise Exception.Create('TSpkGUITools.DrawAARoundCorner: Bitmap must be in 24-bit mode!'); if Radius < 1 then exit; if (ABitmap.Width = 0) or (ABitmap.Height = 0) then exit; {$IFDEF EnhancedRecordSupport} // Source rect... OrgCornerRect := T2DIntRect.Create( Point.x, Point.y, Point.x + radius - 1, Point.y + radius - 1 ); // ... cut to size bitmap BitmapRect := T2DIntRect.Create( 0, 0, ABitmap.Width-1, ABitmap.Height-1); {$ELSE} // Source rect... OrgCornerRect.Create(Point.x, Point.y, Point.x + radius - 1, Point.y + radius - 1); // ... cut to size bitmap BitmapRect.Create(0, 0, ABitmap.Width-1, ABitmap.Height-1); {$ENDIF} if not BitmapRect.IntersectsWith(OrgCornerRect, UnClippedCornerRect) then exit; // ClipRect if not UnClippedCornerRect.IntersectsWith(ClipRect, CornerRect) then exit; // If there is nothing to draw, we leave if (CornerRect.Left > CornerRect.Right) or (CornerRect.Top > CornerRect.Bottom) then exit; // We seek the center of the arc - depending on the type of corner {$IFDEF EnhancedRecordSupport} case CornerPos of cpLeftTop: Center := T2DIntVector.Create(Point.x + radius - 1, Point.y + Radius - 1); cpRightTop: Center := T2DIntVector.Create(Point.x, Point.y + Radius - 1); cpLeftBottom: Center := T2DIntVector.Create(Point.x + radius - 1, Point.y); cpRightBottom: Center := T2DIntVector.Create(Point.x, Point.y); end; {$ELSE} case CornerPos of cpLeftTop: Center.Create(Point.x + radius - 1, Point.y + Radius - 1); cpRightTop: Center.Create(Point.x, Point.y + Radius - 1); cpLeftBottom: Center.Create(Point.x + radius - 1, Point.y); cpRightBottom: Center.Create(Point.x, Point.y); end; {$ENDIF} Color := ColorToRGB(Color); colorR := GetRValue(Color); colorG := GetGValue(Color); colorB := GetBValue(Color); for y := CornerRect.Top to CornerRect.Bottom do begin for x := CornerRect.Left to CornerRect.Right do begin {$IFDEF EnhancedRecordSupport} RadiusDist := 1 - abs((Radius - 1) - Center.DistanceTo(T2DIntVector.create(x, y))); {$ELSE} RadiusDist := 1 - abs((Radius - 1) - Center.DistanceTo(x, y)); {$ENDIF} if RadiusDist > 0 then begin RedGreenBlue(ColorToRGB(ABitmap.Canvas.Pixels[x,y]), cr, cg, cb); cb := round(cb + (ColorB - cb) * RadiusDist); cg := round(cg + (ColorG - cg) * RadiusDist); cr := round(cr + (ColorR - cr) * RadiusDist); ABitmap.Canvas.Pixels[x,y] := RGBToColor(cr,cg,cb); end; end; end; end; class procedure TGUITools.DrawAARoundCorner(ACanvas: TCanvas; Point: T2DIntVector; Radius: integer; CornerPos: TCornerPos; Color: TColor); var Center: T2DIntVector; OrgColor: TColor; x, y: integer; RadiusDist: double; CornerRect: T2DIntRect; begin if Radius<1 then exit; {$IFDEF EnhancedRecordSupport} // Source rect CornerRect := T2DIntRect.Create( Point.x, Point.y, Point.x + radius - 1, Point.y + radius - 1 ); // We seek the center of the arc - depending on the type of corner case CornerPos of cpLeftTop: Center := T2DIntVector.Create(Point.x + radius - 1, Point.y + Radius - 1); cpRightTop: Center := T2DIntVector.Create(Point.x, Point.y + Radius - 1); cpLeftBottom: Center := T2DIntVector.Create(Point.x + radius - 1, Point.y); cpRightBottom: Center := T2DIntVector.Create(Point.x, Point.y); end; {$ELSE} // Source rect CornerRect.Create(Point.x, Point.y, Point.x + radius - 1, Point.y + radius - 1); // We seek the center of the arc - depending on the type of corner case CornerPos of cpLeftTop: Center.Create(Point.x + radius - 1, Point.y + Radius - 1); cpRightTop: Center.Create(Point.x, Point.y + Radius - 1); cpLeftBottom: Center.Create(Point.x + radius - 1, Point.y); cpRightBottom: Center.Create(Point.x, Point.y); end; {$ENDIF} Color := ColorToRGB(Color); for y := CornerRect.Top to CornerRect.Bottom do begin for x := CornerRect.Left to CornerRect.Right do begin {$IFDEF EnhancedRecordSupport} RadiusDist := 1 - abs((Radius - 1) - Center.DistanceTo(T2DIntVector.Create(x, y))); {$ELSE} RadiusDist := 1 - abs((Radius - 1) - Center.DistanceTo(x, y)); {$ENDIF} if RadiusDist > 0 then begin OrgColor := ACanvas.Pixels[x, y]; ACanvas.Pixels[x, y] := TColorTools.Shade(OrgColor, Color, RadiusDist); end; end; end; end; class procedure TGUITools.DrawAARoundCorner(ACanvas: TCanvas; Point: T2DIntVector; Radius: integer; CornerPos: TCornerPos; Color: TColor; ClipRect: T2DIntRect); var UseOrgClipRgn: boolean; ClipRgn: HRGN; OrgRgn: HRGN; begin // Store the original ClipRgn and set a new one SaveClipRgn(ACanvas.Handle, UseOrgClipRgn, OrgRgn); ClipRgn := CreateRectRgn(ClipRect.Left, ClipRect.Top, ClipRect.Right+1, ClipRect.Bottom+1); if UseOrgClipRgn then CombineRgn(ClipRgn, ClipRgn, OrgRgn, RGN_AND); SelectClipRgn(ACanvas.Handle, ClipRgn); DrawAARoundCorner(ACanvas, Point, Radius, CornerPos, Color); // Restores previous ClipRgn and removes used regions RestoreClipRgn(ACanvas.Handle, UseOrgClipRgn, OrgRgn); DeleteObject(ClipRgn); end; class procedure TGUITools.DrawAARoundFrame(ABitmap: TBitmap; Rect: T2DIntRect; Radius: integer; Color: TColor; ClipRect: T2DIntRect); begin if ABitmap.PixelFormat <> pf24Bit then raise Exception.Create('TGUITools.DrawAARoundFrame: Bitmap must be in 24-bit mode!'); if Radius < 1 then exit; if (Radius > Rect.Width div 2) or (Radius > Rect.Height div 2) then exit; // DrawAARoundCorner is protected against drawing outside the area {$IFDEF EnhancedRecordSupport} DrawAARoundCorner(ABitmap, T2DIntVector.Create(Rect.Left, Rect.Top), Radius, cpLeftTop, Color, ClipRect); DrawAARoundCorner(ABitmap, T2DIntVector.Create(Rect.Right - Radius + 1, Rect.Top), Radius, cpRightTop, Color, ClipRect); DrawAARoundCorner(ABitmap, T2DIntVector.Create(Rect.Left, Rect.Bottom - Radius + 1), Radius, cpLeftBottom, Color, ClipRect); DrawAARoundCorner(ABitmap, T2DIntVector.Create(Rect.Right - Radius + 1, Rect.Bottom - Radius + 1), Radius, cpRightBottom, Color, ClipRect); {$ELSE} DrawAARoundCorner(ABitmap, Create2DIntVector(Rect.Left, Rect.Top), Radius, cpLeftTop, Color, ClipRect); DrawAARoundCorner(ABitmap, Create2DIntVector(Rect.Right - Radius + 1, Rect.Top), Radius, cpRightTop, Color, ClipRect); DrawAARoundCorner(ABitmap, Create2DIntVector(Rect.Left, Rect.Bottom - Radius + 1), Radius, cpLeftBottom, Color, ClipRect); DrawAARoundCorner(ABitmap, Create2DIntVector(Rect.Right - Radius + 1, Rect.Bottom - Radius + 1), Radius, cpRightBottom, Color, ClipRect); {$ENDIF} ABitmap.Canvas.Pen.Color := Color; ABitmap.Canvas.pen.Style := psSolid; // Draw*Line is protected against drawing outside the area DrawVLine(ABitmap, Rect.Left, Rect.top + Radius, Rect.Bottom - Radius, Color, ClipRect); DrawVLine(ABitmap, Rect.Right, Rect.top + Radius, Rect.Bottom - Radius, Color, ClipRect); DrawHLine(ABitmap, Rect.Left + Radius, Rect.Right - Radius, Rect.Top, Color, ClipRect); DrawHLine(ABitmap, Rect.Left + Radius, Rect.Right - Radius, Rect.Bottom, Color, ClipRect); end; class procedure TGUITools.DrawAARoundFrame(ABitmap: TBitmap; Rect: T2DIntRect; Radius: integer; Color: TColor); begin if ABitmap.PixelFormat <> pf24Bit then raise Exception.Create('TGUITools.DrawAARoundFrame: Bitmap must be in 24-bit mode!'); if Radius < 1 then exit; if (Radius > Rect.Width div 2) or (Radius > Rect.Height div 2) then exit; // DrawAARoundCorner is protected against drawing outside the area {$IFDEF EnhancedRecordSupport} DrawAARoundCorner(ABitmap, T2DIntVector.Create(Rect.Left, Rect.Top), Radius, cpLeftTop, Color); DrawAARoundCorner(ABitmap, T2DIntVector.Create(Rect.Right - Radius + 1, Rect.Top), Radius, cpRightTop, Color); DrawAARoundCorner(ABitmap, T2DIntVector.Create(Rect.Left, Rect.Bottom - Radius + 1), Radius, cpLeftBottom, Color); DrawAARoundCorner(ABitmap, T2DIntVector.Create(Rect.Right - Radius + 1, Rect.Bottom - Radius + 1), Radius, cpRightBottom, Color); {$ELSE} DrawAARoundCorner(ABitmap, Create2DIntVector(Rect.Left, Rect.Top), Radius, cpLeftTop, Color); DrawAARoundCorner(ABitmap, Create2DIntVector(Rect.Right - Radius + 1, Rect.top), Radius, cpRightTop, Color); DrawAARoundCorner(ABitmap, Create2DIntVector(Rect.Left, Rect.Bottom - Radius + 1), Radius, cpLeftBottom, Color); DrawAARoundCorner(ABitmap, Create2DIntVector(Rect.Right - Radius + 1, Rect.Bottom - Radius + 1), Radius, cpRightBottom, Color); {$ENDIF} ABitmap.Canvas.Pen.Color := Color; ABitmap.Canvas.pen.Style := psSolid; // Draw*Line is protected against drawing outside the area DrawVLine(ABitmap, Rect.Left, Rect.Top + Radius, Rect.bottom - Radius, Color); DrawVLine(ABitmap, Rect.Right, Rect.Top + Radius, Rect.bottom - Radius, Color); DrawHLine(ABitmap, Rect.Left + Radius, Rect.Right - Radius, Rect.Top, Color); DrawHLine(ABitmap, Rect.Left + Radius, Rect.Right - Radius, Rect.Bottom, Color); end; class procedure TGUITools.DrawFitWText(ABitmap: TBitmap; x1, x2, y: integer; const AText: string; TextColor: TColor; Align : TAlignment); var tw: integer; s: string; begin with ABitmap.Canvas do begin Font.Color := TextColor; s := AText; tw := TextWidth(s); if tw <= x2-x1+1 then case Align of taLeftJustify : TextOut(x1,y,AText); taRightJustify : TextOut(x2-tw+1,y,AText); taCenter : TextOut(x1 + ((x2-x1 - tw) div 2), y, AText); end else begin while (s <> '') and (tw > x2-x1+1) do begin Delete(s, Length(s), 1); tw := TextWidth(s+'...'); end; if tw <= x2-x1+1 then TextOut(x1, y, s+'...'); end; end; end; class procedure TGUITools.DrawHLine(ACanvas: TCanvas; x1, x2, y: integer; Color: TColor); begin EnsureOrder(x1, x2); ACanvas.Pen.Color := Color; ACanvas.MoveTo(x1, y); ACanvas.LineTo(x2+1,y); end; class procedure TGUITools.DrawHLine(ACanvas: TCanvas; x1, x2, y: integer; Color: TColor; ClipRect: T2DIntRect); var UseOrgClipRgn: boolean; ClipRgn: HRGN; OrgRgn: HRGN; begin // Store the original ClipRgn and set a new one SaveClipRgn(ACanvas.Handle, UseOrgClipRgn, OrgRgn); ClipRgn := CreateRectRgn(ClipRect.left, ClipRect.Top, ClipRect.Right+1, ClipRect.Bottom+1); if UseOrgClipRgn then CombineRgn(ClipRgn, ClipRgn, OrgRgn, RGN_AND); SelectClipRgn(ACanvas.Handle, ClipRgn); DrawHLine(ACanvas, x1, x2, y, Color); // Restores previous ClipRgn and removes used regions RestoreClipRgn(ACanvas.Handle, UseOrgClipRgn, OrgRgn); DeleteObject(ClipRgn); end; class procedure TGUITools.DrawImage(ABitmap: TBitmap; Imagelist: TImageList; ImageIndex: integer; Point : T2DIntVector; ClipRect: T2DIntRect); begin DrawImage(ABitmap.Canvas, ImageList, ImageIndex, Point, ClipRect); end; class procedure TGUITools.DrawImage(ABitmap: TBitmap; Imagelist: TImageList; ImageIndex: integer; Point: T2DIntVector); begin DrawImage(ABitmap.Canvas, ImageList, ImageIndex, Point); end; class procedure TGUITools.DrawImage(ACanvas: TCanvas; Imagelist: TImageList; ImageIndex: integer; Point : T2DIntVector; ClipRect: T2DIntRect); var UseOrgClipRgn: Boolean; OrgRgn: HRGN; ClipRgn: HRGN; //ImageIcon: TIcon; // wp: no longer needed -- see below ImageBitmap: TBitmap; begin // Storing original ClipRgn and applying a new one SaveClipRgn(ACanvas.Handle, UseOrgClipRgn, OrgRgn); ClipRgn := CreateRectRgn(ClipRect.left, ClipRect.Top, ClipRect.Right+1, ClipRect.Bottom+1); if UseOrgClipRgn then CombineRgn(ClipRgn, ClipRgn, OrgRgn, RGN_AND); SelectClipRgn(ACanvas.Handle, ClipRgn); ImageList.Draw(ACanvas, Point.X, Point.Y, ImageIndex); (* { wp: Next part fixes issue https://sourceforge.net/p/lazarus-ccr/bugs/35/ } ImageBitmap := TBitmap.Create; ImageList.GetBitmap(ImageIndex, ImageBitmap); ACanvas.Draw(Point.x, Point.y, ImageBitmap); ImageBitmap.Free; *) { wp: The following lines were removed and replaced by the "ImageBitmap" lines above in order to fix the "handle leak" of https://sourceforge.net/p/lazarus-ccr/bugs/35/ Not daring to touch the ImageList.Draw which would have worked as well. } (* // avoid exclusive draw. draw with local canvas itself. //ImageList.Draw(ACanvas, Point.x, Point.y, ImageIndex); {$IfDef LCLWin32} ImageIcon := TIcon.Create; ImageList.GetIcon(ImageIndex, ImageIcon); ACanvas.Draw(Point.x, Point.y, ImageIcon); ImageIcon.Free; {$Else} ImageBitmap := TBitmap.Create; ImageList.GetBitmap(ImageIndex, ImageBitmap); ACanvas.Draw(Point.x, Point.y, ImageBitmap); ImageBitmap.Free; {$EndIf} *) RestoreClipRgn(ACanvas.Handle, UseOrgClipRgn, OrgRgn); DeleteObject(ClipRgn); end; class procedure TGUITools.DrawImage(ACanvas: TCanvas; Imagelist: TImageList; ImageIndex: integer; Point : T2DIntVector; ClipRect: T2DIntRect; AImageWidthAt96PPI, ATargetPPI: Integer; ACanvasFactor: Double); var UseOrgClipRgn: Boolean; OrgRgn: HRGN; ClipRgn: HRGN; //ImageIcon: TIcon; // wp: no longer needed -- see below ImageBitmap: TBitmap; begin // Storing original ClipRgn and applying a new one SaveClipRgn(ACanvas.Handle, UseOrgClipRgn, OrgRgn); ClipRgn := CreateRectRgn(ClipRect.left, ClipRect.Top, ClipRect.Right+1, ClipRect.Bottom+1); if UseOrgClipRgn then CombineRgn(ClipRgn, ClipRgn, OrgRgn, RGN_AND); SelectClipRgn(ACanvas.Handle, ClipRgn); {$IF LCL_FULLVERSION >= 1090000} ImageList.DrawForPPI(ACanvas, Point.X, Point.Y, ImageIndex, AImageWidthAt96PPI, ATargetPPI, ACanvasFactor); {$ELSE} ImageList.Draw(ACanvas, Point.X, Point.Y, ImageIndex); {$ENDIF} (* { wp: Next part fixes issue https://sourceforge.net/p/lazarus-ccr/bugs/35/ } ImageBitmap := TBitmap.Create; ImageList.GetBitmap(ImageIndex, ImageBitmap); ACanvas.Draw(Point.x, Point.y, ImageBitmap); ImageBitmap.Free; *) { wp: The following lines were removed and replaced by the "ImageBitmap" lines above in order to fix the "handle leak" of https://sourceforge.net/p/lazarus-ccr/bugs/35/ Not daring to touch the ImageList.Draw which would have worked as well. } (* // avoid exclusive draw. draw with local canvas itself. //ImageList.Draw(ACanvas, Point.x, Point.y, ImageIndex); {$IfDef LCLWin32} ImageIcon := TIcon.Create; ImageList.GetIcon(ImageIndex, ImageIcon); ACanvas.Draw(Point.x, Point.y, ImageIcon); ImageIcon.Free; {$Else} ImageBitmap := TBitmap.Create; ImageList.GetBitmap(ImageIndex, ImageBitmap); ACanvas.Draw(Point.x, Point.y, ImageBitmap); ImageBitmap.Free; {$EndIf} *) RestoreClipRgn(ACanvas.Handle, UseOrgClipRgn, OrgRgn); DeleteObject(ClipRgn); end; class procedure TGUITools.DrawMarkedText(ACanvas: TCanvas; x, y: integer; const AText, AMarkPhrase: string; TextColor : TColor; ClipRect: T2DIntRect; CaseSensitive: boolean); var UseOrgClipRgn: Boolean; OrgRgn: HRGN = 0; ClipRgn: HRGN = 0; begin // Store the original ClipRgn and set a new one SaveClipRgn(ACanvas.Handle, UseOrgClipRgn, OrgRgn); ClipRgn := CreateRectRgn(ClipRect.left, ClipRect.Top, ClipRect.Right+1, ClipRect.Bottom+1); if UseOrgClipRgn then CombineRgn(ClipRgn, ClipRgn, OrgRgn, RGN_AND); SelectClipRgn(ACanvas.Handle, ClipRgn); DrawMarkedText(ACanvas, x, y, AText, AMarkPhrase, TextColor, CaseSensitive); RestoreClipRgn(ACanvas.Handle, UseOrgClipRgn, OrgRgn); DeleteObject(ClipRgn); end; class procedure TGUITools.DrawMarkedText(ACanvas: TCanvas; x, y: integer; const AText, AMarkPhrase: string; TextColor : TColor; CaseSensitive : boolean); var TextToDraw: string; BaseText: string; MarkText: string; MarkPos: Integer; x1: integer; s: string; MarkTextLength: Integer; begin TextToDraw := AText; if CaseSensitive then begin BaseText := AText; MarkText := AMarkPhrase; end else begin BaseText := AnsiUpperCase(AText); MarkText := AnsiUpperCase(AMarkPhrase); end; x1 := x; MarkTextLength := Length(MarkText); ACanvas.Font.Color := TextColor; ACanvas.Brush.Style := bsClear; MarkPos := pos(MarkText, BaseText); while MarkPos > 0 do begin if MarkPos > 1 then begin // Drawing text before highlighted ACanvas.Font.Style := ACanvas.Font.Style - [fsBold]; s := copy(TextToDraw, 1, MarkPos-1); ACanvas.TextOut(x1, y, s); inc(x1, ACanvas.TextWidth(s)+1); Delete(TextToDraw, 1, MarkPos-1); Delete(BaseText, 1, MarkPos-1); end; // Drawing highlighted text ACanvas.Font.Style := ACanvas.Font.Style + [fsBold]; s := copy(TextToDraw, 1, MarkTextLength); ACanvas.TextOut(x1, y, s); inc(x1, ACanvas.TextWidth(s)+1); Delete(TextToDraw, 1, MarkTextLength); Delete(BaseText, 1, MarkTextLength); MarkPos := pos(MarkText, BaseText); end; if Length(BaseText) > 0 then begin ACanvas.Font.Style := ACanvas.Font.Style - [fsBold]; ACanvas.TextOut(x1, y, TextToDraw); end; end; class procedure TGUITools.DrawImage(ACanvas: TCanvas; Imagelist: TImageList; ImageIndex: integer; Point: T2DIntVector); begin ImageList.Draw(ACanvas, Point.x, Point.y, ImageIndex); end; class procedure TGUITools.DrawOutlinedText(ACanvas: TCanvas; x, y: integer; const AText: string; TextColor, OutlineColor: TColor); begin with ACanvas do begin Brush.Style := bsClear; Font.Color := OutlineColor; TextOut(x-1, y-1, AText); TextOut(x, y-1, AText); TextOut(x+1, y-1, AText); TextOut(x-1, y, AText); TextOut(x+1, y, AText); TextOut(x-1, y+1, AText); TextOut(x, y+1, AText); TextOut(x+1, y+1, AText); Font.Color := TextColor; TextOut(x, y, AText); end; end; class procedure TGUITools.DrawOutlinedText(ACanvas: TCanvas; x, y: integer; const AText: string; TextColor, OutlineColor: TColor; ClipRect: T2DIntRect); var WinAPIClipRect: TRect; begin WinAPIClipRect := ClipRect.ForWinAPI; with ACanvas do begin Brush.Style := bsClear; Font.Color := OutlineColor; TextRect(WinAPIClipRect, x-1, y-1, AText); TextRect(WinAPIClipRect, x, y-1, AText); TextRect(WinAPIClipRect, x+1, y-1, AText); TextRect(WinAPIClipRect, x-1, y, AText); TextRect(WinAPIClipRect, x+1, y, AText); TextRect(WinAPIClipRect, x-1, y+1, AText); TextRect(WinAPIClipRect, x, y+1, AText); TextRect(WinAPIClipRect, x+1, y+1, AText); Font.Color := TextColor; TextRect(WinAPIClipRect, x, y, AText); end; end; class procedure TGUITools.DrawHLine(ABitmap: TBitmap; x1, x2, y: integer; Color: TColor); var LineRect: T2DIntRect; BitmapRect: T2DIntRect; begin if ABitmap.PixelFormat <> pf24Bit then raise Exception.Create('TGUITools.DrawHLine: Bitmap must be in 24-bit mode'); EnsureOrder(x1, x2); {$IFDEF EnhancedRecordSupport} BitmapRect := T2DIntRect.Create(0, 0, ABitmap.Width-1, ABitmap.Height-1); if not BitmapRect.IntersectsWith(T2DIntRect.Create(x1, y, x2, y), LineRect) then exit; {$ELSE} BitmapRect.Create(0, 0, ABitmap.Width-1, ABitmap.Height-1); if not BitmapRect.IntersectsWith(Create2DIntRect(x1, y, x2, y), LineRect) then exit; {$ENDIF} ABitmap.Canvas.Pen.Color := Color; ABitmap.Canvas.Pen.Style := psSolid; ABitmap.Canvas.MoveTo(LineRect.Left, LineRect.Top); ABitmap.canvas.LineTo(LineRect.Right+1, LineRect.Top); end; class procedure TGUITools.DrawHLine(ABitmap: TBitmap; x1, x2, y: integer; Color: TColor; ClipRect: T2DIntRect); var OrgLineRect: T2DIntRect; LineRect: T2DIntRect; BitmapRect: T2DIntRect; begin if ABitmap.PixelFormat<>pf24bit then raise Exception.Create('TGUITools.DrawHLine: Bitmap must be in 24-bit mode!'); EnsureOrder(x1, x2); {$IFDEF EnhancedRecordSupport} BitmapRect := T2DIntRect.Create(0, 0, ABitmap.Width-1, ABitmap.Height-1); if not BitmapRect.IntersectsWith(T2DIntRect.Create(x1, y, x2, y), OrgLineRect) then exit; {$ELSE} BitmapRect.Create(0, 0, ABitmap.Width-1, ABitmap.Height-1); if not BitmapRect.IntersectsWith(Create2DIntRect(x1, y, x2, y), OrgLineRect) then exit; {$ENDIF} if not OrgLineRect.IntersectsWith(ClipRect, LineRect) then exit; ABitmap.Canvas.Pen.Color := Color; ABitmap.Canvas.Pen.Style := psSolid; ABitmap.Canvas.MoveTo(LineRect.Left, LineRect.Top); ABitmap.Canvas.LineTo(LineRect.Right+1, LineRect.Top); end; class procedure TGUITools.DrawOutlinedText(ABitmap: TBitmap; x, y: integer; const AText: string; TextColor, OutlineColor: TColor; ClipRect: T2DIntRect); var WinAPIClipRect: TRect; begin WinAPIClipRect := ClipRect.ForWinAPI; with ABitmap.canvas do begin Brush.Style := bsClear; Font.Color := OutlineColor; TextRect(WinAPIClipRect, x-1, y-1, AText); TextRect(WinAPIClipRect, x, y-1, AText); TextRect(WinAPIClipRect, x+1, y-1, AText); TextRect(WinAPIClipRect, x-1, y, AText); TextRect(WinAPIClipRect, x+1, y, AText); TextRect(WinAPIClipRect, x-1, y+1, AText); TextRect(WinAPIClipRect, x, y+1, AText); TextRect(WinAPIClipRect, x+1, y+1, AText); Font.Color := TextColor; TextRect(WinAPIClipRect, x, y, AText); end; end; class procedure TGUITools.DrawRegion(ACanvas: TCanvas; Region: HRGN; Rect : T2DIntRect; ColorFrom, ColorTo: TColor; GradientKind: TBackgroundKind); var UseOrgClipRgn: Boolean; OrgRgn: HRGN; begin // Store the original ClipRgn and set a new one SaveClipRgn(ACanvas.Handle, UseOrgClipRgn, OrgRgn); SelectClipRgn(ACanvas.Handle, Region); FillGradientRectangle(ACanvas, Rect, ColorFrom, ColorTo, GradientKind); RestoreClipRgn(ACanvas.Handle, UseOrgClipRgn, OrgRgn); end; class procedure TGUITools.DrawRegion(ACanvas: TCanvas; Region: HRGN; Rect : T2DIntRect; ColorFrom, ColorTo: TColor; GradientKind: TBackgroundKind; ClipRect: T2DIntRect); var UseOrgClipRgn: boolean; ClipRgn: HRGN; OrgRgn: HRGN; begin // Store the original ClipRgn and set a new one SaveClipRgn(ACanvas.Handle, UseOrgClipRgn, OrgRgn); ClipRgn := CreateRectRgn(ClipRect.left, ClipRect.Top, ClipRect.Right+1, ClipRect.Bottom+1); if UseOrgClipRgn then CombineRgn(ClipRgn, ClipRgn, OrgRgn, RGN_AND); SelectClipRgn(ACanvas.Handle, ClipRgn); DrawRegion(ACanvas, Region, Rect, ColorFrom, ColorTo, GradientKind); // Restores previous ClipRgn and removes used regions RestoreClipRgn(ACanvas.Handle, UseOrgClipRgn, OrgRgn); DeleteObject(ClipRgn); end; class procedure TGUITools.DrawRoundRect(ACanvas: TCanvas; Rect: T2DIntRect; Radius: integer; ColorFrom, ColorTo: TColor; GradientKind: TBackgroundKind; ClipRect: T2DIntRect; LeftTopRound, RightTopRound, LeftBottomRound, RightBottomRound: boolean); var UseOrgClipRgn: boolean; ClipRgn: HRGN; OrgRgn: HRGN; begin // Store the original ClipRgn and set a new one SaveClipRgn(ACanvas.Handle, UseOrgClipRgn, OrgRgn); ClipRgn := CreateRectRgn( ClipRect.left, ClipRect.Top, ClipRect.Right+1, ClipRect.Bottom+1 ); if UseOrgClipRgn then CombineRgn(ClipRgn, ClipRgn, OrgRgn, RGN_AND); SelectClipRgn(ACanvas.Handle, ClipRgn); DrawRoundRect(ACanvas, Rect, Radius, ColorFrom, ColorTo, GradientKind, LeftTopRound, RightTopRound, LeftBottomRound, RightBottomRound); // Restores previous ClipRgn and removes used regions RestoreClipRgn(ACanvas.Handle, UseOrgClipRgn, OrgRgn); DeleteObject(ClipRgn); end; class procedure TGUITools.DrawText(ACanvas: TCanvas; x, y: integer; const AText: string; TextColor: TColor); begin with ACanvas do begin Brush.Style := bsClear; Font.Color := TextColor; TextOut(x, y, AText); end; end; class procedure TGUITools.DrawText(ACanvas: TCanvas; x, y: integer; const AText: string; TextColor: TColor; ClipRect: T2DIntRect); var WinAPIClipRect: TRect; begin WinAPIClipRect := ClipRect.ForWinAPI; with ACanvas do begin Brush.Style := bsClear; Font.Color := TextColor; TextRect(WinAPIClipRect, x, y, AText); end; end; class procedure TGUITools.DrawRoundRect(ACanvas: TCanvas; Rect: T2DIntRect; Radius: integer; ColorFrom, ColorTo: TColor; GradientKind: TBackgroundKind; LeftTopRound, RightTopRound, LeftBottomRound, RightBottomRound: boolean); var RoundRgn: HRGN; TmpRgn: HRGN; OrgRgn: HRGN; UseOrgClipRgn: Boolean; begin if Radius < 0 then exit; if Radius > 0 then begin //WriteLn('Radius: ', Radius, ' Rect.Width: ', Rect.Width, ' Rect.Height: ', Rect.Height); // There's a bug in fpc that evaluates the expression below erroneous when using inline // Radius = 3 and Rect.Width >= 128 and <= 261 will evaluate to true {$ifdef FpcBugWorkAround} if (CompareValue(Radius*2, Rect.width) > 0) and (CompareValue(Radius*2, Rect.Height) > 0) then exit; {$else} if (Radius*2 > Rect.Width) or (Radius*2 > Rect.Height) then exit; {$endif} // Zapamiêtywanie oryginalnego ClipRgn i ustawianie nowego SaveClipRgn(ACanvas.Handle, UseOrgClipRgn, OrgRgn); if not(LeftTopRound) and not(RightTopRound) and not(LeftBottomRound) and not (RightBottomRound) then begin RoundRgn := CreateRectRgn(Rect.Left, Rect.Top, Rect.Right + 1, Rect.Bottom + 1); end else begin RoundRgn := CreateRoundRectRgn(Rect.Left, Rect.Top, Rect.Right +2, Rect.Bottom + 2, Radius*2, Radius*2); if not LeftTopRound then begin TmpRgn := CreateRectRgn(Rect.Left, Rect.Top, Rect.Left + Radius, Rect.Top + Radius); CombineRgn(RoundRgn, RoundRgn, TmpRgn, RGN_OR); DeleteObject(TmpRgn); end; if not RightTopRound then begin TmpRgn := CreateRectRgn(Rect.Right - Radius + 1, Rect.Top, Rect.Right + 1, Rect.Top + Radius); CombineRgn(RoundRgn, RoundRgn, TmpRgn, RGN_OR); DeleteObject(TmpRgn); end; if not LeftBottomRound then begin TmpRgn := CreateRectRgn(Rect.Left, Rect.Bottom - Radius + 1, Rect.Left + Radius, Rect.Bottom + 1); CombineRgn(RoundRgn, RoundRgn, TmpRgn, RGN_OR); DeleteObject(TmpRgn); end; if not RightBottomRound then begin TmpRgn := CreateRectRgn(Rect.Right - Radius + 1, Rect.Bottom - Radius + 1, Rect.Right + 1, Rect.Bottom + 1); CombineRgn(RoundRgn, RoundRgn, TmpRgn, RGN_OR); DeleteObject(TmpRgn); end; end; if UseOrgClipRgn then CombineRgn(RoundRgn, RoundRgn, OrgRgn, RGN_AND); SelectClipRgn(ACanvas.Handle, RoundRgn); end; // if Radius > 0 ColorFrom := ColorToRGB(ColorFrom); ColorTo := ColorToRGB(ColorTo); FillGradientRectangle(ACanvas, Rect, ColorFrom, ColorTo, GradientKind); if Radius > 0 then begin // Restores previous ClipRgn and removes used regions RestoreClipRgn(ACanvas.Handle, UseOrgClipRgn, OrgRgn); DeleteObject(RoundRgn); end; end; class procedure TGUITools.DrawOutlinedText(ABitmap: TBitmap; x, y: integer; const AText: string; TextColor, OutlineColor: TColor); begin with ABitmap.Canvas do begin Brush.Style := bsClear; Font.Color := OutlineColor; TextOut(x-1, y-1, AText); TextOut(x, y-1, AText); TextOut(x+1, y-1, AText); TextOut(x-1, y, AText); TextOut(x+1, y, AText); TextOut(x-1, y+1, AText); TextOut(x, y+1, AText); TextOut(x+1, y+1, AText); Font.Color := TextColor; TextOut(x, y, AText); end; end; class procedure TGUITools.DrawText(ABitmap: TBitmap; x, y: integer; const AText: string; TextColor: TColor; ClipRect: T2DIntRect); var WinAPIClipRect : TRect; begin WinAPIClipRect := ClipRect.ForWinAPI; with ABitmap.Canvas do begin Brush.Style := bsClear; Font.Color := TextColor; TextRect(WinAPIClipRect, x, y, AText); end; end; class procedure TGUITools.DrawFitWOutlinedText(ABitmap: TBitmap; x1, x2, y: integer; const AText: string; TextColor, OutlineColor: TColor; Align: TAlignment); var tw: integer; s: string; begin with ABitmap.Canvas do begin s := AText; tw := TextWidth(s) + 2; if tw <= x2 - x1 + 1 then case Align of taLeftJustify: TGUITools.DrawOutlinedText(ABitmap,x1, y, AText, TextColor, OutlineColor); taRightJustify: TGUITools.DrawOutlinedText(ABitmap,x2-tw+1, y, AText, TextColor, OutlineColor); taCenter: TGUITools.DrawOutlinedText(ABitmap,x1 + ((x2-x1 - tw) div 2), y, AText, TextColor, OutlineColor); end else begin while (s <> '') and (tw > x2 - x1 + 1) do begin Delete(s, Length(s), 1); tw := TextWidth(s + '...') + 2; end; if tw <= x2 - x1 + 1 then TGUITools.DrawOutlinedText(ABitmap, x1, y, s+'...', TextColor, OutlineColor); end; end; end; class procedure TGUITools.DrawFitWOutlinedText(ACanvas: TCanvas; x1, x2, y: integer; const AText: string; TextColor, OutlineColor: TColor; Align: TAlignment); var tw: integer; s: string; begin with ACanvas do begin s := AText; tw := TextWidth(s) + 2; if tw <= x2 - x1 + 1 then case Align of taLeftJustify: TGUITools.DrawOutlinedText(ACanvas,x1, y, AText, TextColor, OutlineColor); taRightJustify: TGUITools.DrawOutlinedText(ACanvas,x2-tw+1, y, AText, TextColor, OutlineColor); taCenter: TGUITools.DrawOutlinedText(ACanvas,x1 + (x2-x1 - tw) div 2, y, AText, TextColor, OutlineColor); end else begin while (s <> '') and (tw > x2 - x1 + 1) do begin Delete(s, Length(s), 1); tw := TextWidth(s + '...') + 2; end; if tw <= x2 - x1 + 1 then TGUITools.DrawOutlinedText(ACanvas, x1, y, s+'...', TextColor, OutlineColor); end; end; end; class procedure TGUITools.FillGradientRectangle(ACanvas: TCanvas; Rect: T2DIntRect; ColorFrom: TColor; ColorTo: TColor; GradientKind: TBackgroundKind); var Mesh: array of GRADIENTRECT; GradientVertice: array of TRIVERTEX; ConcaveColor: TColor; begin case GradientKind of bkSolid: begin ACanvas.Brush.Style := bsSolid; ACanvas.brush.color := ColorFrom; ACanvas.fillrect(Rect.ForWinAPI); end; bkVerticalGradient, bkHorizontalGradient: begin SetLength(GradientVertice, 2); with GradientVertice[0] do begin x := Rect.left; y := Rect.top; Red := GetRValue(ColorFrom) shl 8; Green := GetGValue(ColorFrom) shl 8; Blue := GetBValue(ColorFrom) shl 8; Alpha := 255 shl 8; end; with GradientVertice[1] do begin x := Rect.Right + 1; y := Rect.bottom + 1; Red := GetRValue(ColorTo) shl 8; Green := GetGValue(ColorTo) shl 8; Blue := GetBValue(ColorTo) shl 8; Alpha := 255 shl 8; end; SetLength(Mesh, 1); Mesh[0].UpperLeft := 0; Mesh[0].LowerRight := 1; if GradientKind = bkVerticalGradient then GradientFill(ACanvas.Handle, @GradientVertice[0], 2, @Mesh[0], 1, GRADIENT_FILL_RECT_V) else GradientFill(ACanvas.Handle, @GradientVertice[0], 2, @Mesh[0], 1, GRADIENT_FILL_RECT_H); end; bkConcave: begin ConcaveColor:=TColorTools.Brighten(ColorFrom, 20); SetLength(GradientVertice, 4); with GradientVertice[0] do begin x := Rect.left; y := Rect.top; Red := GetRValue(ColorFrom) shl 8; Green := GetGValue(ColorFrom) shl 8; Blue := GetBValue(ColorFrom) shl 8; Alpha := 255 shl 8; end; with GradientVertice[1] do begin x := Rect.Right + 1; y := Rect.Top + (Rect.height) div 4; Red := GetRValue(ConcaveColor) shl 8; Green := GetGValue(ConcaveColor) shl 8; Blue := GetBValue(ConcaveColor) shl 8; Alpha := 255 shl 8; end; with GradientVertice[2] do begin x := Rect.left; y := Rect.Top + (Rect.height) div 4; Red := GetRValue(ColorTo) shl 8; Green := GetGValue(ColorTo) shl 8; Blue := GetBValue(ColorTo) shl 8; Alpha := 255 shl 8; end; with GradientVertice[3] do begin x := Rect.Right + 1; y := Rect.bottom + 1; Red := GetRValue(ColorFrom) shl 8; Green := GetGValue(ColorFrom) shl 8; Blue := GetBValue(ColorFrom) shl 8; Alpha := 255 shl 8; end; SetLength(Mesh, 2); Mesh[0].UpperLeft := 0; Mesh[0].LowerRight := 1; Mesh[1].UpperLeft := 2; Mesh[1].LowerRight := 3; GradientFill(ACanvas.Handle, @GradientVertice[0], 4, @Mesh[0], 2, GRADIENT_FILL_RECT_V); end; end; end; class procedure TGUITools.DrawFitWText(ACanvas: TCanvas; x1, x2, y: integer; const AText: string; TextColor: TColor; Align: TAlignment); var tw: integer; s: string; begin with ACanvas do begin Font.Color := TextColor; s := AText; tw := TextWidth(s); // We draw if the text is changed if tw <= x2 - x1 + 1 then case Align of taLeftJustify : TextOut(x1, y, AText); taRightJustify : TextOut(x2-tw+1, y, AText); taCenter : TextOut(x1 + (x2-x1 - tw) div 2, y, AText); end else begin while (s <> '') and (tw > x2 - x1 + 1) do begin Delete(s, Length(s), 1); tw := TextWidth(s + '...'); end; if tw <= x2 - x1 + 1 then TextOut(x1, y, s + '...'); end; end; end; class procedure TGUITools.RenderBackground(ABuffer: TBitmap; Rect: T2DIntRect; Color1, Color2: TColor; BackgroundKind: TBackgroundKind); var TempRect: T2DIntRect; begin if ABuffer.PixelFormat<>pf24bit then raise Exception.Create('TGUITools.RenderBackground: Bitmap must be in 24-bit mode'); if (Rect.Left > Rect.Right) or (Rect.Top > Rect.Bottom) then exit; // Both the FillRect method and the WinAPI gradient drawing are // protected from drawing outside the canvas area. case BackgroundKind of bkSolid: begin ABuffer.Canvas.Brush.Color := Color1; ABuffer.Canvas.Brush.Style := bsSolid; ABuffer.Canvas.FillRect(Rect.ForWinAPI); end; bkVerticalGradient: TGradientTools.VGradient(ABuffer.Canvas, Color1, Color2, Rect.ForWinAPI); bkHorizontalGradient: TGradientTools.HGradient(ABuffer.Canvas, Color1, Color2, Rect.ForWinAPI); bkConcave: begin {$IFDEF EnhancedRecordSupport} TempRect := T2DIntRect.Create( {$ELSE} TempRect.Create( {$ENDIF} Rect.Left, Rect.Top, Rect.Right, Rect.Top + (Rect.Bottom - Rect.Top) div 4 ); TGradientTools.VGradient(ABuffer.Canvas, Color1, TColorTools.Shade(Color1, Color2, 20), TempRect.ForWinAPI); {$IFDEF EnhancedRecordSupport} TempRect := T2DIntRect.Create( {$ELSE} TempRect.Create( {$ENDIF} Rect.Left, Rect.Top + (Rect.Bottom - Rect.Top) div 4 + 1, Rect.Right, Rect.Bottom ); TGradientTools.VGradient(ABuffer.Canvas, Color2, Color1, TempRect.ForWinAPI); end; end; // case end; class procedure TGUITools.RestoreClipRgn(DC: HDC; OrgRgnExists: boolean; var OrgRgn: HRGN); begin if OrgRgnExists then SelectClipRgn(DC, OrgRgn) else SelectClipRgn(DC, 0); DeleteObject(OrgRgn); end; class procedure TGUITools.SaveClipRgn(DC: HDC; out OrgRgnExists: boolean; out OrgRgn: HRGN); var i: integer; begin OrgRgn := CreateRectRgn(0, 0, 1, 1); i := GetClipRgn(DC, OrgRgn); OrgRgnExists := (i=1); end; class procedure TGUITools.DrawText(ABitmap: TBitmap; x, y: integer; const AText: string; TextColor: TColor); begin with ABitmap.Canvas do begin Brush.Style := bsClear; Font.Color:= TextColor; TextOut(x, y, AText); end; end; class procedure TGUITools.DrawVLine(ABitmap: TBitmap; x, y1, y2: integer; Color: TColor); var LineRect: T2DIntRect; BitmapRect: T2DIntRect; begin if ABitmap.PixelFormat <> pf24bit then raise Exception.Create('TGUITools.DrawHLine: Bitmap must be in 24-bit mode!'); EnsureOrder(y1, y2); {$IFDEF EnhancedRecordSupport} BitmapRect := T2DIntRect.Create(0, 0, ABitmap.Width-1, ABitmap.Height-1); if not (BitmapRect.IntersectsWith(T2DIntRect.Create(x, y1, x, y2), LineRect)) then exit; {$ELSE} BitmapRect.create(0, 0, ABitmap.Width-1, ABitmap.Height-1); if not (BitmapRect.IntersectsWith(Create2DIntRect(x, y1, x, y2), LineRect)) then exit; {$ENDIF} ABitmap.Canvas.Pen.color := Color; ABitmap.Canvas.Pen.style := psSolid; ABitmap.Canvas.Moveto(LineRect.Left, LineRect.Top); ABitmap.Canvas.Lineto(LineRect.Left, Linerect.Bottom+1); end; class procedure TGUITools.DrawVLine(ABitmap: TBitmap; x, y1, y2: integer; Color: TColor; ClipRect: T2DIntRect); var OrgLineRect: T2DIntRect; LineRect: T2DIntRect; BitmapRect: T2DIntRect; begin if ABitmap.PixelFormat <> pf24bit then raise Exception.Create('TGUITools.DrawHLine: Bitmap must be in 24-bit mode!'); EnsureOrder(y1, y2); {$IFDEF EnhancedRecordSupport} BitmapRect := T2DIntRect.Create(0, 0, ABitmap.Width-1, ABitmap.Height-1); if not(BitmapRect.IntersectsWith(T2DIntRect.Create(x, y1, x, y2), OrgLineRect)) then exit; {$ELSE} BitmapRect.Create(0, 0, ABitmap.Width-1, ABitmap.Height-1); if not(BitmapRect.IntersectsWith(Create2DIntRect(x, y1, x, y2), OrgLineRect)) then exit; {$ENDIF} if not(OrgLineRect.IntersectsWith(ClipRect, LineRect)) then exit; ABitmap.Canvas.Pen.Color := Color; ABitmap.Canvas.Pen.Style := psSolid; ABitmap.Canvas.Moveto(LineRect.Left, LineRect.Top); ABitmap.Canvas.Lineto(LineRect.Left, Linerect.Bottom+1); end; class procedure TGUITools.DrawVLine(ACanvas: TCanvas; x, y1, y2: integer; Color: TColor); begin EnsureOrder(y1, y2); ACanvas.Pen.Color := Color; ACanvas.Moveto(x, y1); ACanvas.Lineto(x, y2+1); end; class procedure TGUITools.DrawVLine(ACanvas: TCanvas; x, y1, y2: integer; Color: TColor; ClipRect: T2DIntRect); var UseOrgClipRgn: boolean; ClipRgn: HRGN; OrgRgn: HRGN; begin // Store the original ClipRgn and set a new one SaveClipRgn(ACanvas.Handle, UseOrgClipRgn, OrgRgn); ClipRgn := CreateRectRgn(ClipRect.left, ClipRect.Top, ClipRect.Right+1, ClipRect.Bottom+1); if UseOrgClipRgn then CombineRgn(ClipRgn, ClipRgn, OrgRgn, RGN_AND); SelectClipRgn(ACanvas.Handle, ClipRgn); DrawVLine(ACanvas, x, y1, y2, Color); // Restores previous ClipRgn and removes used regions RestoreClipRgn(ACanvas.Handle, UseOrgClipRgn, OrgRgn); DeleteObject(ClipRgn); end; class procedure TGUITools.DrawAARoundFrame(ACanvas: TCanvas; Rect: T2DIntRect; Radius: integer; Color: TColor); begin if Radius < 1 then exit; if (Radius > Rect.Width div 2) or (Radius > Rect.Height div 2) then exit; // DrawAARoundCorner is protected against drawing outside the area {$IFDEF EnhancedRecordSupport} DrawAARoundCorner(ACanvas, T2DIntVector.create(Rect.Left, Rect.Top), Radius, cpLeftTop, Color); DrawAARoundCorner(ACanvas, T2DIntVector.create(Rect.Right - Radius + 1, Rect.Top), Radius, cpRightTop, Color); DrawAARoundCorner(ACanvas, T2DIntVector.create(Rect.Left, Rect.Bottom - Radius + 1), Radius, cpLeftBottom, Color); DrawAARoundCorner(ACanvas, T2DIntVector.create(Rect.Right - Radius + 1, Rect.Bottom - Radius + 1), Radius, cpRightBottom, Color); {$ELSE} DrawAARoundCorner(ACanvas, Create2DIntVector(Rect.Left, Rect.Top), Radius, cpLeftTop, Color); DrawAARoundCorner(ACanvas, Create2DIntVector(Rect.Right - Radius + 1, Rect.Top), Radius, cpRightTop, Color); DrawAARoundCorner(ACanvas, Create2DIntVector(Rect.Left, Rect.Bottom - Radius + 1), Radius, cpLeftBottom, Color); DrawAARoundCorner(ACanvas, Create2DIntVector(Rect.Right - Radius + 1, Rect.Bottom - Radius + 1), Radius, cpRightBottom, Color); {$ENDIF} ACanvas.Pen.color := Color; ACanvas.pen.style := psSolid; // Draw * Line is protected against drawing outside the area DrawVLine(ACanvas, Rect.Left, Rect.Top + Radius, Rect.Bottom - Radius, Color); DrawVLine(ACanvas, Rect.Right, Rect.Top + Radius, Rect.Bottom - Radius, Color); DrawHLine(ACanvas, Rect.Left + Radius, Rect.Right - Radius, Rect.Top, Color); DrawHLine(ACanvas, Rect.Left + Radius, Rect.Right - Radius, Rect.Bottom, Color); end; class procedure TGUITools.DrawAARoundFrame(ACanvas: TCanvas; Rect: T2DIntRect; Radius: integer; Color: TColor; ClipRect: T2DIntRect); var UseOrgClipRgn: boolean; ClipRgn: HRGN; OrgRgn: HRGN; begin // Store the original ClipRgn and set a new one SaveClipRgn(ACanvas.Handle, UseOrgClipRgn, OrgRgn); ClipRgn := CreateRectRgn(ClipRect.left, ClipRect.Top, ClipRect.Right+1, ClipRect.Bottom+1); if UseOrgClipRgn then CombineRgn(ClipRgn, ClipRgn, OrgRgn, RGN_AND); SelectClipRgn(ACanvas.Handle, ClipRgn); DrawAARoundFrame(ACanvas, Rect, Radius, Color); // Restores previous ClipRgn and removes used regions RestoreClipRgn(ACanvas.Handle, UseOrgClipRgn, OrgRgn); DeleteObject(ClipRgn); end; class procedure TGUITools.DrawDisabledImage(ABitmap: TBitmap; Imagelist: TImageList; ImageIndex: integer; Point: T2DIntVector; ClipRect: T2DIntRect); begin DrawDisabledImage(ABitmap.Canvas, ImageList, ImageIndex, Point, ClipRect); end; class procedure TGUITools.DrawDisabledImage(ABitmap: TBitmap; Imagelist: TImageList; ImageIndex: integer; Point: T2DIntVector); begin DrawDisabledImage(ABitmap.Canvas, ImageList, ImageIndex, Point); end; class procedure TGUITools.DrawDisabledImage(ACanvas: TCanvas; Imagelist: TImageList; ImageIndex: integer; Point: T2DIntVector; ClipRect: T2DIntRect); var UseOrgClipRgn: Boolean; OrgRgn: HRGN; ClipRgn: HRGN; DCStackPos : integer; begin // Store the original ClipRgn and set a new one SaveClipRgn(ACanvas.Handle, UseOrgClipRgn, OrgRgn); ClipRgn := CreateRectRgn(ClipRect.left, ClipRect.Top, ClipRect.Right+1, ClipRect.Bottom+1); if UseOrgClipRgn then CombineRgn(ClipRgn, ClipRgn, OrgRgn, RGN_AND); SelectClipRgn(ACanvas.Handle, ClipRgn); // Hack fixes the bug in ImageList.Draw which does not restore the previous one /??? // Font color for canvas DcStackPos := SaveDC(ACanvas.Handle); ImageList.Draw(ACanvas, Point.x, Point.y, ImageIndex, false); RestoreDC(ACanvas.Handle, DcStackPos); RestoreClipRgn(ACanvas.Handle, UseOrgClipRgn, OrgRgn); DeleteObject(ClipRgn); end; class procedure TGUITools.DrawDisabledImage(ACanvas: TCanvas; Imagelist: TImageList; ImageIndex: integer; Point: T2DIntVector); var DCStackPos : integer; begin //todo: see if is necessary to save the DC DcStackPos := SaveDC(ACanvas.Handle); ImageList.Draw(ACanvas, Point.x, Point.y, ImageIndex, false); RestoreDC(ACanvas.Handle, DcStackPos); end; class procedure TGUITools.DrawCheckbox(ACanvas:TCanvas; x,y: Integer; AState: TCheckboxState; AButtonState:TSpkButtonState; AStyle: TSpkCheckboxStyle; ClipRect:T2DIntRect); var UseOrgClipRgn: Boolean; OrgRgn: HRGN; ClipRgn: HRGN; begin SaveClipRgn(ACanvas.Handle, UseOrgClipRgn, OrgRgn); ClipRgn := CreateRectRgn(ClipRect.left, ClipRect.Top, ClipRect.Right+1, ClipRect.Bottom+1); if UseOrgClipRgn then CombineRgn(ClipRgn, ClipRgn, OrgRgn, RGN_AND); SelectClipRgn(ACanvas.Handle, ClipRgn); DrawCheckbox(ACanvas, x,y, AState, AButtonState, AStyle); RestoreClipRgn(ACanvas.Handle, UseOrgClipRgn, OrgRgn); DeleteObject(ClipRgn); end; class procedure TGUITools.DrawCheckbox(ACanvas: TCanvas; x,y: Integer; AState: TCheckboxState; AButtonState: TSpkButtonState; AStyle: TSpkCheckboxStyle); const NOT_USED = tbCheckboxCheckedNormal; const UNTHEMED_FLAGS: array [TSpkCheckboxStyle, TCheckboxState] of Integer = ( (DFCS_BUTTONCHECK, DFCS_BUTTONCHECK or DFCS_CHECKED, DFCS_BUTTONCHECK or DFCS_BUTTON3STATE), (DFCS_BUTTONRADIO, DFCS_BUTTONRADIO or DFCS_CHECKED, DFCS_BUTTONRADIO or DFCS_BUTTON3STATE) ); THEMED_FLAGS: array [TSpkCheckboxStyle, TCheckboxState, TSpkButtonState] of TThemedButton = ( ( (tbCheckboxUncheckedNormal, tbCheckboxUncheckedHot, tbCheckboxUncheckedPressed, tbCheckboxUncheckedDisabled, NOT_USED), (tbCheckboxCheckedNormal, tbCheckboxCheckedHot, tbCheckboxCheckedPressed, tbCheckboxCheckedDisabled, NOT_USED), (tbCheckboxMixedNormal, tbCheckboxMixedHot, tbCheckboxMixedPressed, tbCheckboxMixedDisabled, NOT_USED) ), ( (tbRadioButtonUncheckedNormal, tbRadioButtonUncheckedHot, tbRadioButtonUncheckedPressed, tbRadioButtonUncheckedDisabled, NOT_USED), (tbRadioButtonCheckedNormal, tbRadioButtonCheckedHot, tbRadioButtonCheckedPressed, tbRadioButtonCheckedDisabled, NOT_USED), (tbRadioButtonCheckedNormal, tbRadioButtonCheckedHot, tbRadioButtonCheckedPressed, tbRadioButtonCheckedDisabled, NOT_USED) ) ); var R: TRect; w: Integer; sz: TSize; te: TThemedElementDetails; begin if ThemeServices.ThemesEnabled then begin te := ThemeServices.GetElementDetails(THEMED_FLAGS[AStyle, AState, AButtonState]); sz := ThemeServices.GetDetailSize(te); R := Bounds(x, y, sz.cx, sz.cy); InflateRect(R, 1, 1); ThemeServices.DrawElement(ACanvas.Handle, te, R); end else begin w := GetSystemMetrics(SM_CYMENUCHECK); R := Bounds(x, y, w, w); DrawFrameControl( ACanvas.Handle, R, DFC_BUTTON, UNTHEMED_FLAGS[AStyle, AState]); end; end; end.