{********************************************************************} { } { Developer Express Visual Component Library } { Express Cross Platform Library graphics classes } { } { Copyright (c) 2000-2006 Developer Express Inc. } { ALL RIGHTS RESERVED } { } { The entire contents of this file is protected by U.S. and } { International Copyright Laws. Unauthorized reproduction, } { reverse-engineering, and distribution of all or any portion of } { the code contained in this file is strictly prohibited and may } { result in severe civil and criminal penalties and will be } { prosecuted to the maximum extent possible under the law. } { } { RESTRICTIONS } { } { THIS SOURCE CODE AND ALL RESULTING INTERMEDIATE FILES } { (DCU, OBJ, DLL, ETC.) ARE CONFIDENTIAL AND PROPRIETARY TRADE } { SECRETS OF DEVELOPER EXPRESS INC. THE REGISTERED DEVELOPER IS } { LICENSED TO DISTRIBUTE THE EXPRESSCROSSPLATFORMLIBRARY AND ALL } { ACCOMPANYING VCL CONTROLS AS PART OF AN EXECUTABLE PROGRAM } { ONLY. } { } { THE SOURCE CODE CONTAINED WITHIN THIS FILE AND ALL RELATED } { FILES OR ANY PORTION OF ITS CONTENTS SHALL AT NO TIME BE } { COPIED, TRANSFERRED, SOLD, DISTRIBUTED, OR OTHERWISE MADE } { AVAILABLE TO OTHER INDIVIDUALS WITHOUT EXPRESS WRITTEN CONSENT } { AND PERMISSION FROM DEVELOPER EXPRESS INC. } { } { CONSULT THE END USER LICENSE AGREEMENT FOR INFORMATION ON } { ADDITIONAL RESTRICTIONS. } { } {********************************************************************} unit cxGraphics; {$I cxVer.inc} interface uses {$IFDEF DELPHI6} Types, {$ENDIF} {$IFDEF VCL} Windows, {$ELSE} Qt, {$ENDIF} {$IFDEF CLR} System.Runtime.InteropServices, {$ENDIF} Classes, SysUtils, Controls, Graphics, ImgList, cxClasses; const cxAlignLeft = 1; cxAlignRight = 2; cxAlignHCenter = 4; cxAlignTop = 8; cxAlignBottom = 16; cxAlignVCenter = 32; cxAlignCenter = 36; cxSingleLine = 64; cxDontClip = 128; cxExpandTabs = 256; cxShowPrefix = 512; cxWordBreak = 1024; cxShowEndEllipsis = 2048; cxDontPrint = 4096; cxShowPathEllipsis = 8192; cxDontBreakChars = 16384; {$IFNDEF DELPHI6} clMoneyGreen = TColor($C0DCC0); clSkyBlue = TColor($F0CAA6); clCream = TColor($F0FBFF); clMedGray = TColor($A4A0A0); {$ENDIF} clcxLightGray = $CFCFCF; cxEmptyRect: TRect = (Left: 0; Top: 0; Right: 0; Bottom: 0); cxDesignSelectionWidth = 2; cxDefaultAlphaValue = 200; {$IFNDEF CLR} cxHalfToneBrush: TBrush = nil; {$ENDIF} type IcxFontListener = interface ['{B144DD7E-0B27-439A-B908-FC3ACFE6A2D3}'] procedure Changed(Sender: TObject; AFont: TFont); end; TcxBorder = (bLeft, bTop, bRight, bBottom); TcxBorders = set of TcxBorder; const cxBordersAll = [bLeft, bTop, bRight, bBottom]; type TBrushHandle = {$IFDEF VCL}HBRUSH{$ELSE}QBrushH{$ENDIF}; TPointArray = array of TPoint; TRectArray = array of TRect; TcxColorPart = -100..100; TcxGridLines = (glBoth, glNone, glVertical, glHorizontal); PcxViewParams = ^TcxViewParams; TcxViewParams = record Bitmap: TBitmap; Color: TColor; Font: TFont; TextColor: TColor; end; { TcxRegion } TcxRegionHandle = {$IFDEF VCL}HRGN{$ELSE}QRegionH{$ENDIF}; TcxRegionOperation = (roSet, roAdd, roSubtract, roIntersect); TcxRegion = class {6} private FHandle: TcxRegionHandle; function GetIsEmpty: Boolean; protected procedure DestroyHandle; public constructor Create(AHandle: TcxRegionHandle); overload; constructor Create(const ABounds: TRect); overload; constructor Create; overload; constructor Create(ALeft, ATop, ARight, ABottom: Integer); overload; destructor Destroy; override; procedure Combine(ARegion: TcxRegion; AOperation: TcxRegionOperation; ADestroyRegion: Boolean = True); function IsEqual(ARegion: TcxRegion): Boolean; overload; function IsEqual(ARegionHandle: TcxRegionHandle): Boolean; overload; procedure Offset(DX, DY: Integer); function PtInRegion(const Pt: TPoint): Boolean; overload; function PtInRegion(X, Y: Integer): Boolean; overload; function RectInRegion(const R: TRect): Boolean; overload; function RectInRegion(ALeft, ATop, ARight, ABottom: Integer): Boolean; overload; property Handle: TcxRegionHandle read FHandle write FHandle; property IsEmpty: Boolean read GetIsEmpty; end; { TcxCanvas } TcxRotationAngle = (ra0, raPlus90, raMinus90{$IFDEF VCL}, ra180{$ENDIF}); TcxCanvas = class private FCanvas: TCanvas; function GetBrush: TBrush; function GetCopyMode: TCopyMode; function GetDCOrigin: TPoint; function GetFont: TFont; function GetHandle: {$IFDEF VCL}HDC{$ELSE}QPainterH{$ENDIF}; function GetPen: TPen; function GetViewportOrg: TPoint; function GetWindowOrg: TPoint; procedure SetBrush(Value: TBrush); procedure SetCopyMode(Value: TCopyMode); procedure SetFont(Value: TFont); procedure SetPen(Value: TPen); procedure SetPixel(X, Y: Integer; Value: TColor); procedure SetViewportOrg(const P: TPoint); procedure SetWindowOrg(const P: TPoint); public constructor Create(ACanvas: TCanvas); virtual; procedure AlignMultiLineTextRectVertically(var R: TRect; const AText: string; AAlignmentVert: TcxAlignmentVert; AWordBreak, AShowPrefix: Boolean; AEnabled: Boolean = True; ADontBreakChars: Boolean = False); procedure CopyRect(const Dest: TRect; ACanvas: TCanvas; const Source: TRect); procedure Draw(X, Y: Integer; Graphic: TGraphic); procedure DrawComplexFrame(const R: TRect; ALeftTopColor, ARightBottomColor: TColor; ABorders: TcxBorders = [bLeft, bTop, bRight, bBottom]; ABorderWidth: Integer = 1); procedure DrawEdge(const R: TRect; ASunken, AOuter: Boolean; ABorders: TcxBorders = [bLeft, bTop, bRight, bBottom]); procedure DrawFocusRect(const R: TRect); procedure DrawGlyph(X, Y: Integer; AGlyph: TBitmap; AEnabled: Boolean = True; ABackgroundColor: TColor = clNone{; ATempCanvas: TCanvas = nil}); procedure DrawImage(Images: TCustomImageList; X, Y, Index: Integer; Enabled: Boolean = True); procedure DrawTexT(const Text: string; R: TRect; Flags: Integer; Enabled: Boolean = True); procedure FillRect(const R: TRect; ABitmap: TBitmap = nil; AExcludeRect: Boolean = False); overload; procedure FillRect(R: TRect; const AParams: TcxViewParams; ABorders: TcxBorders = []; ABorderColor: TColor = clDefault; ALineWidth: Integer = 1; AExcludeRect: Boolean = False); overload; {$IFDEF LINUX} procedure FillRect(const R: TRect; ABrush: TBrush); overload; {$ENDIF} {$IFNDEF LINUX} procedure DrawDesignSelection(ARect: TRect; AWidth: Integer = cxDesignSelectionWidth); procedure DrawRegion(ARegion: TcxRegion; AContentColor: TColor = clDefault; ABorderColor: TColor = clDefault; ABorderWidth: Integer = 1; ABorderHeight: Integer = 1); overload; procedure DrawRegion(ARegion: TcxRegionHandle; AContentColor: TColor = clDefault; ABorderColor: TColor = clDefault; ABorderWidth: Integer = 1; ABorderHeight: Integer = 1); overload; procedure FillRegion(ARegion: TcxRegion; AColor: TColor = clDefault); overload; procedure FillRegion(ARegion: TcxRegionHandle; AColor: TColor = clDefault); overload; procedure FlipHorizontally(ABitmap: TBitmap); procedure FrameRegion(ARegion: TcxRegion; AColor: TColor = clDefault; ABorderWidth: Integer = 1; ABorderHeight: Integer = 1); overload; procedure FrameRegion(ARegion: TcxRegionHandle; AColor: TColor = clDefault; ABorderWidth: Integer = 1; ABorderHeight: Integer = 1); overload; procedure Pie(const R: TRect; const ARadial1, ARadial2: TPoint); overload; procedure Pie(const R: TRect; AStartAngle, ASweepAngle: Integer); overload; {$ENDIF} function FontHeight(AFont: TFont): Integer; procedure FrameRect(const R: TRect; Color: TColor = clDefault; ALineWidth: Integer = 1; ABorders: TcxBorders = cxBordersAll; AExcludeFrame: Boolean = False); procedure InvertFrame(const R: TRect; ABorderSize: Integer); procedure InvertRect({$IFNDEF LINUX}const {$ENDIF}R: TRect); procedure LineTo(X, Y: Integer); procedure MoveTo(X, Y: Integer); procedure Polygon(const Points: array of TPoint); procedure Polyline(const Points: array of TPoint); procedure RotateBitmap(ABitmap: TBitmap; ARotationAngle: TcxRotationAngle; AFlipVertically: Boolean = False); function TextExtent(const Text: string): TSize; overload; procedure TextExtent(const Text: string; var R: TRect; Flags: Integer); overload; function TextHeight(const Text: string): Integer; function TextWidth(const Text: string): Integer; procedure TransparentDraw(X, Y: Integer; ABitmap: TBitmap; AAlpha: Byte; ABackground: TBitmap = nil); procedure GetParams(var AParams: TcxViewParams); procedure SetParams(AParams: TcxViewParams); procedure SetBrushColor(Value: TColor); procedure SetFontAngle(Value: Integer); {$IFDEF VCL} procedure GetTextStringsBounds(Text: string; R: TRect; Flags: Integer; Enabled: Boolean; var ABounds: TRectArray); {$ENDIF} {$IFNDEF LINUX} procedure BeginPath; procedure EndPath; function PathToRegion: TcxRegion; procedure WidenPath; {$ENDIF} // clipping procedure ExcludeClipRect(const R: TRect); procedure IntersectClipRect(const R: TRect); function GetClipRegion(AConsiderOrigin: Boolean = True): TcxRegion; procedure SetClipRegion(ARegion: TcxRegion; AOperation: TcxRegionOperation; ADestroyRegion: Boolean = True; AConsiderOrigin: Boolean = True); function RectFullyVisible(const R: TRect): Boolean; function RectVisible({$IFDEF VCL}const {$ENDIF}R: TRect): Boolean; property Brush: TBrush read GetBrush write SetBrush; property Canvas: TCanvas read FCanvas write FCanvas; property CopyMode: TCopyMode read GetCopyMode write SetCopyMode; property DCOrigin: TPoint read GetDCOrigin; property Font: TFont read GetFont write SetFont; property Handle: {$IFDEF VCL}HDC{$ELSE}QPainterH{$ENDIF} read GetHandle; property Pen: TPen read GetPen write SetPen; property Pixels[X, Y: Integer]: TColor write SetPixel; property ViewportOrg: TPoint read GetViewportOrg write SetViewportOrg; property WindowOrg: TPoint read GetWindowOrg write SetWindowOrg; end; { TcxScreenCanvas } TcxScreenCanvas = class(TcxCanvas) public constructor Create; reintroduce; virtual; destructor Destroy; override; end; { TcxBitmap } TcxBitmap = class(TBitmap) public procedure Assign(Source: TPersistent); override; end; TRGBColors = array of TRGBQuad; {$IFNDEF CLR} { TcxBrushCache } TcxBrushData = record Brush: TBrush; Color: TColor; RefCount: Integer; end; TcxBrushesData = array of TcxBrushData; EBrushCache = class(Exception); TcxBrushCache = class private FCapacity: Integer; FCount: Integer; FData: TcxBrushesData; FDeletedCount: Integer; FLockRef: Integer; protected function Add(AColor: TColor): TBrush; function AddItemAt(AIndex: Integer; AColor: TColor): TBrush; procedure CacheCheck(Value: Boolean; const AMessage: string); procedure Delete(AIndex: Integer); function IndexOf(AColor: TColor; out AIndex: Integer): Boolean; procedure InitItem(var AItem: TcxBrushData; AColor: TColor); function IsSystemBrush(ABrush: TBrush): Boolean; function FindNearestItem(AColor: TColor): Integer; procedure Move(ASrc, ADst, ACount: Integer); procedure Pack; procedure Recreate; procedure Release(AIndex: Integer); public destructor Destroy; override; procedure BeginUpdate; procedure EndUpdate; procedure ReleaseBrush(var ABrush: TBrush); procedure SetBrushColor(var ABrush: TBrush; AColor: TColor); end; {$ENDIF} function cxFlagsToDTFlags(Flags: Integer): Integer; procedure ExtendRect(var Rect: TRect; const AExtension: TRect); function GetRealColor(AColor: TColor): TColor; // light colors function GetLightColor(ABtnFaceColorPart, AHighlightColorPart, AWindowColorPart: TcxColorPart): TColor; function GetLightBtnFaceColor: TColor; function GetLightDownedColor: TColor; function GetLightDownedSelColor: TColor; function GetLightSelColor: TColor; {!!! TODO: adapt to .net} {$IFNDEF CLR} procedure cxSmoothResizeBitmap(ASource, ADestination: TBitmap; AForceUseLanczos3Filter: Boolean = False); // mouse cursor size function cxGetCursorSize: TSize; // image helper routines procedure cxAlphaBlend(ASource: TBitmap; ARect: TRect; const ASelColor: TColor; Alpha: Byte = 170); overload; procedure cxAlphaBlend(ADest, ABkSource, ASource: TBitmap; Alpha: Byte = cxDefaultAlphaValue); overload; procedure cxAlphaBlend(ADestBitmap, ASrcBitmap: TBitmap; const ADestRect, ASrcRect: TRect; AConstantAlpha: Byte = $FF); overload; procedure cxAlphaBlend(ADestDC: HDC; ASrcBitmap: TBitmap; const ADestRect, ASrcRect: TRect; AConstantAlpha: Byte = $FF); overload; procedure cxApplyViewParams(ACanvas: TcxCanvas; const AViewParams: TcxViewParams); procedure cxBlendFunction(const ASource: TRGBQuad; var ADest: TRGBQuad; ASourceConstantAlpha: Byte); function cxCreateBitmap(const ASize: TSize; AFormat: TPixelFormat = pf24bit): TBitmap; overload; function cxCreateBitmap(AWidth, AHeight: Integer; AFormat: TPixelFormat = pf24bit): TBitmap; overload; function cxCreateTrueColorBitmap(const ASize: TSize): TBitmap; overload; function cxCreateTrueColorBitmap(AWidth, AHeight: Integer): TBitmap; overload; function cxCreateTrueColorBitmapHandle(AWidth, AHeight: Integer; ABPP: Integer = 32): HBitmap; procedure cxCopyImage(ASource, ADest: TBitmap; const ASrcOffset, ADstOffset: TPoint; const ARect: TRect); overload; procedure cxCopyImage(ASource, ADest: TCanvas; const ASrcOffset, ADstOffset: TPoint; const ARect: TRect); overload; procedure cxDrawArrows(ACanvas: TCanvas; const ARect: TRect; ASide: TcxBorder; AColor: TColor; APenColor: TColor = clDefault); procedure cxFillHalfToneRect(Canvas: TCanvas; const ARect: TRect; ABkColor, AColor: TColor); procedure cxSetCanvasOrg(ACanvas: TCanvas; var AOrg: TRect); function cxTextHeight(AFont: TFont; const S: string = 'Wg'; AFontSize: Integer = 0): Integer; function cxTextExtent(AFont: TFont; const S: string; AFontSize: Integer = 0): TSize; function cxTextWidth(AFont: TFont; const S: string; AFontSize: Integer = 0): Integer; {$ENDIF} function cxDrawText(ADC: HDC; const AText: string; var ARect: TRect; AFormat: UINT; ACharCount: Integer = - 1): Integer; function cxTextSize(ADC: HDC; const AText: string): TSize; function cxGetTextRect(ADC: HDC; const AText: string; ARowCount: Integer; AReturnMaxRectHeight: Boolean = False): TRect; overload; function cxGetTextRect(AFont: TFont; const AText: string; ARowCount: Integer): TRect; overload; function cxGetWritingDirection(AFontCharset: TFontCharset; const AText: string): TCanvasOrientation; procedure cxDrawThemeParentBackground(AControl: TWinControl; ACanvas: TcxCanvas; const ARect: TRect); overload; procedure cxDrawThemeParentBackground(AControl: TWinControl; ACanvas: TCanvas; const ARect: TRect); overload; procedure cxDrawTransparentControlBackground(AControl: TWinControl; ACanvas: TcxCanvas; ARect: TRect; APaintParentWithChildren: Boolean = True); overload; procedure cxDrawTransparentControlBackground(AControl: TWinControl; ACanvas: TCanvas; const ARect: TRect; APaintParentWithChildren: Boolean = True); overload; function cxScreenCanvas: TcxScreenCanvas; {$IFDEF CLR} [DllImport(gdi32, CharSet = CharSet.Ansi, SetLastError = True, EntryPoint = 'GetDIBits')] function GetDIBits(DC: HDC; Bitmap: HBitmap; StartScan, NumScans: UINT; [out] Bits: TRGBColors; var BitsInfo: TBitmapInfo; Usage: UINT): Integer; external; [DllImport(gdi32, CharSet = CharSet.Ansi, SetLastError = True, EntryPoint = 'SetDIBits')] function SetDIBits(DC: HDC; Bitmap: HBITMAP; StartScan, NumScans: UINT; [in] Bits: TRGBColors; const BitsInfo: TBitmapInfo; Usage: UINT): Integer; external; {$ENDIF} implementation uses Messages, Math, Menus, cxControls, cxGeometry, dxUxTheme; type TCanvasAccess = class(TCanvas); {!!! TODO: adapt to .net} {$IFNDEF CLR} PContributor = ^TContributor; TContributor = record Pixel: Integer; Weight: Integer; end; TContributorArray = array of TContributor; TContributors = record Count: Integer; Contributors: TContributorArray; end; TContributorList = array of TContributors; const BaseRgns: array[0..3, 0..6, 0..1] of Integer = (((0, -1), (-5, -6),(-2, -6), (-2, -9), (2, -9), (2, -6), (5, -6)), ((0, 0), (5, 5), (2, 5), (2, 8), (-2, 8), (-2, 5), (-5, 5)), ((-1, 0), (-6, -5), (-6, -2), (-9, -2), (-9, 2), (-6, 2), (-6, 5)), ((0, 0), (5, 5), (5, 2), (8, 2), (8, -2), (5, -2), (5, -5))); {$ENDIF} const DefaultBlendFunction: TBlendFunction = (BlendOp: AC_SRC_OVER; BlendFlags: 0; SourceConstantAlpha: cxDefaultAlphaValue; AlphaFormat: $0); var VCLAlphaBlend: {$IFNDEF CLR}function(DC: LongWord; p2, p3, p4, p5: Integer; DC6: LongWord; p7, p8, p9, p10: Integer; p11: TBlendFunction): BOOL; stdcall;{$ELSE}FARPROC;{$ENDIF} ScreenCanvas: TcxScreenCanvas = nil; function cxFlagsToDTFlags(Flags: Integer): Integer; begin Result := DT_NOPREFIX; if cxAlignLeft and Flags <> 0 then Result := Result or DT_LEFT; if cxAlignRight and Flags <> 0 then Result := Result or DT_RIGHT; if cxAlignHCenter and Flags <> 0 then Result := Result or DT_CENTER; if cxAlignTop and Flags <> 0 then Result := Result or DT_TOP; if cxAlignBottom and Flags <> 0 then Result := Result or DT_BOTTOM; if cxAlignVCenter and Flags <> 0 then Result := Result or DT_VCENTER; if cxSingleLine and Flags <> 0 then Result := Result or DT_SINGLELINE; if cxDontClip and Flags <> 0 then Result := Result or DT_NOCLIP; if cxExpandTabs and Flags <> 0 then Result := Result or DT_EXPANDTABS; if cxShowPrefix and Flags <> 0 then Result := Result and not DT_NOPREFIX; if cxWordBreak and Flags <> 0 then begin Result := Result or DT_WORDBREAK; if cxDontBreakChars and Flags = 0 then Result := Result or DT_EDITCONTROL; end; if cxShowEndEllipsis and Flags <> 0 then Result := Result or DT_END_ELLIPSIS; if cxDontPrint and Flags <> 0 then Result := Result or DT_CALCRECT; if cxShowPathEllipsis and Flags <> 0 then Result := Result or DT_PATH_ELLIPSIS; end; procedure ExtendRect(var Rect: TRect; const AExtension: TRect); begin with AExtension do begin Inc(Rect.Left, Left); Inc(Rect.Top, Top); Dec(Rect.Right, Right); Dec(Rect.Bottom, Bottom); end; end; function GetRealColor(AColor: TColor): TColor; {$IFDEF VCL} var DC: HDC; begin DC := GetDC(0); Result := GetNearestColor(DC, AColor); ReleaseDC(0, DC); end; {$ELSE} begin Result := AColor; end; {$ENDIF} function GetLightColor(ABtnFaceColorPart, AHighlightColorPart, AWindowColorPart: TcxColorPart): TColor; var ABtnFaceColor, AHighlightColor, AWindowColor: TColor; function GetLightIndex(ABtnFaceValue, AHighlightValue, AWindowValue: Byte): Integer; begin Result := MulDiv(ABtnFaceValue, ABtnFaceColorPart, 100) + MulDiv(AHighlightValue, AHighlightColorPart, 100) + MulDiv(AWindowValue, AWindowColorPart, 100); if Result < 0 then Result := 0; if Result > 255 then Result := 255; end; begin ABtnFaceColor := ColorToRGB(clBtnFace); AHighlightColor := ColorToRGB(clHighlight); AWindowColor := ColorToRGB(clWindow); if (ABtnFaceColor = 0) or (ABtnFaceColor = $FFFFFF) then Result := AHighlightColor else Result := RGB( GetLightIndex(GetRValue(ABtnFaceColor), GetRValue(AHighlightColor), GetRValue(AWindowColor)), GetLightIndex(GetGValue(ABtnFaceColor), GetGValue(AHighlightColor), GetGValue(AWindowColor)), GetLightIndex(GetBValue(ABtnFaceColor), GetBValue(AHighlightColor), GetBValue(AWindowColor))); end; function GetLightBtnFaceColor: TColor; function GetLightValue(Value: Byte): Byte; begin Result := Value + MulDiv(255 - Value, 16, 100); end; begin Result := ColorToRGB(clBtnFace); Result := RGB( GetLightValue(GetRValue(Result)), GetLightValue(GetGValue(Result)), GetLightValue(GetBValue(Result))); Result := GetRealColor(Result); end; function GetLightDownedColor: TColor; begin Result := GetRealColor(GetLightColor(11, 9, 73)); end; function GetLightDownedSelColor: TColor; begin Result := GetRealColor(GetLightColor(14, 44, 40)); end; function GetLightSelColor: TColor; begin Result := GetRealColor(GetLightColor(-2, 30, 72)); end; procedure FillBitmapInfoHeader(out AHeader: TBitmapInfoHeader; ABitmap: TBitmap; ATopDownDIB: Boolean); begin AHeader.biSize := SizeOf(TBitmapInfoHeader); AHeader.biWidth := ABitmap.Width; if ATopDownDIB then AHeader.biHeight := -ABitmap.Height else AHeader.biHeight := ABitmap.Height; AHeader.biPlanes := 1; AHeader.biBitCount := 32; AHeader.biCompression := BI_RGB; end; function GetBitmapBits(ABitmap: TBitmap; ATopDownDIB: Boolean): TRGBColors; var AInfo: TBitmapInfo; begin SetLength(Result, ABitmap.Width * ABitmap.Height); FillBitmapInfoHeader(AInfo.bmiHeader, ABitmap, ATopDownDIB); // GetDIBits(ABitmap.Canvas.Handle, ABitmap.Handle, 0, ABitmap.Height, nil, AInfo, // DIB_RGB_COLORS); GetDIBits(cxScreenCanvas.Handle, ABitmap.Handle, 0, ABitmap.Height, Result, AInfo, DIB_RGB_COLORS); end; procedure SetBitmapBits(ABitmap: TBitmap; var AColors: TRGBColors; ATopDownDIB: Boolean); var AInfo: TBitmapInfo; begin FillBitmapInfoHeader(AInfo.bmiHeader, ABitmap, ATopDownDIB); SetDIBits(cxScreenCanvas.Handle, ABitmap.Handle, 0, ABitmap.Height, AColors, AInfo, DIB_RGB_COLORS); AColors := nil; end; {!!! TODO: adapt to .net} {$IFNDEF CLR} function Lanczos3Filter(Value: Single): Single; function SinC(Value: Single): Single; begin if (Value <> 0.0) then begin Value := Value * PI; Result := Sin(Value) / Value end else Result := 1.0; end; begin if (Value < 0.0) then Value := -Value; if (Value < 3.0) then Result := SinC(Value) * SinC(Value / 3.0) else Result := 0.0; end; procedure BuildFilter(out AContributorList: TContributorList; AScale: Single; ASrcSize, ADestSize: Integer); var I, J, APixel, AMaxContributors, AWeight: Integer; ACenter, ARadius, AScaleFactor: Single; begin SetLength(AContributorList, ADestSize); if AScale < 1.0 then AScaleFactor := 1.0 / AScale else AScaleFactor := 1.0; ARadius := 3 * AScaleFactor; AMaxContributors := Trunc(ARadius * 2.0 + 1); for I := 0 to ADestSize - 1 do with AContributorList[I] do begin SetLength(Contributors, AMaxContributors); Count := 0; ACenter := I / AScale; for J := Floor(ACenter - ARadius) to Ceil(ACenter + ARadius) do begin AWeight := Round(Lanczos3Filter((ACenter - J) / AScaleFactor) / AScaleFactor * 256); if AWeight = 0 then continue; if J < 0 then APixel := -J else if (J >= ASrcSize) then APixel := ASrcSize - J + ASrcSize - 1 else APixel := J; Contributors[Count].Pixel := APixel; Contributors[Count].Weight := AWeight; Inc(Count); end; end; end; procedure ApplyFilter(var AContributorList: TContributorList; var ASource: TRGBColors; ASrcSize, ASrcLineLength: Integer; var ADest: TRGBColors; ADestSize, ADestLineLength: Integer; AHorizontal: Boolean); function GetColorPart(Value: Integer): Integer; begin if Value < 0 then Result := 0 else begin Value := Value shr 8; if Value > 255 then Result := 255 else Result := Value; end; end; var AWeight: Integer; AColor: TRGBQuad; R, G, B: Integer; K, I, J: Integer; AContributor: PContributor; begin for I := 0 to ASrcSize - 1 do for J := 0 to ADestSize - 1 do with AContributorList[J] do begin R := 0; G := 0; B := 0; AContributor := @Contributors[0]; for K := 0 to Count - 1 do begin with AContributor^ do begin if AHorizontal then AColor := ASource[Pixel + (I * ASrcLineLength)] else AColor := ASource[I + (Pixel * ASrcLineLength)]; AWeight := Weight; if AWeight = 0 then continue; Inc(R, AColor.rgbRed * AWeight); Inc(G, AColor.rgbGreen * AWeight); Inc(B, AColor.rgbBlue * AWeight); end; Inc(AContributor); end; AColor.rgbRed := GetColorPart(R); AColor.rgbGreen := GetColorPart(G); AColor.rgbBlue := GetColorPart(B); AColor.rgbReserved := 0; if AHorizontal then ADest[J + (I * ADestLineLength)] := AColor else ADest[I + (J * ADestLineLength)] := AColor; end; //dispose contributors and source buffer for I := 0 to HIGH(AContributorList) do AContributorList[I].Contributors := nil; AContributorList := nil; ASource := nil; end; procedure cxSmoothResizeBitmap(ASource, ADestination: TBitmap; AForceUseLanczos3Filter: Boolean = False); var AContributorList: TContributorList; ASrcWidth, ASrcHeight, ADestWidth, ADestHeight: Integer; ABuffer1, ABuffer2: TRGBColors; AOldMode: Cardinal; AScale: Single; begin ADestWidth := ADestination.Width; ADestHeight := ADestination.Height; ASrcWidth := ASource.Width; ASrcHeight := ASource.Height; if (ADestWidth = 0) or (ADestHeight = 0) or (ASrcWidth = 0) or (ASrcHeight = 0) then Exit; ASource.Canvas.Lock; ADestination.Canvas.Lock; try if IsWinNT and not AForceUseLanczos3Filter then begin AOldMode := SetStretchBltMode(ADestination.Canvas.Handle, HALFTONE); StretchBlt(ADestination.Canvas.Handle, 0, 0, ADestWidth, ADestHeight, ASource.Canvas.Handle, 0, 0, ASrcWidth, ASrcHeight, srcCopy); SetStretchBltMode(ADestination.Canvas.Handle, AOldMode); end else begin ABuffer1 := GetBitmapBits(ASource, False); SetLength(ABuffer2, ADestWidth * ASrcHeight); if ASrcWidth = 1 then AScale := ADestWidth / ASrcWidth else AScale := (ADestWidth - 1) / (ASrcWidth - 1); BuildFilter(AContributorList, AScale, ASrcWidth, ADestWidth); ApplyFilter(AContributorList, ABuffer1, ASrcHeight, ASrcWidth, ABuffer2, ADestWidth, ADestWidth, True); ABuffer1 := GetBitmapBits(ADestination, False); if (ASrcHeight = 1) or (ADestHeight = 1) then AScale := ADestHeight / ASrcHeight else AScale := (ADestHeight - 1) / (ASrcHeight - 1); BuildFilter(AContributorList, AScale, ASrcHeight, ADestHeight); ApplyFilter(AContributorList, ABuffer2, ADestWidth, ADestWidth, ABuffer1, ADestHeight, ADestWidth, False); SetBitmapBits(ADestination, ABuffer1, False); end; finally ASource.Canvas.Unlock; ADestination.Canvas.Unlock; end; end; function cxGetCursorSize: TSize; var IconInfo: TIconInfo; BitmapInfoSize, BitmapBitsSize, ImageSize: DWORD; Bitmap: PBitmapInfoHeader; Bits: Pointer; BytesPerScanline: Integer; function FindScanline(Source: Pointer; MaxLen: Cardinal; Value: Cardinal): Cardinal; assembler; asm PUSH ECX MOV ECX,EDX MOV EDX,EDI MOV EDI,EAX POP EAX REPE SCASB MOV EAX,ECX MOV EDI,EDX end; begin { Default value is entire icon height } Result.cy := GetSystemMetrics(SM_CYCURSOR); Result.cx := GetSystemMetrics(SM_CXCURSOR); if GetIconInfo(GetCursor, IconInfo) then try GetDIBSizes(IconInfo.hbmMask, BitmapInfoSize, BitmapBitsSize); Bitmap := AllocMem(DWORD(BitmapInfoSize) + BitmapBitsSize); try Bits := Pointer(DWORD(Bitmap) + BitmapInfoSize); if GetDIB(IconInfo.hbmMask, 0, Bitmap^, Bits^) and (Bitmap^.biBitCount = 1) then begin { Point Bits to the end of this bottom-up bitmap } with Bitmap^ do begin Result.cx := biWidth; BytesPerScanline := ((biWidth * biBitCount + 31) and not 31) div 8; ImageSize := biWidth * BytesPerScanline; Bits := Pointer(DWORD(Bits) + BitmapBitsSize - ImageSize); { Use the width to determine the height since another mask bitmap may immediately follow } Result.cy := FindScanline(Bits, ImageSize, $FF); { In case the and mask is blank, look for an empty scanline in the xor mask. } if (Result.cy = 0) and (biHeight >= 2 * biWidth) then Result.cy := FindScanline(Pointer(DWORD(Bits) - ImageSize), ImageSize, $00); Result.cy := Result.cy div BytesPerScanline; end; Dec(Result.cy, IconInfo.yHotSpot); end; finally FreeMem(Bitmap, BitmapInfoSize + BitmapBitsSize); end; finally if IconInfo.hbmColor <> 0 then DeleteObject(IconInfo.hbmColor); if IconInfo.hbmMask <> 0 then DeleteObject(IconInfo.hbmMask); end; end; procedure cxAlphaBlend(ASource: TBitmap; ARect: TRect; const ASelColor: TColor; Alpha: Byte = 170); var ARow, ACol: Integer; SrcLine: Pointer; C1, C2: Double; AColorValues: array[0..3] of Byte; P: TPoint; begin C1 := Alpha / 255; C2 := 1.0 - C1; AColorValues[0] := Round(GetBValue(ASelColor) * C1); AColorValues[1] := Round(GetGValue(ASelColor) * C1); AColorValues[2] := Round(GetRValue(ASelColor) * C1); AColorValues[3] := 0; GetWindowOrgEx(ASource.Canvas.Handle, P); OffsetRect(ARect, -P.X, -P.Y); for ARow := Max(ARect.Top, 0) to Min(ARect.Bottom, ASource.Height - 1) do begin SrcLine := ASource.ScanLine[ARow]; ACol := Max(0, ARect.Left * 4); while ACol < Min(ARect.Right * 4, ASource.Width * 4 - 1) do begin WriteToMemory(SrcLine, ACol, AColorValues[ACol mod 4] + Round(ReadFromMemory(SrcLine, ACol) * C2)); Inc(ACol); end; end; end; procedure cxAlphaBlend( ADest, ABkSource, ASource: TBitmap; Alpha: Byte = cxDefaultAlphaValue); function SystemAlphaPaint: Boolean; {$IFDEF VCL} var ABlendFunction: TBlendFunction; {$ENDIF} begin {$IFDEF VCL} if not Assigned(VCLAlphaBlend) then begin Result := False; Exit; end; ABlendFunction := DefaultBlendFunction; ABlendFunction.SourceConstantAlpha := Alpha; with ADest do begin Canvas.Draw(0, 0, ABkSource); // Assign(ABkSource); todo: graphics bug image not copying but _AddRef called Result := {$IFDEF CLR}AlphaBlend{$ELSE}VCLAlphaBlend{$ENDIF}(Canvas.Handle, 0, 0, Width, Height, ASource.Canvas.Handle, 0, 0, Width, Height, ABlendFunction); end; {$ELSE} Result := False; {$ENDIF} end; procedure AlphaPaint; var ACount, K: Integer; DstLine, BkSrcLine, SrcLine: Pointer; C1, C2: Double; begin C1 := Alpha / 255; C2 := 1.0 - C1; with ASource do begin K := Height; ACount := ((Width * 24 + 31) and not 31) shr 3 * K; end; BkSrcLine := ABkSource.ScanLine[K - 1]; SrcLine := ASource.ScanLine[K - 1]; DstLine := ADest.ScanLine[K - 1]; for K := 0 to ACount - 1 do WriteToMemory(DstLine, K, Round(ReadFromMemory(SrcLine, K) * C1) + Round(ReadFromMemory(BkSrcLine, K) * C2)); end; procedure DoAlphaPaint; begin {$IFDEF VCL} if GetDeviceCaps(cxScreenCanvas.Handle, BITSPIXEL) in [16, 24, 32] then {$ELSE} //TODO if False then {$ENDIF} AlphaPaint else ADest.Canvas.Draw(0, 0, ASource); // .Assign(ASource); end; begin if not SystemAlphaPaint then DoAlphaPaint; end; procedure CommonAlphaBlend(ADestBitmap, ASrcBitmap: TBitmap; ADestDC: HDC; const ADestRect, ASrcRect: TRect; AConstantAlpha: Byte = $FF); procedure SystemAlphaBlend(ADestDC, ASrcDC: HDC; ADestLeft, ADestTop, ADestWidth, ADestHeight, ASrcLeft, ASrcTop, ASrcWidth, ASrcHeight: Integer; AConstantAlpha: Byte); {$IFNDEF DELPHI6} const AC_SRC_ALPHA = 1; {$ENDIF} var ABlendFunction: TBlendFunction; begin ABlendFunction.BlendOp := AC_SRC_OVER; ABlendFunction.BlendFlags := 0; ABlendFunction.SourceConstantAlpha := AConstantAlpha; ABlendFunction.AlphaFormat := AC_SRC_ALPHA; {$IFDEF CLR}AlphaBlend{$ELSE}VCLAlphaBlend{$ENDIF}(ADestDC, ADestLeft, ADestTop, ADestWidth, ADestHeight, ASrcDC, ASrcLeft, ASrcTop, ASrcWidth, ASrcHeight, ABlendFunction); end; procedure SoftwareAlphaBlend(ADestBitmap, ASrcBitmap: TBitmap; ADestLeft, ADestTop, ADestWidth, ADestHeight, ASrcLeft, ASrcTop, ASrcWidth, ASrcHeight: Integer; AConstantAlpha: Byte); function GetStretchedBitmap(AWidth, AHeight: Integer): TBitmap; begin Result := cxCreateBitmap(AWidth, AHeight, pf32bit); Result.Canvas.Brush.Color := 0; Result.Canvas.FillRect(Rect(0, 0, AWidth, AHeight)); StretchBlt(Result.Canvas.Handle, ADestLeft, ADestTop, ADestWidth, ADestHeight, ASrcBitmap.Canvas.Handle, ASrcLeft, ASrcTop, ASrcWidth, ASrcHeight, SRCCOPY); end; var ASourceColors, ADestColors: TRGBColors; I, J, K: Integer; AWidth, AHeight: Integer; AStretchedBitmap: TBitmap; begin AWidth := ADestBitmap.Width; AHeight := ADestBitmap.Height; AStretchedBitmap := GetStretchedBitmap(AWidth, AHeight); try ASourceColors := GetBitmapBits(AStretchedBitmap, False); ADestColors := GetBitmapBits(ADestBitmap, False); for I := 0 to AWidth - 1 do for J := 0 to AHeight - 1 do begin K := J * AWidth + I; cxBlendFunction(ASourceColors[K], ADestColors[K], AConstantAlpha); end; SetBitmapBits(ADestBitmap, ADestColors, False); finally AStretchedBitmap.Free; end; end; var DC: HDC; ADestWidth, ADestHeight: Integer; begin ADestWidth := ADestRect.Right - ADestRect.Left; ADestHeight := ADestRect.Bottom - ADestRect.Top; if Assigned(VCLAlphaBlend) then begin if ADestBitmap <> nil then DC := ADestBitmap.Canvas.Handle else DC := ADestDC; SystemAlphaBlend(DC, ASrcBitmap.Canvas.Handle, ADestRect.Left, ADestRect.Top, ADestWidth, ADestHeight, ASrcRect.Left, ASrcRect.Top, ASrcRect.Right - ASrcRect.Left, ASrcRect.Bottom - ASrcRect.Top, AConstantAlpha); end else begin if ADestBitmap <> nil then SoftwareAlphaBlend(ADestBitmap, ASrcBitmap, ADestRect.Left, ADestRect.Top, ADestWidth, ADestHeight, ASrcRect.Left, ASrcRect.Top, ASrcRect.Right - ASrcRect.Left, ASrcRect.Bottom - ASrcRect.Top, AConstantAlpha) else begin ADestBitmap := cxCreateBitmap(ADestWidth, ADestHeight, pf32bit); try BitBlt(ADestBitmap.Canvas.Handle, 0, 0, ADestWidth, ADestHeight, ADestDC, ADestRect.Left, ADestRect.Top, SRCCOPY); SoftwareAlphaBlend(ADestBitmap, ASrcBitmap, 0, 0, ADestWidth, ADestHeight, ASrcRect.Left, ASrcRect.Top, ASrcRect.Right - ASrcRect.Left, ASrcRect.Bottom - ASrcRect.Top, AConstantAlpha); BitBlt(ADestDC, ADestRect.Left, ADestRect.Top, ADestWidth, ADestHeight, ADestBitmap.Canvas.Handle, 0, 0, SRCCOPY); finally ADestBitmap.Free; end; end; end; end; procedure cxAlphaBlend(ADestBitmap, ASrcBitmap: TBitmap; const ADestRect, ASrcRect: TRect; AConstantAlpha: Byte = $FF); overload; begin CommonAlphaBlend(ADestBitmap, ASrcBitmap, 0, ADestRect, ASrcRect, AConstantAlpha); end; procedure cxAlphaBlend(ADestDC: HDC; ASrcBitmap: TBitmap; const ADestRect, ASrcRect: TRect; AConstantAlpha: Byte = $FF); overload; begin CommonAlphaBlend(nil, ASrcBitmap, ADestDC, ADestRect, ASrcRect, AConstantAlpha); end; procedure cxApplyViewParams(ACanvas: TcxCanvas; const AViewParams: TcxViewParams); begin with ACanvas do begin Font := AViewParams.Font; Font.Color := AViewParams.TextColor; Brush.Color := AViewParams.Color; end; end; procedure cxBlendFunction(const ASource: TRGBQuad; var ADest: TRGBQuad; ASourceConstantAlpha: Byte); function GetValue(AValue: Single): Byte; begin if AValue < 255 then Result := Round(AValue) else Result := 255; end; var ASCA, ASrcAlpha: Single; begin ASCA := ASourceConstantAlpha / 255; ASrcAlpha := 1 - ASource.rgbReserved * ASCA / 255; ADest.rgbRed := GetValue(ASource.rgbRed * ASCA + ASrcAlpha * ADest.rgbRed); ADest.rgbGreen := GetValue(ASource.rgbGreen * ASCA + ASrcAlpha * ADest.rgbGreen); ADest.rgbBlue := GetValue(ASource.rgbBlue * ASCA + ASrcAlpha * ADest.rgbBlue); ADest.rgbReserved := GetValue(ASource.rgbReserved * ASCA + ASrcAlpha * ADest.rgbReserved); end; function cxCreateBitmap(const ASize: TSize; AFormat: TPixelFormat = pf24bit): TBitmap; begin Result := cxCreateBitmap(ASize.cx, ASize.cy, AFormat); end; function cxCreateBitmap(AWidth, AHeight: Integer; AFormat: TPixelFormat = pf24bit): TBitmap; begin Result := TBitmap.Create; Result.PixelFormat := AFormat; Result.Width := AWidth; Result.Height := AHeight; end; function cxCreateTrueColorBitmap(const ASize: TSize): TBitmap; begin Result := cxCreateTrueColorBitmap(ASize.cx, ASize.cy); end; function cxCreateTrueColorBitmap(AWidth, AHeight: Integer): TBitmap; begin Result := TBitmap.Create; Result.Handle := cxCreateTrueColorBitmapHandle(AWidth, AHeight); end; function cxCreateTrueColorBitmapHandle(AWidth, AHeight: Integer; ABPP: Integer = 32): HBitmap; begin Result := CreateBitmap(AWidth, AHeight, 1, ABPP, nil); end; procedure cxCopyImage(ASource, ADest: TBitmap; const ASrcOffset, ADstOffset: TPoint; const ARect: TRect); var ADstRect, ASrcRect: TRect; begin ADstRect := ARect; ASrcRect := ARect; OffsetRect(ASrcRect, ASrcOffset.X, ASrcOffset.Y); OffsetRect(ADstRect, ADstOffset.X, ADstOffset.Y); ADest.Canvas.CopyRect(ASrcRect, ASource.Canvas, ADstRect); end; procedure cxCopyImage(ASource, ADest: TCanvas; const ASrcOffset, ADstOffset: TPoint; const ARect: TRect); var ADstRect, ASrcRect: TRect; begin ADstRect := ARect; ASrcRect := ARect; OffsetRect(ASrcRect, ASrcOffset.X, ASrcOffset.Y); OffsetRect(ADstRect, ADstOffset.X, ADstOffset.Y); ADest.CopyRect(ADstRect, ASource, ASrcRect); end; procedure cxDrawArrows(ACanvas: TCanvas; const ARect: TRect; ASide: TcxBorder; AColor: TColor; APenColor: TColor = clDefault); type TArrowPolygon = array[0..6] of TPoint; var ArrowRgns: array[0..1, 0..6, 0..1] of Integer; BaseLine: array[0..1, 0..1] of Integer; I, J, K: Integer; begin with ARect do begin BaseLine[0, 0] := Left; BaseLine[0, 1] := Top; BaseLine[1, 0] := Right; BaseLine[1, 1] := Bottom; end; if ASide in [bLeft, bBottom] then begin BaseLine[Byte(ASide = bLeft), 0] := ARect.Left; BaseLine[Byte(ASide = bLeft), 1] := ARect.Bottom; end else begin BaseLine[Byte(ASide = bTop), 0] := ARect.Right; BaseLine[Byte(ASide = bTop), 1] := ARect.Top; end; Move(BaseRgns[Byte(ASide in [bTop, bBottom]) shl 1], ArrowRgns, SizeOf(ArrowRgns)); for I := 0 to 1 do for J := 0 to 6 do for K := 0 to 1 do Inc(ArrowRgns[I, J, K], BaseLine[I, K]); ACanvas.Brush.Color := AColor; if APenColor = clDefault then ACanvas.Pen.Color := $FFFFFF xor ColorToRgb(AColor) else ACanvas.Pen.Color := APenColor; for I := 0 to 1 do ACanvas.Polygon(TArrowPolygon(ArrowRgns[I])); end; procedure cxFillHalfToneRect( Canvas: TCanvas; const ARect: TRect; ABkColor, AColor: TColor); begin with Canvas do begin {$IFDEF VCL} ABkColor := SetBkColor(Handle, ColorToRgb(ABkColor)); AColor := SetTextColor(Handle, ColorToRgb(AColor)); Windows.FillRect(Handle, ARect, cxHalfToneBrush.Handle); SetBkColor(Handle, ABkColor); SetTextColor(Handle, AColor); {$ELSE} QBrush_SetColor(HalfToneBrush.Handle, QColor(AColor)); QPainter_SetBackgroundColor(Handle, QColor(ABkColor)); with ARect do QPainter_FillRect(Handle, Left, Top, Right - Left + 1, Bottom - Top + 1, cxHalfToneBrush); {$ENDIF} end; end; procedure cxSetCanvasOrg(ACanvas: TCanvas; var AOrg: TRect); begin {$IFDEF VCL} with AOrg do SetWindowOrgEx(ACanvas.Handle, Left, Top, @TopLeft); {$ELSE} QPainter_SetWindow(ACanvas.Handle, AOrg); {$ENDIF} end; function cxTextHeight(AFont: TFont; const S: string = 'Wg'; AFontSize: Integer = 0): Integer; begin Result := cxTextExtent(AFont, S, AFontSize).cy; end; function cxTextExtent(AFont: TFont; const S: string; AFontSize: Integer = 0): TSize; begin with cxScreenCanvas do begin Font.Assign(AFont); if AFontSize <> 0 then Font.Size := AFontSize; Result := TextExtent(S); end; end; function cxTextWidth(AFont: TFont; const S: string; AFontSize: Integer = 0): Integer; begin Result := cxTextExtent(AFont, S, AFontSize).cx; end; {$ENDIF} function cxDrawText(ADC: HDC; const AText: string; var ARect: TRect; AFormat: UINT; ACharCount: Integer = - 1): Integer; begin Result := Windows.DrawText(ADC, {$IFNDEF CLR}PChar{$ENDIF}(AText), ACharCount, ARect, AFormat); end; function cxTextSize(ADC: HDC; const AText: string): TSize; // differs from cxTextExtent var ARect: TRect; begin ARect := cxGetTextRect(ADC, AText, 1); Result := Size(ARect.Right, ARect.Bottom); end; function cxGetTextRect(ADC: HDC; const AText: string; ARowCount: Integer; AReturnMaxRectHeight: Boolean = False): TRect; function GetFirstApproximation(out ARectWidth, ARectHeight: Integer): TRect; begin Result := Rect(0, 0, 1, 1); cxDrawText(ADC, AText, Result, DT_WORDBREAK or DT_CALCRECT); ARectHeight := cxTextSize(ADC, 'Wg').cy * ARowCount; ARectWidth := cxRectWidth(Result); end; var ARectHeight, ARectWidth: Integer; begin Result := cxEmptyRect; if ARowCount <= 0 then Exit; if ARowCount = 1 then cxDrawText(ADC, AText, Result, DT_SINGLELINE or DT_CALCRECT) else begin Result := GetFirstApproximation(ARectWidth, ARectHeight); while cxRectHeight(Result) > ARectHeight do begin Inc(ARectWidth); Result.Right := ARectWidth; cxDrawText(ADC, AText, Result, DT_WORDBREAK or DT_CALCRECT); end; if AReturnMaxRectHeight and (cxRectHeight(Result) < ARectHeight) then Result.Bottom := Result.Top + ARectHeight; end; end; function cxGetTextRect(AFont: TFont; const AText: string; ARowCount: Integer): TRect; begin cxScreenCanvas.Font := AFont; Result := cxGetTextRect(cxScreenCanvas.Handle, AText, ARowCount); end; function cxGetWritingDirection(AFontCharset: TFontCharset; const AText: string): TCanvasOrientation; function IsStandardASCIIChar: Boolean; begin {$IFDEF CLR} Result := (Length(AText) > 0) and (Integer(AText[1]) < 128); {$ELSE} Result := (Length(AText) > 0) and (cxStrCharLength(AText) = 1) and (Integer(AText[1]) < 128); {$ENDIF} end; begin if AFontCharset = DEFAULT_CHARSET then AFontCharset := GetDefFontCharset; if not IsStandardASCIIChar and (AFontCharset in [ARABIC_CHARSET, CHINESEBIG5_CHARSET, GB2312_CHARSET]) then Result := coRightToLeft else Result := coLeftToRight; end; procedure cxDrawThemeParentBackground(AControl: TWinControl; ACanvas: TcxCanvas; const ARect: TRect); begin if AControl.Parent.DoubleBuffered then cxDrawTransparentControlBackground(AControl, ACanvas, ARect, False) else DrawThemeParentBackground(AControl.Handle, ACanvas.Handle, ARect); end; procedure cxDrawThemeParentBackground(AControl: TWinControl; ACanvas: TCanvas; const ARect: TRect); var AcxCanvas: TcxCanvas; begin AcxCanvas := TcxCanvas.Create(ACanvas); try cxDrawThemeParentBackground(AControl, AcxCanvas, ARect); finally AcxCanvas.Free; end; end; procedure cxDrawTransparentControlBackground(AControl: TWinControl; ACanvas: TcxCanvas; ARect: TRect; APaintParentWithChildren: Boolean = True); procedure cxPaintControlTo(ADrawControl: TWinControl; AOffsetX, AOffsetY: Integer; ADrawRect: TRect); procedure DrawEdgesAndBorders; var AEdgeFlags, ABorderFlags: Integer; ABorderRect: TRect; begin ABorderFlags := 0; AEdgeFlags := 0; if GetWindowLong(ADrawControl.Handle, GWL_EXSTYLE) and WS_EX_CLIENTEDGE <> 0 then begin AEdgeFlags := EDGE_SUNKEN; ABorderFlags := BF_RECT or BF_ADJUST end else if GetWindowLong(ADrawControl.Handle, GWL_STYLE) and WS_BORDER <> 0 then begin AEdgeFlags := BDR_OUTER; ABorderFlags := BF_RECT or BF_ADJUST or BF_MONO; end; if ABorderFlags <> 0 then begin ABorderRect := Rect(0, 0, ADrawControl.Width, ADrawControl.Height); DrawEdge(ACanvas.Handle, ABorderRect, AEdgeFlags, ABorderFlags); ACanvas.SetClipRegion(TcxRegion.Create(ABorderRect), roIntersect); MoveWindowOrg(ACanvas.Handle, ABorderRect.Left, ABorderRect.Top); end; end; var ASavedDC, I: Integer; AChildControl: TControl; begin ASavedDC := SaveDC(ACanvas.Handle); try MoveWindowOrg(ACanvas.Handle, AOffsetX, AOffsetY); ACanvas.SetClipRegion(TcxRegion.Create(ADrawRect), roIntersect); with ACanvas.GetClipRegion do try if IsEmpty then Exit; finally Free; end; ADrawControl.ControlState := ADrawControl.ControlState + [csPaintCopy]; try if ADrawControl <> AControl.Parent then DrawEdgesAndBorders; ACanvas.Canvas.Lock; try ADrawControl.Perform(WM_ERASEBKGND, ACanvas.Handle, ACanvas.Handle); ADrawControl.Perform(WM_PAINT, ACanvas.Handle, 0); finally ACanvas.Canvas.Unlock; end; if APaintParentWithChildren then for I := 0 to ADrawControl.ControlCount - 1 do begin AChildControl := ADrawControl.Controls[I]; if AChildControl = AControl then Break; if (AChildControl is TWinControl) and TWinControl(AChildControl).Visible then cxPaintControlTo(TWinControl(AChildControl), AChildControl.Left, AChildControl.Top, Rect(0, 0, AChildControl.Width, AChildControl.Height)); end; finally ADrawControl.ControlState := ADrawControl.ControlState - [csPaintCopy]; end; finally RestoreDC(ACanvas.Handle, ASavedDC); end; end; begin if AControl.Parent <> nil then begin OffsetRect(ARect, AControl.Left, AControl.Top); cxPaintControlTo(AControl.Parent, -ARect.Left, -ARect.Top, ARect); // wrong cxLabel painting cxPaintControlTo(AControl.Parent, -AControl.Left, -AControl.Top, ARect); end; end; procedure cxDrawTransparentControlBackground(AControl: TWinControl; ACanvas: TCanvas; const ARect: TRect; APaintParentWithChildren: Boolean = True); var AcxCanvas: TcxCanvas; begin AcxCanvas := TcxCanvas.Create(ACanvas); try cxDrawTransparentControlBackground(AControl, AcxCanvas, ARect, APaintParentWithChildren); finally AcxCanvas.Free; end; end; function cxScreenCanvas: TcxScreenCanvas; begin if ScreenCanvas = nil then ScreenCanvas := TcxScreenCanvas.Create; Result := ScreenCanvas; end; { TcxRegion } constructor TcxRegion.Create(AHandle: TcxRegionHandle); begin inherited Create; FHandle := AHandle; end; constructor TcxRegion.Create(const ABounds: TRect); var AHandle: TcxRegionHandle; begin {$IFDEF VCL} AHandle := CreateRectRgnIndirect(ABounds); {$ELSE} AHandle := QRegion_create(@ABounds, QRegionRegionType_Rectangle); {$ENDIF} Create(AHandle); end; constructor TcxRegion.Create; begin {$IFDEF VCL} Create(0, 0, 0, 0); {$ELSE} Create(QRegion_create); {$ENDIF} end; constructor TcxRegion.Create(ALeft, ATop, ARight, ABottom: Integer); begin Create(Rect(ALeft, ATop, ARight, ABottom)); end; destructor TcxRegion.Destroy; begin DestroyHandle; inherited; end; function TcxRegion.GetIsEmpty: Boolean; {$IFDEF VCL} var R: TRect; {$ENDIF} begin {$IFDEF VCL} Result := GetRgnBox(FHandle, R) = NULLREGION; {$ELSE} Result := QRegion_isEmpty(FHandle); {$ENDIF} end; procedure TcxRegion.DestroyHandle; begin {$IFDEF VCL} if FHandle <> 0 then begin DeleteObject(FHandle); FHandle := 0; end; {$ELSE} if FHandle <> nil then begin QRegion_destroy(FHandle); FHandle := nil; end; {$ENDIF} end; procedure TcxRegion.Combine(ARegion: TcxRegion; AOperation: TcxRegionOperation; ADestroyRegion: Boolean = True); {$IFDEF VCL} const Modes: array[TcxRegionOperation] of Integer = (RGN_COPY, RGN_OR, RGN_DIFF, RGN_AND); {$ENDIF} begin {$IFDEF VCL} if AOperation = roSet then CombineRgn(FHandle, ARegion.Handle, 0, Modes[AOperation]) else CombineRgn(FHandle, FHandle, ARegion.Handle, Modes[AOperation]); {$ELSE} case AOperation of roSet: {}; roAdd: QRegion_unite(FHandle, FHandle, ARegion.Handle); roSubtract: QRegion_subtract(FHandle, FHandle, ARegion.Handle); roIntersect: QRegion_intersect(FHandle, FHandle, ARegion.Handle); end; {$ENDIF} if ADestroyRegion then ARegion.Free; end; function TcxRegion.IsEqual(ARegion: TcxRegion): Boolean; begin Result := (ARegion <> nil) and ((IsEmpty and ARegion.IsEmpty) or IsEqual(ARegion.Handle)); end; function TcxRegion.IsEqual(ARegionHandle: TcxRegionHandle): Boolean; begin Result := EqualRgn(Handle, ARegionHandle); end; procedure TcxRegion.Offset(DX, DY: Integer); begin {$IFDEF VCL} OffsetRgn(FHandle, DX, DY); {$ELSE} QRegion_translate(FHandle, DX, DY); {$ENDIF} end; function TcxRegion.PtInRegion(const Pt: TPoint): Boolean; begin {$IFDEF VCL} Result := Windows.PtInRegion(Handle, Pt.X, Pt.Y); {$ELSE} Result := QRegion_contains(Handle, @Pt); {$ENDIF} end; function TcxRegion.PtInRegion(X, Y: Integer): Boolean; begin Result := PtInRegion(Point(X, Y)); end; function TcxRegion.RectInRegion(const R: TRect): Boolean; begin {$IFDEF VCL} Result := Windows.RectInRegion(Handle, R); {$ELSE} Result := QRegion_contains(Handle, @R); {$ENDIF} end; function TcxRegion.RectInRegion(ALeft, ATop, ARight, ABottom: Integer): Boolean; begin Result := RectInRegion(Rect(ALeft, ATop, ARight, ABottom)); end; { TcxCanvas } constructor TcxCanvas.Create(ACanvas: TCanvas); begin inherited Create; FCanvas := ACanvas; end; function TcxCanvas.GetBrush: TBrush; begin Result := Canvas.Brush; end; function TcxCanvas.GetCopyMode: TCopyMode; begin Result := Canvas.CopyMode; end; function TcxCanvas.GetDCOrigin: TPoint; var AWindowOrg, AViewportOrg: TPoint; begin AWindowOrg := WindowOrg; AViewportOrg := ViewportOrg; Result := Point(AViewportOrg.X - AWindowOrg.X, AViewportOrg.Y - AWindowOrg.Y); end; function TcxCanvas.GetFont: TFont; begin Result := Canvas.Font; end; function TcxCanvas.GetHandle: {$IFDEF VCL}HDC{$ELSE}QPainterH{$ENDIF}; begin Result := Canvas.Handle; end; function TcxCanvas.GetPen: TPen; begin Result := Canvas.Pen; end; function TcxCanvas.GetViewportOrg: TPoint; begin GetViewportOrgEx(Handle, Result); end; function TcxCanvas.GetWindowOrg: TPoint; {$IFNDEF VCL} var R: TRect; {$ENDIF} begin {$IFDEF VCL} GetWindowOrgEx(Handle, Result); {$ELSE} QPainter_window(Handle, @R); Result := R.TopLeft; {$ENDIF} end; procedure TcxCanvas.SetBrush(Value: TBrush); begin Canvas.Brush := Value; end; procedure TcxCanvas.SetCopyMode(Value: TCopyMode); begin Canvas.CopyMode := Value; end; procedure TcxCanvas.SetFont(Value: TFont); begin Canvas.Font := Value; end; procedure TcxCanvas.SetPen(Value: TPen); begin Canvas.Pen := Value; end; procedure TcxCanvas.SetPixel(X, Y: Integer; Value: TColor); begin {$IFDEF VCL} Canvas.Pixels[X, Y] := Value; {$ELSE} SetBrushColor(Value); FillRect(Rect(X, Y, X + 1, Y + 1)); {$ENDIF} end; procedure TcxCanvas.SetViewportOrg(const P: TPoint); begin SetViewportOrgEx(Handle, P.X, P.Y, nil); end; procedure TcxCanvas.SetWindowOrg(const P: TPoint); {$IFNDEF VCL} var ACanvasHandle: QPainterH; R: TRect; {$ENDIF} begin {$IFDEF VCL} SetWindowOrgEx(Handle, P.X, P.Y, nil); {$ELSE} ACanvasHandle := Handle; QPainter_window(ACanvasHandle, @R); OffsetRect(R, P.X - R.Left, P.Y - R.Top); QPainter_setWindow(ACanvasHandle, @R); {$ENDIF} end; procedure TcxCanvas.AlignMultiLineTextRectVertically(var R: TRect; const AText: string; AAlignmentVert: TcxAlignmentVert; AWordBreak, AShowPrefix: Boolean; AEnabled: Boolean = True; ADontBreakChars: Boolean = False); var ASizeR: TRect; AFlags: Integer; begin if AAlignmentVert = vaTop then Exit; ASizeR := Rect(0, 0, R.Right - R.Left - Ord(not AEnabled), 0); AFlags := cxAlignLeft or cxAlignTop; if AWordBreak then AFlags := AFlags or cxWordBreak; if AShowPrefix then AFlags := AFlags or cxShowPrefix; if ADontBreakChars then AFlags := AFlags or cxDontBreakChars; TextExtent(AText, ASizeR, AFlags); case AAlignmentVert of vaCenter: R.Top := (R.Top + R.Bottom - (ASizeR.Bottom - ASizeR.Top)) div 2; vaBottom: R.Top := R.Bottom - (ASizeR.Bottom - ASizeR.Top + Ord(not AEnabled)); end; end; procedure TcxCanvas.CopyRect(const Dest: TRect; ACanvas: TCanvas; const Source: TRect); begin {$IFNDEF VCL} if IsRectEmpty(Dest) or IsRectEmpty(Source) then Exit; {$ENDIF} Canvas.CopyRect(Dest, ACanvas, Source); end; procedure TcxCanvas.Draw(X, Y: Integer; Graphic: TGraphic); begin Canvas.Draw(X, Y, Graphic); end; procedure TcxCanvas.DrawComplexFrame(const R: TRect; ALeftTopColor, ARightBottomColor: TColor; ABorders: TcxBorders; ABorderWidth: Integer); var ABorder: TcxBorder; function GetBorderColor: TColor; begin if ABorder in [bLeft, bTop] then Result := ALeftTopColor else Result := ARightBottomColor; end; function GetBorderBounds: TRect; begin Result := R; with Result do case ABorder of bLeft: Right := Left + ABorderWidth; bTop: Bottom := Top + ABorderWidth; bRight: Left := Right - ABorderWidth; bBottom: Top := Bottom - ABorderWidth; end; end; begin for ABorder := Low(ABorder) to High(ABorder) do if ABorder in ABorders then begin SetBrushColor(GetBorderColor); FillRect(GetBorderBounds); end; end; procedure TcxCanvas.DrawEdge(const R: TRect; ASunken, AOuter: Boolean; ABorders: TcxBorders); begin if ASunken then if AOuter then DrawComplexFrame(R, clBtnShadow, clBtnHighlight, ABorders) else DrawComplexFrame(R, cl3DDkShadow{clBtnText}, cl3DLight{clBtnFace}, ABorders) else if AOuter then DrawComplexFrame(R, cl3DLight{clBtnFace}, cl3DDkShadow{clBtnText}, ABorders) else DrawComplexFrame(R, clBtnHighlight, clBtnShadow, ABorders); end; procedure TcxCanvas.DrawFocusRect(const R: TRect); begin SetBrushColor(clWhite); {$IFDEF VCL} Canvas.Font.Color := clBlack; {$IFNDEF CLR} TCanvasAccess(Canvas).RequiredState([csFontValid]); {$ELSE} Canvas.Handle; {$ENDIF} {$ELSE} Canvas.Pen.Color := clBlack; {$ENDIF} Canvas.DrawFocusRect(R); end; procedure TcxCanvas.DrawGlyph(X, Y: Integer; AGlyph: TBitmap; AEnabled: Boolean = True; ABackgroundColor: TColor = clNone{; ATempCanvas: TCanvas = nil}); var {$IFDEF VCL} APrevBrushStyle: TBrushStyle; {$ENDIF} AImageList: TImageList; ABitmap: TBitmap; begin {$IFDEF VCL} if AEnabled {and (ATempCanvas = nil)} then begin APrevBrushStyle := Brush.Style; if ABackgroundColor = clNone then Brush.Style := bsClear else Brush.Color := ABackgroundColor; Canvas.BrushCopy(Bounds(X, Y, AGlyph.Width, AGlyph.Height), AGlyph, Rect(0, 0, AGlyph.Width, AGlyph.Height), AGlyph.TransparentColor); Brush.Style := APrevBrushStyle; Exit; end; {$ENDIF} AImageList := nil; ABitmap := nil; try AImageList := TImageList.Create(nil); AImageList.Width := AGlyph.Width; AImageList.Height := AGlyph.Height; if ABackgroundColor <> clNone then //if ATempCanvas = nil then begin ABitmap := TBitmap.Create; ABitmap.Width := AImageList.Width; ABitmap.Height := AImageList.Height; with ABitmap.Canvas do begin Brush.Color := ABackgroundColor; FillRect(Rect(0, 0, ABitmap.Width, ABitmap.Height)); end; end {else with ATempCanvas do begin Brush.Color := ABackgroundColor; FillRect(Bounds(X, Y, AGlyph.Width, AGlyph.Height)); end}; if AGlyph.TransparentMode = tmFixed then AImageList.AddMasked(AGlyph, AGlyph.TransparentColor) else AImageList.AddMasked(AGlyph, clDefault); if ABitmap <> nil then begin AImageList.Draw(ABitmap.Canvas, 0, 0, 0{$IFNDEF VCL}, itImage{itMask}{$ENDIF}, AEnabled); // ??? itMask TODO Draw(X, Y, ABitmap); end else (*if ATempCanvas <> nil then AImageList.Draw(ATempCanvas, X, Y, 0{$IFNDEF VCL}, itMask{$ENDIF}, AEnabled) // ??? itMask TODO else*) AImageList.Draw(Canvas, X, Y, 0{$IFNDEF VCL}, itImage{itMask}{$ENDIF}, AEnabled); // ??? itMask TODO finally ABitmap.Free; AImageList.Free; end; end; procedure TcxCanvas.DrawImage(Images: TCustomImageList; X, Y, Index: Integer; Enabled: Boolean = True); var ASavedDCInfo: Integer; begin if (0 <= Index) and (Index < Images.Count) then begin if not Enabled then ASavedDCInfo := SaveDC(Handle) // to restore normal colors after TCustomImageList.DoDraw else ASavedDCInfo := 0; Images.Draw(Canvas, X, Y, Index, {$IFNDEF VCL}itImage, {$ENDIF}Enabled); if ASavedDCInfo <> 0 then RestoreDC(Handle, ASavedDCInfo); end; end; procedure TcxCanvas.DrawText(const Text: string; R: TRect; Flags: Integer; Enabled: Boolean); var {$IFDEF VCL} AUseDrawText: Boolean; {$ENDIF} PrevBrushStyle: TBrushStyle; PrevFontColor: TColor; procedure ProcessFlags; var ASize: TSize; {$IFDEF VCL} AAlignmentVert: TcxAlignmentVert; {$ENDIF} begin ASize := TextExtent(Text); if (ASize.cx <= R.Right - R.Left) and (ASize.cy <= R.Bottom - R.Top) then Flags := Flags or cxDontClip; {$IFDEF VCL} if AUseDrawText then begin if (Flags and cxSingleLine = 0) and (Flags and (cxAlignBottom or cxAlignVCenter) <> 0) then begin if Flags and cxAlignBottom <> 0 then AAlignmentVert := vaBottom else AAlignmentVert := vaCenter; AlignMultiLineTextRectVertically(R, Text, AAlignmentVert, cxWordBreak and Flags <> 0, cxShowPrefix and Flags <> 0, Enabled, cxDontBreakChars and Flags <> 0); end; Flags := cxFlagsToDTFlags(Flags); end else begin if ASize.cx < R.Right - R.Left then case Flags and (cxAlignLeft or cxAlignRight or cxAlignHCenter) of cxAlignRight: R.Left := R.Right - ASize.cx - Ord(not Enabled); cxAlignHCenter: R.Left := (R.Left + R.Right - ASize.cx) div 2; end; if ASize.cy < R.Bottom - R.Top then case Flags and (cxAlignTop or cxAlignBottom or cxAlignVCenter) of cxAlignBottom: R.Top := R.Bottom - ASize.cy - Ord(not Enabled); cxAlignVCenter: R.Top := (R.Top + R.Bottom - ASize.cy) div 2; end; if Flags and cxDontClip = 0 then Flags := ETO_CLIPPED else Flags := 0; end; {$ELSE} Flags := Flags and not (cxShowEndEllipsis or cxShowPathEllipsis); {$ENDIF} end; procedure DoDrawText; begin {$IFDEF VCL} if AUseDrawText then Windows.DrawText(Canvas.Handle, {$IFNDEF CLR}PChar{$ENDIF}(Text), Length(Text), R, Flags) else ExtTextOut(Canvas.Handle, R.Left, R.Top, Flags, {$IFNDEF CLR}@{$ENDIF}R, {$IFNDEF CLR}PChar{$ENDIF}(Text), Length(Text), nil); {$ELSE} Canvas.TextRect(R, R.Left, R.Top, Text, Flags); {$ENDIF} end; begin if Length(Text) = 0 then Exit; {$IFDEF VCL} AUseDrawText := (Flags and cxSingleLine = 0) or (Flags and (cxShowPrefix or cxShowEndEllipsis or cxShowPathEllipsis) <> 0); {$ENDIF} ProcessFlags; PrevBrushStyle := Brush.Style; PrevFontColor := Font.Color; if not Enabled then begin with R do begin Inc(Left); Inc(Top); end; Brush.Style := bsClear; Font.Color := clBtnHighlight; DoDrawText; OffsetRect(R, -1, -1); Font.Color := clBtnShadow; end; DoDrawText; if Brush.Style <> PrevBrushStyle then Brush.Style := PrevBrushStyle; Font.Color := PrevFontColor; end; procedure TcxCanvas.FillRect(const R: TRect; ABitmap: TBitmap = nil; AExcludeRect: Boolean = False); var ABitmapSize, AOffset: TPoint; AFirstCol, AFirstRow, ALastCol, ALastRow, I, J: Integer; ABitmapRect, ACellRect: TRect; begin if IsRectEmpty(R) then Exit; if (ABitmap = nil) or ABitmap.Empty then Canvas.FillRect(R) else with ABitmapSize do begin X := ABitmap.Width; Y := ABitmap.Height; AFirstCol := R.Left div X; AFirstRow := R.Top div Y; ALastCol := R.Right div X - Ord(R.Right mod X = 0); ALastRow := R.Bottom div Y - Ord(R.Bottom mod Y = 0); for J := AFirstRow to ALastRow do for I := AFirstCol to ALastCol do begin AOffset.X := I * X; AOffset.Y := J * Y; ACellRect := Bounds(AOffset.X, AOffset.Y, X, Y); IntersectRect(ACellRect, ACellRect, R); ABitmapRect := ACellRect; OffsetRect(ABitmapRect, -AOffset.X, -AOffset.Y); CopyRect(ACellRect, ABitmap.Canvas, ABitmapRect); end; end; if AExcludeRect then SetClipRegion(TcxRegion.Create(R), roSubtract); end; procedure TcxCanvas.FillRect(R: TRect; const AParams: TcxViewParams; ABorders: TcxBorders = []; ABorderColor: TColor = clDefault; ALineWidth: Integer = 1; AExcludeRect: Boolean = False); begin FrameRect(R, ABorderColor, ALineWidth, ABorders, AExcludeRect); with R do begin if bLeft in ABorders then Inc(Left, ALineWidth); if bRight in ABorders then Dec(Right, ALineWidth); if bTop in ABorders then Inc(Top, ALineWidth); if bBottom in ABorders then Dec(Bottom, ALineWidth); end; SetBrushColor(AParams.Color); FillRect(R, AParams.Bitmap, AExcludeRect); end; {$IFDEF LINUX} procedure TcxCanvas.FillRect(const R: TRect; ABrush: TBrush); begin QPainter_fillRect(Handle, @R, ABrush.Handle); end; {$ENDIF} {$IFNDEF LINUX} procedure TcxCanvas.DrawDesignSelection(ARect: TRect; AWidth: Integer = cxDesignSelectionWidth); var I: Integer; begin for I := 0 to AWidth - 1 do begin DrawFocusRect(ARect); InflateRect(ARect, -1, -1); end; end; procedure TcxCanvas.DrawRegion(ARegion: TcxRegion; AContentColor: TColor = clDefault; ABorderColor: TColor = clDefault; ABorderWidth: Integer = 1; ABorderHeight: Integer = 1); begin DrawRegion(ARegion.Handle, AContentColor, ABorderColor, ABorderWidth, ABorderHeight); end; procedure TcxCanvas.DrawRegion(ARegion: TcxRegionHandle; AContentColor: TColor = clDefault; ABorderColor: TColor = clDefault; ABorderWidth: Integer = 1; ABorderHeight: Integer = 1); begin FillRegion(ARegion, AContentColor); FrameRegion(ARegion, ABorderColor, ABorderWidth, ABorderHeight); end; procedure TcxCanvas.FillRegion(ARegion: TcxRegion; AColor: TColor = clDefault); begin FillRegion(ARegion.Handle, AColor); end; procedure TcxCanvas.FillRegion(ARegion: TcxRegionHandle; AColor: TColor = clDefault); begin SetBrushColor(AColor); FillRgn(Handle, ARegion, Brush.Handle); end; procedure TcxCanvas.FlipHorizontally(ABitmap: TBitmap); var Bits: TRGBColors; ARow, ACol, W, H, ARowStart: Integer; AValue: TRGBQuad; begin W := ABitmap.Width; H := ABitmap.Height; Bits := GetBitmapBits(ABitmap, True); ARowStart := 0; for ARow := 0 to H - 1 do begin for ACol := 0 to (W - 1) div 2 do begin AValue := Bits[ARowStart + ACol]; Bits[ARowStart + ACol] := Bits[ARowStart + W - 1 - ACol]; Bits[ARowStart + W - 1 - ACol] := AValue; end; Inc(ARowStart, W); end; SetBitmapBits(ABitmap, Bits, True); end; procedure TcxCanvas.FrameRegion(ARegion: TcxRegion; AColor: TColor = clDefault; ABorderWidth: Integer = 1; ABorderHeight: Integer = 1); begin FrameRegion(ARegion.Handle, AColor, ABorderWidth, ABorderHeight); end; procedure TcxCanvas.FrameRegion(ARegion: TcxRegionHandle; AColor: TColor = clDefault; ABorderWidth: Integer = 1; ABorderHeight: Integer = 1); begin SetBrushColor(AColor); FrameRgn(Handle, ARegion, Brush.Handle, ABorderWidth, ABorderHeight); end; procedure TcxCanvas.Pie(const R: TRect; const ARadial1, ARadial2: TPoint); begin with R do Canvas.Pie(Left, Top, Right, Bottom, ARadial1.X, ARadial1.Y, ARadial2.X, ARadial2.Y); end; procedure TcxCanvas.Pie(const R: TRect; AStartAngle, ASweepAngle: Integer); { A * B V = --------------------------------------------- Sqrt(A^2 * Sin^2(Alpha) + B^2 * Cos^2(Alpha)) Radial.X = V * Cos(Alpha) Radial.Y = V * Sin(Alpha) where: A - horizontal ellipse semiaxis B - vertical ellipse semiaxis Angle - an angle between Radius-Vector and A calculated in counterclockwise direction } function CalculateRadial(A, B: Integer; const ACenter: TPoint; AnAngle: Integer): TPoint; var Sin, Cos, V: Extended; begin SinCos(DegToRad(AnAngle), Sin, Cos); if (A <> 0) and (B <> 0) then V := A * B / Sqrt(A * A * Sin * Sin + B * B * Cos * Cos) else V := 0; Result.X := ACenter.X + Round(V * Cos); Result.Y := ACenter.Y - Round(V * Sin); end; var A, B: Integer; Center, Radial1, Radial2: TPoint; begin if IsRectEmpty(R) or (ASweepAngle = 0) then Exit; with R do begin A := (Right - Left) div 2; B := (Bottom - Top) div 2; Center.X := Left + A; Center.Y := Top + B; end; Radial1 := CalculateRadial(A, B, Center, AStartAngle); if ASweepAngle = 360 then Radial2 := Radial1 else Radial2 := CalculateRadial(A, B, Center, AStartAngle + ASweepAngle); if (Radial1.X <> Radial2.X) or (Radial1.Y <> Radial2.Y) or (ASweepAngle > 180) then Pie(R, Radial1, Radial2); end; {$ENDIF} function TcxCanvas.FontHeight(AFont: TFont): Integer; begin Font := AFont; Result := TextHeight('Qq'); end; procedure TcxCanvas.FrameRect(const R: TRect; Color: TColor = clDefault; ALineWidth: Integer = 1; ABorders: TcxBorders = cxBordersAll; AExcludeFrame: Boolean = False); begin if IsRectEmpty(R) then Exit; if Color <> clDefault then begin SetBrushColor(Color); {$IFNDEF VCL} Brush.Style := bsSolid; // bug in Qt {$ENDIF} end; with R do begin if bLeft in ABorders then FillRect(Rect(Left, Top, Min(Left + ALineWidth, Right), Bottom), nil, AExcludeFrame); if bRight in ABorders then FillRect(Rect(Max(Right - ALineWidth, Left), Top, Right, Bottom), nil, AExcludeFrame); if bTop in ABorders then FillRect(Rect(Left, Top, Right, Min(Top + ALineWidth, Bottom)), nil, AExcludeFrame); if bBottom in ABorders then FillRect(Rect(Left, Max(Bottom - ALineWidth, Top), Right, Bottom), nil, AExcludeFrame); end; end; procedure TcxCanvas.InvertFrame(const R: TRect; ABorderSize: Integer); begin with R do begin InvertRect(Rect(Left, Top, Left + ABorderSize, Bottom)); InvertRect(Rect(Right - ABorderSize, Top, Right, Bottom)); InvertRect(Rect(Left + ABorderSize, Top, Right - ABorderSize, Top + ABorderSize)); InvertRect(Rect(Left + ABorderSize, Bottom - ABorderSize, Right - ABorderSize, Bottom)); end; end; procedure TcxCanvas.InvertRect({$IFNDEF LINUX}const {$ENDIF}R: TRect); begin {$IFDEF LINUX} IntersectRect(R, R, Canvas.ClipRect); {$ENDIF} with Canvas do begin CopyMode := cmDstInvert; CopyRect(R, Canvas, R); CopyMode := cmSrcCopy; end; end; procedure TcxCanvas.LineTo(X, Y: Integer); begin Canvas.LineTo(X, Y); end; procedure TcxCanvas.MoveTo(X, Y: Integer); begin Canvas.MoveTo(X, Y); end; procedure TcxCanvas.Polygon(const Points: array of TPoint); begin Canvas.Polygon(Points{$IFNDEF VCL}, False, 0, -1{$ENDIF}); end; procedure TcxCanvas.Polyline(const Points: array of TPoint); begin Canvas.Polyline(Points); end; {$IFDEF VCL} procedure TcxCanvas.RotateBitmap(ABitmap: TBitmap; ARotationAngle: TcxRotationAngle; AFlipVertically: Boolean = False); var SourceRGBs, DestRGBs: TRGBColors; ARow, ACol, H, W, ASourceI, ADestI: Integer; begin SourceRGBs := nil; // to remove compiler's warning if (ARotationAngle = ra0) and not AFlipVertically then exit; H := ABitmap.Height; W := ABitmap.Width; SourceRGBs := GetBitmapBits(ABitmap, True); SetLength(DestRGBs, Length(SourceRGBs)); for ARow := 0 to H - 1 do for ACol := 0 to W - 1 do begin ASourceI := ARow * W + ACol; case ARotationAngle of raPlus90: if AFlipVertically then ADestI := ACol * H + ARow else ADestI := (W - ACol - 1) * H + ARow; ra0: ADestI := (H - 1 - ARow) * W + ACol; ra180: if AFlipVertically then ADestI := ARow * W + W - ACol - 1 else ADestI := (H - ARow - 1) * W + W - ACol - 1; else if AFlipVertically then ADestI := (W - ACol - 1) * H + H - ARow - 1 else ADestI := H - 1 + ACol * H - ARow; end; DestRGBs[ADestI] := SourceRGBs[ASourceI]; end; if ARotationAngle in [raPlus90, raMinus90] then begin {$IFNDEF CLR} ABitmap.Height := 0; {$ENDIF} ABitmap.Width := H; ABitmap.Height := W; end; SetBitmapBits(ABitmap, DestRGBs, True); end; {$ELSE} procedure RotateBitmap(Bitmap: TBitmap; Angle: TcxRotationAngle); var PDest, PDestStart: ^DWord; PSource: ^DWord; PBuffer: Pointer; XSource, YSource: Integer; LineCopyingDirection: Integer; TempVar: Integer; begin case Angle of raPlus90, raMinus90: with Bitmap do begin GetMem(PBuffer, Width * Height * 4); LineCopyingDirection := 0; PDestStart := PBuffer; case Angle of raPlus90: begin Inc(PDestStart, Height * (Width - 1)); LineCopyingDirection := 1; end; raMinus90: begin Inc(PDestStart, Height - 1); LineCopyingDirection := -1; end; end; for YSource := 0 to Height - 1 do begin PSource := ScanLine[YSource]; PDest := PDestStart; for XSource := 0 to Width - 1 do begin PDest^ := PSource^; Dec(PDest, Height * LineCopyingDirection); Inc(PSource); end; Inc(PDestStart, LineCopyingDirection); end; TempVar := Width; Width := Height; Height := TempVar; if Width = Height then begin Width := Width + 1; Width := Width - 1; end; PDest := PBuffer; for YSource := 0 to Height - 1 do begin Move(PDest^, ScanLine[YSource]^, Width * 4); Inc(PDest, Width); end; FreeMem(PBuffer); end; end; end; {$ENDIF} function TcxCanvas.TextExtent(const Text: string): TSize; begin {$IFDEF VCL} {$IFNDEF CLR} TCanvasAccess(Canvas).RequiredState([csHandleValid, csFontValid]); {$ELSE} Canvas.Handle; {$ENDIF} Result.cX := 0; Result.cY := 0; GetTextExtentPoint(Handle, {$IFNDEF CLR}PChar{$ENDIF}(Text), Length(Text), Result); {$ELSE} Result := Canvas.TextExtent(Text, 0); {$ENDIF} end; procedure TcxCanvas.TextExtent(const Text: string; var R: TRect; Flags: Integer); {$IFDEF VCL} var RWidth, RHeight, TextWidth, TextHeight: Integer; procedure CalcRSizes(var AWidth, AHeight: Integer); begin with R do begin AWidth := Right - Left; AHeight := Bottom - Top; end; end; procedure AlignR; begin if Flags and DT_CENTER <> 0 then OffsetRect(R, (RWidth - TextWidth) div 2, 0) else if Flags and DT_RIGHT <> 0 then OffsetRect(R, RWidth - TextWidth, 0); if Flags and DT_VCENTER <> 0 then OffsetRect(R, 0, (RHeight - TextHeight) div 2) else if Flags and DT_BOTTOM <> 0 then OffsetRect(R, 0, RHeight - TextHeight); end; begin CalcRSizes(RWidth, RHeight); Flags := cxFlagsToDTFlags(Flags); if (RWidth <= 0) and (Text <> '') then // A2079 R.Right := R.Left + 1; Windows.DrawText(Canvas.Handle, {$IFNDEF CLR}PChar{$ENDIF}(Text), Length(Text), R, Flags and not DT_VCENTER or DT_CALCRECT); CalcRSizes(TextWidth, TextHeight); AlignR; end; {$ELSE} begin Canvas.TextExtent(Text, R, Flags); end; {$ENDIF} function TcxCanvas.TextHeight(const Text: string): Integer; begin Result := TextExtent(Text).cy; end; function TcxCanvas.TextWidth(const Text: string): Integer; begin Result := TextExtent(Text).cx; end; procedure TcxCanvas.TransparentDraw(X, Y: Integer; ABitmap: TBitmap; AAlpha: Byte; ABackground: TBitmap = nil); function BlendValues(ASource, ADestination: DWORD): DWORD; begin Result := MulDiv(ASource, AAlpha, 255) + MulDiv(ADestination, 255 - AAlpha, 255); end; procedure BlendValue(const ASource: TRGBQuad; var ADestination: TRGBQuad); begin ADestination.rgbBlue := BlendValues(ASource.rgbBlue, ADestination.rgbBlue); ADestination.rgbGreen := BlendValues(ASource.rgbGreen, ADestination.rgbGreen); ADestination.rgbRed := BlendValues(ASource.rgbRed, ADestination.rgbRed); end; var W, H, ARow, ACol: Integer; ABackgroundBitmap: TBitmap; ABlendFunction: TBlendFunction; ABits, ABackgroundBits: TRGBColors; begin ABits := nil; // to remove compiler's warning W := ABitmap.Width; H := ABitmap.Height; ABackgroundBitmap := TBitmap.Create; ABackgroundBitmap.Width := W; ABackgroundBitmap.Height := H; if ABackground = nil then ABackgroundBitmap.Canvas.CopyRect(Rect(0, 0, W, H), Canvas, Bounds(X, Y, W, H)) else ABackgroundBitmap.Canvas.Draw(0, 0, ABackground); if Assigned(VCLAlphaBlend) then begin ABlendFunction := DefaultBlendFunction; ABlendFunction.SourceConstantAlpha := AAlpha; {$IFDEF CLR}AlphaBlend{$ELSE}VCLAlphaBlend{$ENDIF}(ABackgroundBitmap.Canvas.Handle, 0, 0, W, H, ABitmap.Canvas.Handle, 0, 0, W, H, ABlendFunction); end else begin ABits := GetBitmapBits(ABitmap, True); ABackgroundBits := GetBitmapBits(ABackgroundBitmap, True); for ARow := 0 to H - 1 do for ACol := 0 to W - 1 do BlendValue(ABits[ACol * H + ARow], ABackgroundBits[ACol * H + ACol]); SetBitmapBits(ABackgroundBitmap, ABackgroundBits, True); end; Draw(X, Y, ABackgroundBitmap); ABackgroundBitmap.Free; end; procedure TcxCanvas.GetParams(var AParams: TcxViewParams); begin AParams.Color := Brush.Color; AParams.Font := Font; AParams.TextColor := Font.Color; end; procedure TcxCanvas.SetParams(AParams: TcxViewParams); begin SetBrushColor(AParams.Color); Font := AParams.Font; Font.Color := AParams.TextColor; end; procedure TcxCanvas.SetBrushColor(Value: TColor); begin if Brush.Color <> Value then Brush.Color := Value; end; procedure TcxCanvas.SetFontAngle(Value: Integer); var ALogFont: TLogFont; begin {$IFDEF CLR} GetObject(Font.Handle, Marshal.SizeOf(TypeOf(TLogFont)), ALogFont); ALogFont.lfOrientation := Value * 10; {$ELSE} GetObject(Font.Handle, SizeOf(ALogFont), @ALogFont); {$ENDIF} ALogFont.lfEscapement := Value * 10; if Value <> 0 then ALogFont.lfOutPrecision := OUT_TT_ONLY_PRECIS; Font.Handle := CreateFontIndirect(ALogFont); end; {$IFDEF VCL} procedure TcxCanvas.GetTextStringsBounds(Text: string; R: TRect; Flags: Integer; Enabled: Boolean; var ABounds: TRectArray); var AAlignHorz, AAlignVert, AMaxCharCount: Integer; ATextR: TRect; AStringSize: TSize; procedure PrepareRects; begin if not Enabled then with R do begin Dec(Right); Dec(Bottom); end; ATextR := R; TextExtent(Text, ATextR, Flags); case AAlignVert of cxAlignBottom: OffsetRect(ATextR, 0, R.Bottom - ATextR.Bottom); cxAlignVCenter: OffsetRect(ATextR, 0, (R.Bottom - ATextR.Bottom) div 2); end; end; procedure CheckMaxCharCount; function ProcessSpecialChars: Boolean; const SpecialChars = [#10, #13]; var I, ACharCount: Integer; begin Result := False; for I := 1 to AMaxCharCount do if Text[I] in SpecialChars then begin AMaxCharCount := I - 1; ACharCount := 1; if (I < Length(Text)) and (Text[I + 1] in SpecialChars) and (Text[I] <> Text[I + 1]) then Inc(ACharCount); Delete(Text, I, ACharCount); Result := True; Break; end; end; procedure ProcessSpaces; var I: Integer; begin if AMaxCharCount < Length(Text) then for I := AMaxCharCount + 1 downto 1 do if Text[I] = ' ' then begin if I < AMaxCharCount then begin AMaxCharCount := I; if AAlignHorz <> cxAlignLeft then begin Delete(Text, I, 1); Dec(AMaxCharCount); end; end; Break; end; end; begin if not ProcessSpecialChars then ProcessSpaces; end; procedure GetStringSize; begin if AMaxCharCount = 0 then AStringSize.cx := 0 else GetTextExtentPoint(Handle, {$IFNDEF CLR}PChar{$ENDIF}(Copy(Text, 1, AMaxCharCount)), AMaxCharCount, AStringSize); end; function GetBounds: TRect; begin Result := ATextR; with Result, AStringSize do begin case AAlignHorz of cxAlignLeft: Right := Left + cx; cxAlignRight: Left := Right - cx; cxAlignHCenter: begin Left := (Left + Right - cx) div 2; Right := Left + cx; end; end; Bottom := Top + cy; end; ATextR.Top := Result.Bottom; end; begin if Text = '' then Exit; if Flags and cxShowPrefix <> 0 then begin Text := StripHotKey(Text); Flags := Flags and not cxShowPrefix; end; AAlignHorz := Flags and (cxAlignLeft or cxAlignRight or cxAlignHCenter); AAlignVert := Flags and (cxAlignTop or cxAlignBottom or cxAlignVCenter); PrepareRects; repeat GetTextExtentExPoint(Handle, {$IFNDEF CLR}PChar{$ENDIF}(Text), Length(Text), R.Right - R.Left, {$IFNDEF CLR}@{$ENDIF}AMaxCharCount, nil, AStringSize); CheckMaxCharCount; GetStringSize; SetLength(ABounds, High(ABounds) + 2); ABounds[High(ABounds)] := GetBounds; Delete(Text, 1, AMaxCharCount); until Text = ''; end; {$ENDIF} {$IFNDEF LINUX} procedure TcxCanvas.BeginPath; begin Windows.BeginPath(Handle); end; procedure TcxCanvas.EndPath; begin Windows.EndPath(Handle); end; function TcxCanvas.PathToRegion: TcxRegion; begin Result := TcxRegion.Create(Windows.PathToRegion(Handle)); end; procedure TcxCanvas.WidenPath; begin Windows.WidenPath(Handle); end; {$ENDIF} procedure TcxCanvas.ExcludeClipRect(const R: TRect); begin {$IFDEF VCL} with R do Windows.ExcludeClipRect(Handle, Left, Top, Right, Bottom); {$ELSE} if not IsRectEmpty(R) then SetClipRegion(TcxRegion.Create(R), roSubtract); {$ENDIF} end; procedure TcxCanvas.IntersectClipRect(const R: TRect); begin {$IFDEF VCL} with R do Windows.IntersectClipRect(Canvas.Handle, Left, Top, Right, Bottom); {$ELSE} if IsRectEmpty(R) then Exit; SetClipRegion(TcxRegion.Create(R), roIntersect); {$ENDIF} end; function TcxCanvas.GetClipRegion(AConsiderOrigin: Boolean = True): TcxRegion; const MaxRegionSize = 30000; begin Result := TcxRegion.Create; {$IFDEF VCL} if GetClipRgn(Handle, Result.Handle) = 0 then SetRectRgn(Result.Handle, 0, 0, MaxRegionSize, MaxRegionSize); {$ELSE} if QPainter_hasClipping(Handle) then QRegion_unite(Result.Handle, Result.Handle, Canvas.GetClipRegion) else begin Result.DestroyHandle; Result.Handle := QRegion_create(0, 0, MaxInt div 20, MaxInt div 20, QRegionRegionType_Rectangle); end; {$ENDIF} if AConsiderOrigin then Result.Offset(-DCOrigin.X, -DCOrigin.Y); end; procedure TcxCanvas.SetClipRegion(ARegion: TcxRegion; AOperation: TcxRegionOperation; ADestroyRegion: Boolean = True; AConsiderOrigin: Boolean = True); var AClipRegion: TcxRegion; ARegionOrigin: TPoint; begin if AOperation = roSet then begin if AConsiderOrigin then begin ARegionOrigin := DCOrigin; ARegion.Offset(ARegionOrigin.X, ARegionOrigin.Y); end; SelectClipRgn(Handle, ARegion.Handle); if ADestroyRegion then ARegion.Free else if AConsiderOrigin then ARegion.Offset(-ARegionOrigin.X, -ARegionOrigin.Y); end else begin AClipRegion := GetClipRegion(AConsiderOrigin); AClipRegion.Combine(ARegion, AOperation, ADestroyRegion); SetClipRegion(AClipRegion, roSet, True, AConsiderOrigin); end; end; function TcxCanvas.RectFullyVisible(const R: TRect): Boolean; var AClipRegion, ARegion: TcxRegion; begin AClipRegion := GetClipRegion; ARegion := TcxRegion.Create(R); try CombineRgn(AClipRegion.Handle, AClipRegion.Handle, ARegion.Handle, RGN_AND); Result := AClipRegion.IsEqual(ARegion); finally ARegion.Free; AClipRegion.Free; end; end; function TcxCanvas.RectVisible({$IFDEF VCL}const {$ENDIF}R: TRect): Boolean; begin {$IFDEF VCL} Result := Windows.RectVisible(Handle, R); {$ELSE} Result := not QPainter_hasClipping(Handle); if Result then Result := not IsRectEmpty(R) else begin Inc(R.Right); Inc(R.Bottom); Result := QRegion_contains(QPainter_clipRegion(Handle), PRect(@R)); end; {$ENDIF} end; { TScreenCanvas } type TScreenCanvas = class({$IFDEF VCL}TCanvas{$ELSE}TQtCanvas{$ENDIF}) private {$IFNDEF VCL} FWidget: QOpenWidgetH; FWidgetFlags: Integer; {$ENDIF} {$IFDEF VCL} procedure FreeHandle; protected procedure CreateHandle; override; {$ENDIF} public constructor Create; destructor Destroy; override; end; constructor TScreenCanvas.Create; begin inherited Create; {$IFNDEF VCL} FWidget := QOpenWidgetH(QApplication_desktop); FWidgetFlags := QOpenWidget_getWFlags(FWidget); QOpenWidget_setWFlags(FWidget, FWidgetFlags or Integer(WidgetFlags_WPaintUnclipped)); QtHandle := FWidget; Start; {$ENDIF} end; destructor TScreenCanvas.Destroy; begin {$IFDEF VCL} FreeHandle; {$ELSE} Stop; QOpenWidget_setWFlags(FWidget, FWidgetFlags); {$ENDIF} inherited; end; {$IFDEF VCL} procedure TScreenCanvas.FreeHandle; begin ReleaseDC(0, Handle); Handle := 0; end; procedure TScreenCanvas.CreateHandle; begin Handle := GetDC(0); end; {$ENDIF} { TcxScreenCanvas } constructor TcxScreenCanvas.Create; begin inherited Create(TScreenCanvas.Create); end; destructor TcxScreenCanvas.Destroy; begin FCanvas.Free; inherited; end; { TcxBitmap } procedure TcxBitmap.Assign(Source: TPersistent); begin if not (Source is TBitmap) or not (Empty and TBitmap(Source).Empty) then inherited; end; {$IFNDEF CLR} {$IFDEF VCL} const SystemBrushes: TList = nil; SysColorPrefix = {$IFDEF DELPHI7} clSystemColor {$ELSE} $80000000 {$ENDIF}; BrushDataSize = SizeOf(TcxBrushData); scxBrushCacheReleaseUnusedBrush = 'Release unused brush'; {$ENDIF} destructor TcxBrushCache.Destroy; var I: Integer; begin try for I := 0 to FCount - 1 do FData[I].Brush.Free; finally inherited Destroy; end; end; procedure TcxBrushCache.BeginUpdate; begin Inc(FLockRef); end; procedure TcxBrushCache.EndUpdate; begin Inc(FLockRef); if (FLockRef = 0) and (FDeletedCount <> 0) then Pack; end; procedure TcxBrushCache.ReleaseBrush(var ABrush: TBrush); var AIndex: Integer; begin if ABrush <> nil then begin if not IsSystemBrush(ABrush) and IndexOf(ABrush.Color, AIndex) then begin with FData[AIndex] do begin Dec(RefCount); CacheCheck(RefCount < 0, scxBrushCacheReleaseUnusedBrush); if RefCount <= 0 then Delete(AIndex); end; end; end; end; procedure TcxBrushCache.SetBrushColor(var ABrush: TBrush; AColor: TColor); begin ReleaseBrush(ABrush); ABrush := Add(AColor); end; function TcxBrushCache.Add(AColor: TColor): TBrush; begin {$IFDEF VCL} if AColor and SysColorPrefix <> 0 then Result := TBrush(SystemBrushes[AColor and not SysColorPrefix]) else {$ENDIF} Result := AddItemAt(FindNearestItem(AColor), AColor); Result.Color := AColor; end; function TcxBrushCache.AddItemAt(AIndex: Integer; AColor: TColor): TBrush; var Delta: Integer; begin if (AIndex >= FCount) or (FData[AIndex].Color <> AColor) then begin if FCapacity <= FCount then begin Delta := FCapacity shr 2; if Delta < 8 then Delta := 8; Inc(FCapacity, Delta); SetLength(FData, FCapacity); end; if AIndex < FCount then Move(AIndex, AIndex + 1, FCount - AIndex); InitItem(FData[AIndex], AColor); Inc(FCount); end else if FData[AIndex].RefCount = 0 then Dec(FDeletedCount); Inc(FData[AIndex].RefCount); Result := FData[AIndex].Brush; end; procedure TcxBrushCache.CacheCheck(Value: Boolean; const AMessage: string); begin if Value then raise EBrushCache.Create(AMessage); end; procedure TcxBrushCache.Delete(AIndex: Integer); begin if FLockRef = 0 then begin FData[AIndex].Brush.Free; Dec(FCount); if AIndex < FCount then Move(AIndex + 1, AIndex, FCount - AIndex); end else Inc(FDeletedCount); end; function TcxBrushCache.IndexOf(AColor: TColor; out AIndex: Integer): Boolean; begin AIndex := -1; {$IFDEF VCL} if (AColor and SysColorPrefix = 0) then {$ENDIF} AIndex := FindNearestItem(AColor); Result := (AIndex >= 0) and (AIndex < FCount) and (FData[AIndex].Color = AColor); end; procedure TcxBrushCache.InitItem(var AItem: TcxBrushData; AColor: TColor); begin FillChar(AItem, BrushDataSize, 0); AItem.Brush := TBrush.Create; AItem.Brush.Color := AColor; end; function TcxBrushCache.IsSystemBrush(ABrush: TBrush): Boolean; begin Result := ABrush = nil; {$IFDEF VCL} Result := Result or ((ABrush.Color and SysColorPrefix) <> 0); {$ENDIF}; end; function TcxBrushCache.FindNearestItem(AColor: TColor): Integer; function Check(Min, Max: Integer): Integer; begin Result := Max; if AColor <= FData[Min].Color then Result := Min else if AColor > FData[Max].Color then AColor := Max + 1; end; var A, B, C: Integer; begin if FCount > 0 then begin A := 0; B := FCount - 1; if (FData[0].Color >= AColor) or (FData[B].Color <= AColor) then Result := Check(A, B) else begin while A < B do begin C := (A + B) shr 1; with FData[C] do begin if Color < AColor then A := C else if Color > AColor then B := C else B := A; end; end; Result := Check(A, B); end; end else Result := 0; end; procedure TcxBrushCache.Move(ASrc, ADst, ACount: Integer); begin System.Move(FData[ASrc], FData[ADst], ACount * BrushDataSize); end; procedure TcxBrushCache.Pack; var I, ACount: Integer; begin try ACount := 0; I := FCount - 1; while (ACount < FDeletedCount) and (I >= 0) do begin if FData[I].RefCount < 0 then begin Delete(I); Inc(ACount); end; Dec(I); end; finally FDeletedCount := 0; end; end; procedure TcxBrushCache.Recreate; var I: Integer; begin for I := 0 to FCount - 1 do with FData[I] do Brush.Color := Color; end; procedure TcxBrushCache.Release(AIndex: Integer); begin Dec(FData[AIndex].RefCount); if FData[AIndex].RefCount = 0 then Delete(AIndex); end; {$IFDEF VCL} procedure InitSystemBrushes; var I: Word; ABrush: TBrush; begin SystemBrushes := TList.Create; for I := COLOR_SCROLLBAR to COLOR_ENDCOLORS do begin ABrush := TBrush.Create; ABrush.Handle := GetSysColorBrush(I); SystemBrushes.Add(ABrush); end; end; procedure DestroySystemBrushes; var I: Integer; begin try for I := 0 to SystemBrushes.Count - 1 do TBrush(SystemBrushes[I]).Free; finally SystemBrushes.Free; end; end; {$ENDIF} procedure InitPredefinedBrushes; var ABitmap: {$IFDEF VCL} HBitmap {$ELSE} TBitmap{$ENDIF}; {$IFNDEF VCL} I, J: Integer; {$ENDIF} const APattern: array[0..7] of Word = ($00AA, $0055, $00AA, $0055, $00AA, $0055, $00AA, $0055); begin cxHalfToneBrush := TBrush.Create; {$IFDEF VCL} InitSystemBrushes; ABitmap := CreateBitmap(8, 8, 1, 1, @APattern); cxHalfToneBrush.Handle := CreatePatternBrush(ABitmap); DeleteObject(ABitmap); {$ELSE} ABitmap := cxCreateBitmap(TSize(cxPointPoint(8, 8)), pf1Bit); ABitmap.Monochrome := True; for I := 0 to 7 do for J := 0 to 7 do begin if ((APattern[I] and (1 shl J)) <> 0) then ABitmap.Canvas.Pen.Color := ColorToRGB(clBlack) else ABitmap.Canvas.Pen.Color := ColorToRGB(clWhite); ABitmap.Canvas.DrawPoint(J, K); end; cxHalfToneBrush.Bitmap := ABitmap; {$ENDIF} end; procedure DestroyPredefinedBrushes; begin DestroySystemBrushes; {$IFDEF DELPHI9} {$IFNDEF DELPHI10} cxHalfToneBrush.Bitmap.Free; {$ENDIF} {$ENDIF} cxHalfToneBrush.Free; end; {$ENDIF} var ALib: Integer; initialization {$IFNDEF CLR} InitPredefinedBrushes; {$ENDIF} ALib := LoadLibrary('msimg32.dll'); if ALib <> 0 then VCLAlphaBlend := GetProcAddress(ALib, 'AlphaBlend') else VCLAlphaBlend := nil; finalization if ALib <> 0 then FreeLibrary(ALib); {$IFNDEF CLR} DestroyPredefinedBrushes; FreeAndNil(ScreenCanvas); {$ENDIF} end.