From 7c4f9b75a2023331d0c1de7bb99a1a8a8270941e Mon Sep 17 00:00:00 2001 From: livius2 Date: Thu, 2 Nov 2023 21:30:33 +0100 Subject: [PATCH] CreateSystemImageSet, SetWindowTheme and small cleanup another small step. - moved vcl code of CreateSystemImageSet - moved specific vcl SetWindowTheme - small cleanup of unused TCanvasEx, WideCR, WideLF --- Source/VirtualTrees.BaseAncestorFMX.pas | 19 ++- Source/VirtualTrees.BaseAncestorVcl.pas | 149 +++++++++++++++++++++++- Source/VirtualTrees.BaseTree.pas | 146 +---------------------- 3 files changed, 170 insertions(+), 144 deletions(-) diff --git a/Source/VirtualTrees.BaseAncestorFMX.pas b/Source/VirtualTrees.BaseAncestorFMX.pas index 276e08c3..e080368b 100644 --- a/Source/VirtualTrees.BaseAncestorFMX.pas +++ b/Source/VirtualTrees.BaseAncestorFMX.pas @@ -60,6 +60,8 @@ TVTBaseAncestorFMX = class abstract(TRectangle) procedure DragCanceled; virtual; abstract; procedure Resize; override; + function CreateSystemImageSet(): TImageList; + procedure SetWindowTheme(const Theme: string); virtual; procedure ChangeScale(M, D: Integer{$if CompilerVersion >= 31}; isDpiChange: Boolean{$ifend}); virtual; abstract; function GetControlsAlignment: TAlignment; virtual; abstract; @@ -68,7 +70,7 @@ TVTBaseAncestorFMX = class abstract(TRectangle) procedure MarkCutCopyNodes; virtual; abstract; function GetSortedCutCopySet(Resolve: Boolean): TNodeArray; virtual; abstract; function GetSortedSelection(Resolve: Boolean): TNodeArray; virtual; abstract; - procedure WriteNode(Stream: TStream; Node: PVirtualNode); virtual; abstract; + procedure WriteNode(Stream: TStream; Node: PVirtualNode); virtual; abstract; protected //properties property DottedBrushTreeLines: TStrokeBrush read FDottedBrushTreeLines write FDottedBrushTreeLines; property DottedBrushGridLines: TStrokeBrush read FDottedBrushGridLines write FDottedBrushGridLines; @@ -606,4 +608,19 @@ function TVTBaseAncestorFMX.GetSystemMetrics(nIndex: Integer): Integer; {$ENDIF} end; +//---------------------------------------------------------------------------------------------------------------------- + +function TVTBaseAncestorFMX.CreateSystemImageSet(): TImageList; +begin + Result:= TImageList.Create(Self); + FillSystemCheckImages(Self, Result); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTBaseAncestorFMX.SetWindowTheme(const Theme: string); +begin + //nothing +end; + end. diff --git a/Source/VirtualTrees.BaseAncestorVcl.pas b/Source/VirtualTrees.BaseAncestorVcl.pas index fa17cde2..6e5ad0d8 100644 --- a/Source/VirtualTrees.BaseAncestorVcl.pas +++ b/Source/VirtualTrees.BaseAncestorVcl.pas @@ -37,6 +37,8 @@ TVTBaseAncestorVcl = class abstract(TCustomControl) function RenderOLEData(const FormatEtcIn: TFormatEtc; out Medium: TStgMedium; ForClipboard: Boolean): HResult; virtual; procedure NotifyAccessibleEvent(pEvent: DWord = EVENT_OBJECT_STATECHANGE); function PrepareDottedBrush(CurrentDottedBrush: TBrush; Bits: Pointer; const BitsLinesCount: Word): TBrush; virtual; + function CreateSystemImageSet(): TImageList; + procedure SetWindowTheme(const Theme: string); virtual; //// Abtract method that are implemented in TBaseVirtualTree, keep in sync with TVTBaseAncestorFMX function GetSelectedCount(): Integer; virtual; abstract; procedure MarkCutCopyNodes; virtual; abstract; @@ -104,10 +106,17 @@ implementation uses System.SyncObjs, + System.SysUtils, Vcl.AxCtrls, + Vcl.Forms, + Vcl.Themes, + Winapi.CommCtrl, + Winapi.ShlObj, + Winapi.UxTheme, VirtualTrees.DataObject, VirtualTrees.Clipboard, - VirtualTrees.AccessibilityFactory; + VirtualTrees.AccessibilityFactory, + VirtualTrees.StyleHooks; //---------------------------------------------------------------------------------------------------------------------- @@ -283,6 +292,137 @@ procedure TVTBaseAncestorVcl.CopyToClipboard; end; end; +function TVTBaseAncestorVcl.CreateSystemImageSet: TImageList; + +// Creates a system check image set. +// Note: the DarkCheckImages and FlatImages image lists must already be filled, as some images from them are copied here. + +const + MaskColor: TColor = clRed; + cFlags = ILC_COLOR32 or ILC_MASK; + +var + BM: TBitmap; + Theme: HTHEME; + Details: TThemedElementDetails; + + //--------------------------------------------------------------------------- + + // Mitigator function to use the correct style service for this context (either the style assigned to the control for Delphi > 10.4 or the application style) + function StyleServices: TCustomStyleServices; + begin + Result := VTStyleServices(Self); + end; + + procedure AddSystemImage(IL: TImageList; Index: Integer); + const + States: array [0..19] of Integer = ( + RBS_UNCHECKEDNORMAL, RBS_UNCHECKEDHOT, RBS_UNCHECKEDPRESSED, RBS_UNCHECKEDDISABLED, + RBS_CHECKEDNORMAL, RBS_CHECKEDHOT, RBS_CHECKEDPRESSED, RBS_CHECKEDDISABLED, + CBS_UNCHECKEDNORMAL, CBS_UNCHECKEDHOT, CBS_UNCHECKEDPRESSED, CBS_UNCHECKEDDISABLED, + CBS_CHECKEDNORMAL, CBS_CHECKEDHOT, CBS_CHECKEDPRESSED, CBS_CHECKEDDISABLED, + CBS_MIXEDNORMAL, CBS_MIXEDHOT, CBS_MIXEDPRESSED, CBS_MIXEDDISABLED); + var + ButtonState: Cardinal; + ButtonType: Cardinal; + + begin + BM.Canvas.FillRect(Rect(0, 0, BM.Width, BM.Height)); + if StyleServices.Enabled and StyleServices.IsSystemStyle then + begin + if Index < 8 then + Details.Part := BP_RADIOBUTTON + else + Details.Part := BP_CHECKBOX; + Details.State := States[Index]; + DrawThemeBackground(Theme, BM.Canvas.Handle, Details.Part, Details.State, Rect(0, 0, BM.Width, BM.Height), nil); + end + else + begin + if Index < 8 then + ButtonType := DFCS_BUTTONRADIO + else + ButtonType := DFCS_BUTTONCHECK; + if Index >= 16 then + ButtonType := ButtonType or DFCS_BUTTON3STATE; + + case Index mod 4 of + 0: + ButtonState := 0; + 1: + ButtonState := DFCS_HOT; + 2: + ButtonState := DFCS_PUSHED; + else + ButtonState := DFCS_INACTIVE; + end; + if Index in [4..7, 12..19] then + ButtonState := ButtonState or DFCS_CHECKED; +// if Flat then +// ButtonState := ButtonState or DFCS_FLAT; + DrawFrameControl(BM.Canvas.Handle, Rect(0, 0, BM.Width, BM.Height), DFC_BUTTON, ButtonType or ButtonState); + end; + IL.AddMasked(BM, MaskColor); + end; + + //--------------- end local functions --------------------------------------- + +const + cDefaultCheckboxSize = 13;// Used when no other value is available +var + I: Integer; + lSize: TSize; + Res: Boolean; +begin + BM := TBitmap.Create; // Create a temporary bitmap, which holds the intermediate images. + try + Res := False; + // Retrieve the checkbox image size, prefer theme if available, fall back to GetSystemMetrics() otherwise, but this returns odd results on Windows 8 and higher in high-dpi scenarios. + if StyleServices.Enabled then + if StyleServices.IsSystemStyle then + begin + {$if CompilerVersion >= 33} + if TOSVersion.Check(10) and (TOSVersion.Build >= 15063) then + Theme := OpenThemeDataForDPI(Handle, 'BUTTON', CurrentPPI) + else + {$ifend} + Theme := OpenThemeData(Self.Handle, 'BUTTON'); + Details := StyleServices.GetElementDetails(tbCheckBoxUncheckedNormal); + Res := GetThemePartSize(Theme, BM.Canvas.Handle, Details.Part, Details.State, nil, TS_TRUE, lSize) = S_OK; + end + else + Res := StyleServices.GetElementSize(BM.Canvas.Handle, StyleServices.GetElementDetails(tbCheckBoxUncheckedNormal), TElementSize.esActual, lSize {$IF CompilerVersion >= 34}, Self.CurrentPPI{$IFEND}); + if not Res then begin + lSize := TSize.Create(GetSystemMetrics(SM_CXMENUCHECK), GetSystemMetrics(SM_CYMENUCHECK)); + if lSize.cx = 0 then begin // error? (Should happen rarely only) + lSize.cx := MulDiv(cDefaultCheckboxSize, Screen.PixelsPerInch, USER_DEFAULT_SCREEN_DPI); + lSize.cy := lSize.cx; + end;// if + end;//if + + Result := TImageList.CreateSize(lSize.cx, lSize.cy); + Result.Handle := ImageList_Create(Result.Width, Result.Height, cFlags, 0, Result.AllocBy); + Result.Masked := True; + Result.BkColor := clWhite; + + // Make the bitmap the same size as the image list is to avoid problems when adding. + BM.SetSize(Result.Width, Result.Height); + BM.Canvas.Brush.Color := MaskColor; + BM.Canvas.Brush.Style := bsSolid; + BM.Canvas.FillRect(Rect(0, 0, BM.Width, BM.Height)); + Result.AddMasked(BM, MaskColor); + + // Add the 20 system checkbox and radiobutton images. + for I := 0 to 19 do + AddSystemImage(Result, I); + if StyleServices.Enabled and StyleServices.IsSystemStyle then + CloseThemeData(Theme); + + finally + BM.Free; + end; +end; + procedure TVTBaseAncestorVcl.CutToClipboard; var lDataObject: IDataObject; @@ -409,6 +549,13 @@ function TVTBaseAncestorVcl.SetScrollInfo(Bar: Integer; const ScrollInfo: TScrol //---------------------------------------------------------------------------------------------------------------------- +procedure TVTBaseAncestorVcl.SetWindowTheme(const Theme: string); +begin + Winapi.UxTheme.SetWindowTheme(Handle, PWideChar(Theme), nil); +end; + +//---------------------------------------------------------------------------------------------------------------------- + function TVTBaseAncestorVcl.GetScrollInfo(Bar: Integer; var ScrollInfo: TScrollInfo): Boolean; begin Result:= WinApi.Windows.GetScrollInfo(Handle, Bar, ScrollInfo); diff --git a/Source/VirtualTrees.BaseTree.pas b/Source/VirtualTrees.BaseTree.pas index aeedec7d..65ab8cdd 100644 --- a/Source/VirtualTrees.BaseTree.pas +++ b/Source/VirtualTrees.BaseTree.pas @@ -734,7 +734,6 @@ TBaseVirtualTree = class abstract(TVTBaseAncestor) NewRect: TRect): Boolean; procedure ClearNodeBackground(const PaintInfo: TVTPaintInfo; UseBackground, Floating: Boolean; R: TRect); function CompareNodePositions(Node1, Node2: PVirtualNode; ConsiderChildrenAbove: Boolean = False): Integer; - function CreateSystemImageSet(): TImageList; procedure DrawLineImage(const PaintInfo: TVTPaintInfo; X, Y, H, VAlign: TDimension; Style: TVTLineType; Reverse: Boolean); function FindInPositionCache(Node: PVirtualNode; var CurrentPos: TDimension): PVirtualNode; overload; function FindInPositionCache(Position: TDimension; var CurrentPos: TDimension): PVirtualNode; overload; @@ -1144,7 +1143,7 @@ TBaseVirtualTree = class abstract(TVTBaseAncestor) procedure SetChildCount(Node: PVirtualNode; NewChildCount: Cardinal); virtual; procedure SetFocusedNodeAndColumn(Node: PVirtualNode; Column: TColumnIndex); virtual; procedure SetRangeX(value: TDimension); - procedure SetWindowTheme(const Theme: string); + procedure SetWindowTheme(const Theme: string); override; procedure SetVisibleCount(value : Cardinal); procedure SkipNode(Stream: TStream); virtual; procedure StartOperation(OperationKind: TVTOperationKind); @@ -1724,15 +1723,10 @@ TToggleAnimationData = record MissedSteps: Double; end; - TCanvasEx = class(TCanvas); - const MagicID: TMagicID = (#$2045, 'V', 'T', WideChar(VTTreeStreamVersion), ' ', #$2046); - WideCR = Char(#13); - WideLF = Char(#10); - var gWatcher: TCriticalSection = nil; gInitialized: Integer = 0; // >0 if global structures have been initialized; otherwise 0 @@ -1789,140 +1783,6 @@ procedure QuickSort(const TheArray: TNodeArray; L, R: Integer); until I >= R; end; -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.CreateSystemImageSet(): TImageList; - -// Creates a system check image set. -// Note: the DarkCheckImages and FlatImages image lists must already be filled, as some images from them are copied here. - -const - MaskColor: TColor = clRed; - cFlags = ILC_COLOR32 or ILC_MASK; - -var - BM: TBitmap; - Theme: HTHEME; - Details: TThemedElementDetails; - - //--------------------------------------------------------------------------- - - // Mitigator function to use the correct style service for this context (either the style assigned to the control for Delphi > 10.4 or the application style) - function StyleServices: TCustomStyleServices; - begin - Result := VTStyleServices(Self); - end; - - procedure AddSystemImage(IL: TImageList; Index: Integer); - const - States: array [0..19] of Integer = ( - RBS_UNCHECKEDNORMAL, RBS_UNCHECKEDHOT, RBS_UNCHECKEDPRESSED, RBS_UNCHECKEDDISABLED, - RBS_CHECKEDNORMAL, RBS_CHECKEDHOT, RBS_CHECKEDPRESSED, RBS_CHECKEDDISABLED, - CBS_UNCHECKEDNORMAL, CBS_UNCHECKEDHOT, CBS_UNCHECKEDPRESSED, CBS_UNCHECKEDDISABLED, - CBS_CHECKEDNORMAL, CBS_CHECKEDHOT, CBS_CHECKEDPRESSED, CBS_CHECKEDDISABLED, - CBS_MIXEDNORMAL, CBS_MIXEDHOT, CBS_MIXEDPRESSED, CBS_MIXEDDISABLED); - var - ButtonState: Cardinal; - ButtonType: Cardinal; - - begin - BM.Canvas.FillRect(Rect(0, 0, BM.Width, BM.Height)); - if StyleServices.Enabled and StyleServices.IsSystemStyle then - begin - if Index < 8 then - Details.Part := BP_RADIOBUTTON - else - Details.Part := BP_CHECKBOX; - Details.State := States[Index]; - DrawThemeBackground(Theme, BM.Canvas.Handle, Details.Part, Details.State, Rect(0, 0, BM.Width, BM.Height), nil); - end - else - begin - if Index < 8 then - ButtonType := DFCS_BUTTONRADIO - else - ButtonType := DFCS_BUTTONCHECK; - if Index >= 16 then - ButtonType := ButtonType or DFCS_BUTTON3STATE; - - case Index mod 4 of - 0: - ButtonState := 0; - 1: - ButtonState := DFCS_HOT; - 2: - ButtonState := DFCS_PUSHED; - else - ButtonState := DFCS_INACTIVE; - end; - if Index in [4..7, 12..19] then - ButtonState := ButtonState or DFCS_CHECKED; -// if Flat then -// ButtonState := ButtonState or DFCS_FLAT; - DrawFrameControl(BM.Canvas.Handle, Rect(0, 0, BM.Width, BM.Height), DFC_BUTTON, ButtonType or ButtonState); - end; - IL.AddMasked(BM, MaskColor); - end; - - //--------------- end local functions --------------------------------------- - -const - cDefaultCheckboxSize = 13;// Used when no other value is available -var - I: Integer; - lSize: TSize; - Res: Boolean; -begin - BM := TBitmap.Create; // Create a temporary bitmap, which holds the intermediate images. - try - Res := False; - // Retrieve the checkbox image size, prefer theme if available, fall back to GetSystemMetrics() otherwise, but this returns odd results on Windows 8 and higher in high-dpi scenarios. - if StyleServices.Enabled then - if StyleServices.IsSystemStyle then - begin - {$if CompilerVersion >= 33} - if TOSVersion.Check(10) and (TOSVersion.Build >= 15063) then - Theme := OpenThemeDataForDPI(Handle, 'BUTTON', CurrentPPI) - else - {$ifend} - Theme := OpenThemeData(Self.Handle, 'BUTTON'); - Details := StyleServices.GetElementDetails(tbCheckBoxUncheckedNormal); - Res := GetThemePartSize(Theme, BM.Canvas.Handle, Details.Part, Details.State, nil, TS_TRUE, lSize) = S_OK; - end - else - Res := StyleServices.GetElementSize(BM.Canvas.Handle, StyleServices.GetElementDetails(tbCheckBoxUncheckedNormal), TElementSize.esActual, lSize {$IF CompilerVersion >= 34}, Self.CurrentPPI{$IFEND}); - if not Res then begin - lSize := TSize.Create(GetSystemMetrics(SM_CXMENUCHECK), GetSystemMetrics(SM_CYMENUCHECK)); - if lSize.cx = 0 then begin // error? (Should happen rarely only) - lSize.cx := MulDiv(cDefaultCheckboxSize, Screen.PixelsPerInch, USER_DEFAULT_SCREEN_DPI); - lSize.cy := lSize.cx; - end;// if - end;//if - - Result := TImageList.CreateSize(lSize.cx, lSize.cy); - Result.Handle := ImageList_Create(Result.Width, Result.Height, cFlags, 0, Result.AllocBy); - Result.Masked := True; - Result.BkColor := clWhite; - - // Make the bitmap the same size as the image list is to avoid problems when adding. - BM.SetSize(Result.Width, Result.Height); - BM.Canvas.Brush.Color := MaskColor; - BM.Canvas.Brush.Style := bsSolid; - BM.Canvas.FillRect(Rect(0, 0, BM.Width, BM.Height)); - Result.AddMasked(BM, MaskColor); - - // Add the 20 system checkbox and radiobutton images. - for I := 0 to 19 do - AddSystemImage(Result, I); - if StyleServices.Enabled and StyleServices.IsSystemStyle then - CloseThemeData(Theme); - - finally - BM.Free; - end; -end; - - //----------------- TVTVirtualNodeEnumerator --------------------------------------------------------------------------- function TVTVirtualNodeEnumerator.GetCurrent: PVirtualNode; @@ -5638,7 +5498,8 @@ procedure TBaseVirtualTree.SetWindowTheme(const Theme: string); begin FChangingTheme := True; - Winapi.UxTheme.SetWindowTheme(Handle, PWideChar(Theme), nil); + + inherited; end; //---------------------------------------------------------------------------------------------------------------------- @@ -12070,6 +11931,7 @@ function TBaseVirtualTree.GetOptionsClass: TTreeOptionsClass; end; //---------------------------------------------------------------------------------------------------------------------- + function TBaseVirtualTree.GetTreeFromDataObject(const DataObject: TVTDragDataObject): TBaseVirtualTree; begin Result:= nil;