diff --git a/components/virtualtreeview/Design/VirtualTreesReg.pas b/components/virtualtreeview/Design/VirtualTreesReg.pas index 141d49a8..094fe635 100644 --- a/components/virtualtreeview/Design/VirtualTreesReg.pas +++ b/components/virtualtreeview/Design/VirtualTreesReg.pas @@ -1,400 +1,400 @@ -unit VirtualTreesReg; - -// This unit is an addendum to VirtualTrees.pas and contains code of design time editors as well as -// for theirs and the tree's registration. - -interface - -// For some things to work we need code, which is classified as being unsafe for .NET. -{$warn UNSAFE_TYPE off} -{$warn UNSAFE_CAST off} -{$warn UNSAFE_CODE off} - -uses - Windows, Classes, DesignIntf, DesignEditors, VCLEditors, PropertyCategories, - ColnEdit, VirtualTrees, VirtualTrees.DrawTree, VirtualTrees.HeaderPopup; - -type - TVirtualTreeEditor = class (TDefaultEditor) - public - procedure Edit; override; - end; - -procedure Register; - -//---------------------------------------------------------------------------------------------------------------------- - -implementation - -uses - StrEdit, Dialogs, TypInfo, SysUtils, Graphics, CommCtrl, ImgList, Controls, - VirtualTrees.ClipBoard, VirtualTrees.Actions; - -type - // The usual trick to make a protected property accessible in the ShowCollectionEditor call below. - TVirtualTreeCast = class(TBaseVirtualTree); - - TClipboardElement = class(TNestedProperty, ICustomPropertyDrawing) - private - FElement: string; - protected - constructor Create(Parent: TPropertyEditor; AElement: string); reintroduce; - public - function AllEqual: Boolean; override; - function GetAttributes: TPropertyAttributes; override; - function GetName: string; override; - function GetValue: string; override; - procedure GetValues(Proc: TGetStrProc); override; - procedure SetValue(const Value: string); override; - - procedure PropDrawName(ACanvas: TCanvas; const ARect: TRect; ASelected: Boolean); - procedure PropDrawValue(ACanvas: TCanvas; const ARect: TRect; ASelected: Boolean); - end; - - // This is a special property editor to make the strings in the clipboard format string list - // being shown as subproperties in the object inspector. This way it is shown what formats are actually available - // and the user can pick them with a simple yes/no choice. - - TGetPropEditProc = TGetPropProc; - - TClipboardFormatsProperty = class(TStringListProperty, ICustomPropertyDrawing) - public - function GetAttributes: TPropertyAttributes; override; - procedure GetProperties(Proc: TGetPropEditProc); override; - procedure PropDrawName(ACanvas: TCanvas; const ARect: TRect; ASelected: Boolean); - procedure PropDrawValue(ACanvas: TCanvas; const ARect: TRect; ASelected: Boolean); - end; - - resourcestring - sVTHeaderCategoryName = 'Header'; - sVTPaintingCategoryName = 'Custom painting'; - sVTIncremenalCategoryName = 'Incremental search'; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeEditor.Edit; - -begin - ShowCollectionEditor(Designer, Component, TVirtualTreeCast(Component).Header.Columns, 'Columns'); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -constructor TClipboardElement.Create(Parent: TPropertyEditor; AElement: string); - -begin - inherited Create(Parent); - FElement := AElement; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TClipboardElement.AllEqual: Boolean; - -// Determines if this element is included or excluded in all selected components it belongs to. - -var - I, Index: Integer; - List: TClipboardFormats; - V: Boolean; - -begin - Result := False; - if PropCount > 1 then - begin - List := TClipboardFormats(GetOrdValue); - V := List.Find(FElement, Index); - for I := 1 to PropCount - 1 do - begin - List := TClipboardFormats(GetOrdValue); - if List.Find(FElement, Index) <> V then - Exit; - end; - end; - Result := True; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TClipboardElement.GetAttributes: TPropertyAttributes; - -begin - Result := [paMultiSelect, paValueList, paSortList]; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TClipboardElement.GetName: string; - -begin - Result := FElement; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TClipboardElement.GetValue: string; - -var - List: TClipboardFormats; - -begin - List := TClipboardFormats(GetOrdValue); - Result := BooleanIdents[List.IndexOf(FElement) > -1]; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TClipboardElement.GetValues(Proc: TGetStrProc); - -begin - Proc(BooleanIdents[False]); - Proc(BooleanIdents[True]); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TClipboardElement.SetValue(const Value: string); - -var - List: TClipboardFormats; - I, Index: Integer; - -begin - if CompareText(Value, 'True') = 0 then - begin - for I := 0 to PropCount - 1 do - begin - List := TClipboardFormats(GetOrdValueAt(I)); - List.Add(FElement); - end; - end - else - begin - for I := 0 to PropCount - 1 do - begin - List := TClipboardFormats(GetOrdValueAt(I)); - if List.Find(FElement, Index) then - List.Delete(Index); - end; - end; - Modified; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure DrawBoolean(Checked: Boolean; ACanvas: TCanvas; const ARect: TRect; ASelected: Boolean); - -var - BoxSize, - EntryWidth: Integer; - R: TRect; - State: Cardinal; - -begin - with ACanvas do - begin - FillRect(ARect); - - BoxSize := ARect.Bottom - ARect.Top; - EntryWidth := ARect.Right - ARect.Left; - - R := Rect(ARect.Left + (EntryWidth - BoxSize) div 2, ARect.Top, ARect.Left + (EntryWidth + BoxSize) div 2, - ARect.Bottom); - InflateRect(R, -1, -1); - State := DFCS_BUTTONCHECK; - if Checked then - State := State or DFCS_CHECKED; - DrawFrameControl(Handle, R, DFC_BUTTON, State); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TClipboardElement.PropDrawName(ACanvas: TCanvas; const ARect: TRect; ASelected: Boolean); - -begin - DefaultPropertyDrawName(Self, ACanvas, ARect); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TClipboardElement.PropDrawValue(ACanvas: TCanvas; const ARect: TRect; ASelected: Boolean); - -begin - DrawBoolean(CompareText(GetVisualValue, 'True') = 0, ACanvas, ARect, ASelected); -end; - -//----------------- TClipboardFormatsProperty -------------------------------------------------------------------------- - -function TClipboardFormatsProperty.GetAttributes: TPropertyAttributes; - -begin - Result := inherited GetAttributes + [paSubProperties, paFullWidthName]; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TClipboardFormatsProperty.GetProperties(Proc: TGetPropEditProc); - -var - List: TStringList; - I: Integer; - Tree: TBaseVirtualTree; - -begin - List := TStringList.Create; - Tree := TClipboardFormats(GetOrdValue).Owner; - EnumerateVTClipboardFormats(TVirtualTreeClass(Tree.ClassType), List); - for I := 0 to List.Count - 1 do - Proc(TClipboardElement.Create(Self, List[I])); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TClipboardFormatsProperty.PropDrawName(ACanvas: TCanvas; const ARect: TRect; ASelected: Boolean); - -var - S: string; - Width: Integer; - R: TRect; - -begin - with ACanvas do - begin - Font.Name := 'Arial'; - R := ARect; - Font.Color := clBlack; - S := GetName; - Width := TextWidth(S); - TextRect(R, R.Left + 1, R.Top + 1, S); - - Inc(R.Left, Width + 8); - Font.Height := 14; - Font.Color := clBtnHighlight; - S := '(OLE drag and clipboard)'; - SetBkMode(Handle, TRANSPARENT); - ExtTextOut(Handle, R.Left + 1, R.Top + 1, ETO_CLIPPED, @R, PChar(S), Length(S), nil); - Font.Color := clBtnShadow; - ExtTextOut(Handle, R.Left, R.Top, ETO_CLIPPED, @R, PChar(S), Length(S), nil); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TClipboardFormatsProperty.PropDrawValue(ACanvas: TCanvas; const ARect: TRect; ASelected: Boolean); - -begin - // Nothing to do here. -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure Register; - -begin - RegisterComponents('Virtual Controls', [TVirtualStringTree, TVirtualDrawTree, TVTHeaderPopupMenu]); - RegisterComponentEditor(TVirtualStringTree, TVirtualTreeEditor); - RegisterComponentEditor(TVirtualDrawTree, TVirtualTreeEditor); - RegisterPropertyEditor(TypeInfo(TClipboardFormats), nil, '', TClipboardFormatsProperty); - - // Categories: - RegisterPropertiesInCategory(sActionCategoryName, TBaseVirtualTree, ['ChangeDelay', 'EditDelay']); - - RegisterPropertiesInCategory(sDataCategoryName, - TBaseVirtualTree, - ['NodeDataSize', - 'RootNodeCount', - 'OnCompareNodes', - 'OnGetNodeDataSize', - 'OnInitNode', - 'OnInitChildren', - 'OnFreeNode', - 'OnGetNodeWidth', - 'OnGetPopupMenu', - 'OnLoadNode', - 'OnSaveNode', - 'OnResetNode', - 'OnNodeMov*', - 'OnStructureChange', - 'OnUpdating', - 'OnGetText', - 'OnNewText', - 'OnShortenString']); - - RegisterPropertiesInCategory(slayoutCategoryName, - TBaseVirtualTree, - ['AnimationDuration', - 'AutoExpandDelay', - 'AutoScroll*', - 'ButtonStyle', - 'DefaultNodeHeight', - '*Images*', 'OnGetImageIndex', 'OnGetImageText', - 'Header', - 'Indent', - 'LineStyle', 'OnGetLineStyle', - 'CheckImageKind', - 'Options', - 'Margin', - 'NodeAlignment', - 'ScrollBarOptions', - 'SelectionCurveRadius', - 'TextMargin']); - - RegisterPropertiesInCategory(sVisualCategoryName, - TBaseVirtualTree, - ['Background*', - 'ButtonFillMode', - 'CustomCheckimages', - 'Colors', - 'LineMode']); - - RegisterPropertiesInCategory(sHelpCategoryName, - TBaseVirtualTree, - ['AccessibleName', 'Hint*', 'On*Hint*', 'On*Help*']); - - RegisterPropertiesInCategory(sDragNDropCategoryName, - TBaseVirtualTree, - ['ClipboardFormats', - 'DefaultPasteMode', - 'OnCreateDataObject', - 'OnCreateDragManager', - 'OnGetUserClipboardFormats', - 'OnNodeCop*', - 'OnDragAllowed', - 'OnRenderOLEData']); - - RegisterPropertiesInCategory(sInputCategoryName, - TBaseVirtualTree, - ['DefaultText', - 'DrawSelectionMode', - 'WantTabs', - 'OnChang*', - 'OnCollaps*', - 'OnExpand*', - 'OnCheck*', - 'OnEdit*', - 'On*Click', - 'OnFocus*', - 'OnCreateEditor', - 'OnScroll', - 'OnNodeHeightTracking', - 'OnHotChange']); - - RegisterPropertiesInCategory(sVTHeaderCategoryName, - TBaseVirtualTree, - ['OnHeader*', 'OnGetHeader*']); - - RegisterPropertiesInCategory(sVTPaintingCategoryName, - TBaseVirtualTree, - ['On*Paint*', - 'OnDraw*', - 'On*Erase*']); - - RegisterPropertiesInCategory(sVTIncremenalCategoryName, - TBaseVirtualTree, - ['*Incremental*']); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -end. +unit VirtualTreesReg; + +// This unit is an addendum to VirtualTrees.pas and contains code of design time editors as well as +// for theirs and the tree's registration. + +interface + +// For some things to work we need code, which is classified as being unsafe for .NET. +{$warn UNSAFE_TYPE off} +{$warn UNSAFE_CAST off} +{$warn UNSAFE_CODE off} + +uses + Windows, Classes, DesignIntf, DesignEditors, VCLEditors, PropertyCategories, + ColnEdit, VirtualTrees, VirtualTrees.HeaderPopup; + +type + TVirtualTreeEditor = class (TDefaultEditor) + public + procedure Edit; override; + end; + +procedure Register; + +//---------------------------------------------------------------------------------------------------------------------- + +implementation + +uses + StrEdit, Dialogs, TypInfo, SysUtils, Graphics, CommCtrl, ImgList, Controls, + VirtualTrees.ClipBoard, VirtualTrees.Actions; + +type + // The usual trick to make a protected property accessible in the ShowCollectionEditor call below. + TVirtualTreeCast = class(TBaseVirtualTree); + + TClipboardElement = class(TNestedProperty, ICustomPropertyDrawing) + private + FElement: string; + protected + constructor Create(Parent: TPropertyEditor; AElement: string); reintroduce; + public + function AllEqual: Boolean; override; + function GetAttributes: TPropertyAttributes; override; + function GetName: string; override; + function GetValue: string; override; + procedure GetValues(Proc: TGetStrProc); override; + procedure SetValue(const Value: string); override; + + procedure PropDrawName(ACanvas: TCanvas; const ARect: TRect; ASelected: Boolean); + procedure PropDrawValue(ACanvas: TCanvas; const ARect: TRect; ASelected: Boolean); + end; + + // This is a special property editor to make the strings in the clipboard format string list + // being shown as subproperties in the object inspector. This way it is shown what formats are actually available + // and the user can pick them with a simple yes/no choice. + + TGetPropEditProc = TGetPropProc; + + TClipboardFormatsProperty = class(TStringListProperty, ICustomPropertyDrawing) + public + function GetAttributes: TPropertyAttributes; override; + procedure GetProperties(Proc: TGetPropEditProc); override; + procedure PropDrawName(ACanvas: TCanvas; const ARect: TRect; ASelected: Boolean); + procedure PropDrawValue(ACanvas: TCanvas; const ARect: TRect; ASelected: Boolean); + end; + + resourcestring + sVTHeaderCategoryName = 'Header'; + sVTPaintingCategoryName = 'Custom painting'; + sVTIncremenalCategoryName = 'Incremental search'; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeEditor.Edit; + +begin + ShowCollectionEditor(Designer, Component, TVirtualTreeCast(Component).Header.Columns, 'Columns'); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +constructor TClipboardElement.Create(Parent: TPropertyEditor; AElement: string); + +begin + inherited Create(Parent); + FElement := AElement; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TClipboardElement.AllEqual: Boolean; + +// Determines if this element is included or excluded in all selected components it belongs to. + +var + I, Index: Integer; + List: TClipboardFormats; + V: Boolean; + +begin + Result := False; + if PropCount > 1 then + begin + List := TClipboardFormats(GetOrdValue); + V := List.Find(FElement, Index); + for I := 1 to PropCount - 1 do + begin + List := TClipboardFormats(GetOrdValue); + if List.Find(FElement, Index) <> V then + Exit; + end; + end; + Result := True; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TClipboardElement.GetAttributes: TPropertyAttributes; + +begin + Result := [paMultiSelect, paValueList, paSortList]; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TClipboardElement.GetName: string; + +begin + Result := FElement; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TClipboardElement.GetValue: string; + +var + List: TClipboardFormats; + +begin + List := TClipboardFormats(GetOrdValue); + Result := BooleanIdents[List.IndexOf(FElement) > -1]; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TClipboardElement.GetValues(Proc: TGetStrProc); + +begin + Proc(BooleanIdents[False]); + Proc(BooleanIdents[True]); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TClipboardElement.SetValue(const Value: string); + +var + List: TClipboardFormats; + I, Index: Integer; + +begin + if CompareText(Value, 'True') = 0 then + begin + for I := 0 to PropCount - 1 do + begin + List := TClipboardFormats(GetOrdValueAt(I)); + List.Add(FElement); + end; + end + else + begin + for I := 0 to PropCount - 1 do + begin + List := TClipboardFormats(GetOrdValueAt(I)); + if List.Find(FElement, Index) then + List.Delete(Index); + end; + end; + Modified; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure DrawBoolean(Checked: Boolean; ACanvas: TCanvas; const ARect: TRect; ASelected: Boolean); + +var + BoxSize, + EntryWidth: Integer; + R: TRect; + State: Cardinal; + +begin + with ACanvas do + begin + FillRect(ARect); + + BoxSize := ARect.Bottom - ARect.Top; + EntryWidth := ARect.Right - ARect.Left; + + R := Rect(ARect.Left + (EntryWidth - BoxSize) div 2, ARect.Top, ARect.Left + (EntryWidth + BoxSize) div 2, + ARect.Bottom); + InflateRect(R, -1, -1); + State := DFCS_BUTTONCHECK; + if Checked then + State := State or DFCS_CHECKED; + DrawFrameControl(Handle, R, DFC_BUTTON, State); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TClipboardElement.PropDrawName(ACanvas: TCanvas; const ARect: TRect; ASelected: Boolean); + +begin + DefaultPropertyDrawName(Self, ACanvas, ARect); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TClipboardElement.PropDrawValue(ACanvas: TCanvas; const ARect: TRect; ASelected: Boolean); + +begin + DrawBoolean(CompareText(GetVisualValue, 'True') = 0, ACanvas, ARect, ASelected); +end; + +//----------------- TClipboardFormatsProperty -------------------------------------------------------------------------- + +function TClipboardFormatsProperty.GetAttributes: TPropertyAttributes; + +begin + Result := inherited GetAttributes + [paSubProperties, paFullWidthName]; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TClipboardFormatsProperty.GetProperties(Proc: TGetPropEditProc); + +var + List: TStringList; + I: Integer; + Tree: TBaseVirtualTree; + +begin + List := TStringList.Create; + Tree := TClipboardFormats(GetOrdValue).Owner; + EnumerateVTClipboardFormats(TVirtualTreeClass(Tree.ClassType), List); + for I := 0 to List.Count - 1 do + Proc(TClipboardElement.Create(Self, List[I])); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TClipboardFormatsProperty.PropDrawName(ACanvas: TCanvas; const ARect: TRect; ASelected: Boolean); + +var + S: string; + Width: Integer; + R: TRect; + +begin + with ACanvas do + begin + Font.Name := 'Arial'; + R := ARect; + Font.Color := clBlack; + S := GetName; + Width := TextWidth(S); + TextRect(R, R.Left + 1, R.Top + 1, S); + + Inc(R.Left, Width + 8); + Font.Height := 14; + Font.Color := clBtnHighlight; + S := '(OLE drag and clipboard)'; + SetBkMode(Handle, TRANSPARENT); + ExtTextOut(Handle, R.Left + 1, R.Top + 1, ETO_CLIPPED, @R, PChar(S), Length(S), nil); + Font.Color := clBtnShadow; + ExtTextOut(Handle, R.Left, R.Top, ETO_CLIPPED, @R, PChar(S), Length(S), nil); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TClipboardFormatsProperty.PropDrawValue(ACanvas: TCanvas; const ARect: TRect; ASelected: Boolean); + +begin + // Nothing to do here. +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure Register; + +begin + RegisterComponents('Virtual Controls', [TVirtualStringTree, TVirtualDrawTree, TVTHeaderPopupMenu]); + RegisterComponentEditor(TVirtualStringTree, TVirtualTreeEditor); + RegisterComponentEditor(TVirtualDrawTree, TVirtualTreeEditor); + RegisterPropertyEditor(TypeInfo(TClipboardFormats), nil, '', TClipboardFormatsProperty); + + // Categories: + RegisterPropertiesInCategory(sActionCategoryName, TBaseVirtualTree, ['ChangeDelay', 'EditDelay']); + + RegisterPropertiesInCategory(sDataCategoryName, + TBaseVirtualTree, + ['NodeDataSize', + 'RootNodeCount', + 'OnCompareNodes', + 'OnGetNodeDataSize', + 'OnInitNode', + 'OnInitChildren', + 'OnFreeNode', + 'OnGetNodeWidth', + 'OnGetPopupMenu', + 'OnLoadNode', + 'OnSaveNode', + 'OnResetNode', + 'OnNodeMov*', + 'OnStructureChange', + 'OnUpdating', + 'OnGetText', + 'OnNewText', + 'OnShortenString']); + + RegisterPropertiesInCategory(slayoutCategoryName, + TBaseVirtualTree, + ['AnimationDuration', + 'AutoExpandDelay', + 'AutoScroll*', + 'ButtonStyle', + 'DefaultNodeHeight', + '*Images*', 'OnGetImageIndex', 'OnGetImageText', + 'Header', + 'Indent', + 'LineStyle', 'OnGetLineStyle', + 'CheckImageKind', + 'Options', + 'Margin', + 'NodeAlignment', + 'ScrollBarOptions', + 'SelectionCurveRadius', + 'TextMargin']); + + RegisterPropertiesInCategory(sVisualCategoryName, + TBaseVirtualTree, + ['Background*', + 'ButtonFillMode', + 'CustomCheckimages', + 'Colors', + 'LineMode']); + + RegisterPropertiesInCategory(sHelpCategoryName, + TBaseVirtualTree, + ['AccessibleName', 'Hint*', 'On*Hint*', 'On*Help*']); + + RegisterPropertiesInCategory(sDragNDropCategoryName, + TBaseVirtualTree, + ['ClipboardFormats', + 'DefaultPasteMode', + 'OnCreateDataObject', + 'OnCreateDragManager', + 'OnGetUserClipboardFormats', + 'OnNodeCop*', + 'OnDragAllowed', + 'OnRenderOLEData']); + + RegisterPropertiesInCategory(sInputCategoryName, + TBaseVirtualTree, + ['DefaultText', + 'DrawSelectionMode', + 'WantTabs', + 'OnChang*', + 'OnCollaps*', + 'OnExpand*', + 'OnCheck*', + 'OnEdit*', + 'On*Click', + 'OnFocus*', + 'OnCreateEditor', + 'OnScroll', + 'OnNodeHeightTracking', + 'OnHotChange']); + + RegisterPropertiesInCategory(sVTHeaderCategoryName, + TBaseVirtualTree, + ['OnHeader*', 'OnGetHeader*']); + + RegisterPropertiesInCategory(sVTPaintingCategoryName, + TBaseVirtualTree, + ['On*Paint*', + 'OnDraw*', + 'On*Erase*']); + + RegisterPropertiesInCategory(sVTIncremenalCategoryName, + TBaseVirtualTree, + ['*Incremental*']); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +end. diff --git a/components/virtualtreeview/MAKEFILE b/components/virtualtreeview/MAKEFILE index e10d0294..aba6f01c 100644 --- a/components/virtualtreeview/MAKEFILE +++ b/components/virtualtreeview/MAKEFILE @@ -3,6 +3,9 @@ EMBARCADERO = $(PROGRAMFILES)\Embarcadero\RAD Studio STUDIO = $(PROGRAMFILES)\Embarcadero\Studio BDSCOMMONDIRMAIN = %PUBLIC%\Documents\Embarcadero\Studio # Default MS Build version +!IF EXIST("$(PROGRAMFILESX64)\Microsoft Visual Studio\2022\Enterprise\MSBuild\Current\Bin\msbuild.exe") +BUILDEXE = "$(PROGRAMFILESX64)\Microsoft Visual Studio\2022\Enterprise\MSBuild\Current\Bin\msbuild.exe" +!ELSE !IF EXIST("$(PROGRAMFILES)\Microsoft Visual Studio\2019\Enterprise\MSBuild\Current\Bin\msbuild.exe") BUILDEXE = "$(PROGRAMFILES)\Microsoft Visual Studio\2019\Enterprise\MSBuild\Current\Bin\msbuild.exe" !ELSE @@ -12,6 +15,7 @@ BUILDEXE = "$(PROGRAMFILES)\Microsoft Visual Studio\2019\Professional\MSBuild\Cu BUILDEXE = "$(PROGRAMFILES)\Microsoft Visual Studio\2017\BuildTools\MSBuild\15.0\Bin\msbuild.exe" !ENDIF !ENDIF +!ENDIF BUILD = $(BUILDEXE) /t:Rebuild clean: @@ -50,7 +54,6 @@ _release: #Download e.g. from: ftp://ftp.info-zip.org/pub/infozip/win32/ ZIP -9 -r .\VirtualTreeView.zip INSTALL.txt Changes.txt Source Design Packages Demos Contributions Help\VirtualTreeview.chm -i *.pas -i *.dpk -i *.groupproj -i *.dproj -i *.cbproj -i *.hlp -i *.rc -i *.res -i *.cfg -i *.dpr -i *.dof -i *.bpr -i *.dfm -i *.cpp -i *.inc -i *.dcr -i *.chm -i *.png -i *.js -i *.txt -i *.bmp -i *.uni ECHO Source code zip archive "VirtualTreeView.zip" created. - ECHO !!! Please ensure that the const TVTVersion is correct or remove const!!! ECHO !!! Please add version number to ZIP file name!!! ECHO !!! Please create release at: https://github.com/Virtual-TreeView/Virtual-TreeView/releases ECHO !!! Let JAM web-team upload the file to our server at https://www.jam-software.com/virtual-treeview diff --git a/components/virtualtreeview/README.md b/components/virtualtreeview/README.md index b4d981bf..d05cef65 100644 --- a/components/virtualtreeview/README.md +++ b/components/virtualtreeview/README.md @@ -5,7 +5,7 @@ Virtual Treeview is a Delphi treeview control built from ground up. Many years o I don't use C++ Builder and my experience with it is very limited. This makes it difficult to take care about bugs that are reported in C++ Builder and to maintain the C++ Builder packages. I would be great if someone would volunteer to do this. ### Downloads -**V7.5** official release for **RAD Studio XE3 to 10.4.2 Rio**: [JAM Software](https://www.jam-software.com/virtual-treeview/VirtualTreeView.zip) ([Changes](https://github.com/JAM-Software/Virtual-TreeView/issues?q=is%3Aissue+milestone%3AV7.5+is%3Aclosed)) +**V7.6.x** official release for **RAD Studio XE3 to 10.4.2 Rio**: [JAM Software](https://www.jam-software.com/virtual-treeview/VirtualTreeView.zip) An experimental **FireMonkey** port can be found here: [livius2/Virtual-TreeView](https://github.com/livius2/Virtual-TreeView) diff --git a/components/virtualtreeview/Source/VirtualTrees.Accessibility.pas b/components/virtualtreeview/Source/VirtualTrees.Accessibility.pas index 8e5d19ab..04b516d2 100644 --- a/components/virtualtreeview/Source/VirtualTrees.Accessibility.pas +++ b/components/virtualtreeview/Source/VirtualTrees.Accessibility.pas @@ -99,8 +99,7 @@ type implementation uses - System.SysUtils, Vcl.Forms, System.Variants, System.Math, - VirtualTrees.Types; + System.SysUtils, Vcl.Forms, System.Variants, System.Math; type diff --git a/components/virtualtreeview/Source/VirtualTrees.AccessibilityFactory.pas b/components/virtualtreeview/Source/VirtualTrees.AccessibilityFactory.pas index d6270313..5c772d81 100644 --- a/components/virtualtreeview/Source/VirtualTrees.AccessibilityFactory.pas +++ b/components/virtualtreeview/Source/VirtualTrees.AccessibilityFactory.pas @@ -1,178 +1,178 @@ -unit VirtualTrees.AccessibilityFactory; - -// The contents of this file are subject to the Mozilla Public License -// Version 1.1 (the "License"); you may not use this file except in compliance -// with the License. You may obtain a copy of the License at http://www.mozilla.org/MPL/ -// -// Alternatively, you may redistribute this library, use and/or modify it under the terms of the -// GNU Lesser General Public License as published by the Free Software Foundation; -// either version 2.1 of the License, or (at your option) any later version. -// You may obtain a copy of the LGPL at http://www.gnu.org/copyleft/. -// -// Software distributed under the License is distributed on an "AS IS" basis, -// WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for the -// specific language governing rights and limitations under the License. -// -// The original code is VirtualTrees.pas, released September 30, 2000. -// -// The initial developer of the original code is digital publishing AG (Munich, Germany, www.digitalpublishing.de), -// written by Mike Lischke (public@soft-gems.net, www.soft-gems.net). -// -// Portions created by digital publishing AG are Copyright -// (C) 1999-2001 digital publishing AG. All Rights Reserved. -//---------------------------------------------------------------------------------------------------------------------- - - -// class to create IAccessibles for the tree passed into it. -// If not already assigned, creates IAccessibles for the tree itself -// and the focused item -// the tree accessible is returned when the tree receives an WM_GETOBJECT message -// the AccessibleItem is returned when the Accessible is being asked for the first child -// To create your own IAccessibles, use the VTStandardAccessible unit as a reference, -// and assign your Accessibles to the variables in the unit's initialization. -// You only need to add the unit to your project, and voilá, you have an accessible string tree! -// -// Written by Marco Zehe. (c) 2007 - -interface - -uses - System.Classes, Winapi.oleacc, VirtualTrees; - -type - IVTAccessibleProvider = interface - function CreateIAccessible(ATree: TBaseVirtualTree): IAccessible; - end; - - TVTAccessibilityFactory = class(TObject) - strict private class var - FAccessibilityAvailable: Boolean; - FVTAccessibleFactory: TVTAccessibilityFactory; - strict private - FAccessibleProviders: TInterfaceList; - private - class procedure FreeFactory; - public - constructor Create; - destructor Destroy; override; - function CreateIAccessible(ATree: TBaseVirtualTree): IAccessible; - class function GetAccessibilityFactory: TVTAccessibilityFactory; static; - procedure RegisterAccessibleProvider(const AProvider: IVTAccessibleProvider); - procedure UnRegisterAccessibleProvider(const AProvider: IVTAccessibleProvider); - end; - - -implementation - -{ TVTAccessibilityFactory } - -constructor TVTAccessibilityFactory.Create; -begin - inherited Create; - FAccessibleProviders := TInterfaceList.Create; - FAccessibleProviders.Clear; -end; - -function TVTAccessibilityFactory.CreateIAccessible( - ATree: TBaseVirtualTree): IAccessible; -var - I: Integer; - TmpIAccessible: IAccessible; -// returns an IAccessible. -// 1. If the Accessible property of the passed-in tree is nil, -// the first registered element will be returned. -// Usually, this is the IAccessible that provides information about the tree itself. -// If it is not nil, we'll check whether the AccessibleItem is nil. -// If it is, we'll look in the registered IAccessibles for the appropriate one. -// Each IAccessibleProvider will check the tree for properties to determine whether it is responsible. -// We'll work top to bottom, from the most complicated to the most simple. -// The index for these should all be greater than 0, e g the IAccessible for the tree itself should always be registered first, then any IAccessible items. -begin - Result := nil; - if ATree <> nil then - begin - if ATree.Accessible = nil then - begin - if FAccessibleProviders.Count > 0 then - begin - Result := IVTAccessibleProvider(FAccessibleProviders.Items[0]).CreateIAccessible(ATree); - Exit; - end; - end; - if ATree.AccessibleItem = nil then - begin - if FAccessibleProviders.Count > 0 then - begin - for I := FAccessibleProviders.Count - 1 downto 1 do - begin - TmpIAccessible := IVTAccessibleProvider(FAccessibleProviders.Items[I]).CreateIAccessible(ATree); - if TmpIAccessible <> nil then - begin - Result := TmpIAccessible; - Break; - end; - end; - if TmpIAccessible = nil then - begin - Result := IVTAccessibleProvider(FAccessibleProviders.Items[0]).CreateIAccessible(ATree); - end; - end; - end - else - Result := ATree.AccessibleItem; - end; -end; - -destructor TVTAccessibilityFactory.Destroy; -begin - FAccessibleProviders.Free; - FAccessibleProviders := nil; - inherited Destroy; -end; - -class procedure TVTAccessibilityFactory.FreeFactory; -begin - FVTAccessibleFactory.Free; -end; - -procedure TVTAccessibilityFactory.RegisterAccessibleProvider(const AProvider: IVTAccessibleProvider); -// Ads a provider if it is not already registered -begin - if FAccessibleProviders.IndexOf(AProvider) < 0 then - FAccessibleProviders.Add(AProvider) -end; - -procedure TVTAccessibilityFactory.UnRegisterAccessibleProvider(const AProvider: IVTAccessibleProvider); -// Unregisters/removes an IAccessible provider if it is present -begin - if FAccessibleProviders.IndexOf(AProvider) >= 0 then - FAccessibleProviders.Remove(AProvider); -end; - -class function TVTAccessibilityFactory.GetAccessibilityFactory: TVTAccessibilityFactory; -// Accessibility helper function to create a singleton class that will create or return -// the IAccessible interface for the tree and the focused node. - -begin - // first, check if we've loaded the library already - if not FAccessibilityAvailable then - FAccessibilityAvailable := True; - if FAccessibilityAvailable then - begin - // Check to see if the class has already been created. - if FVTAccessibleFactory = nil then - FVTAccessibleFactory := TVTAccessibilityFactory.Create; - Result := FVTAccessibleFactory; - end - else - Result := nil; -end; - -initialization - -finalization - TVTAccessibilityFactory.FreeFactory; - -end. - - +unit VirtualTrees.AccessibilityFactory; + +// The contents of this file are subject to the Mozilla Public License +// Version 1.1 (the "License"); you may not use this file except in compliance +// with the License. You may obtain a copy of the License at http://www.mozilla.org/MPL/ +// +// Alternatively, you may redistribute this library, use and/or modify it under the terms of the +// GNU Lesser General Public License as published by the Free Software Foundation; +// either version 2.1 of the License, or (at your option) any later version. +// You may obtain a copy of the LGPL at http://www.gnu.org/copyleft/. +// +// Software distributed under the License is distributed on an "AS IS" basis, +// WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for the +// specific language governing rights and limitations under the License. +// +// The original code is VirtualTrees.pas, released September 30, 2000. +// +// The initial developer of the original code is digital publishing AG (Munich, Germany, www.digitalpublishing.de), +// written by Mike Lischke (public@soft-gems.net, www.soft-gems.net). +// +// Portions created by digital publishing AG are Copyright +// (C) 1999-2001 digital publishing AG. All Rights Reserved. +//---------------------------------------------------------------------------------------------------------------------- + + +// class to create IAccessibles for the tree passed into it. +// If not already assigned, creates IAccessibles for the tree itself +// and the focused item +// the tree accessible is returned when the tree receives an WM_GETOBJECT message +// the AccessibleItem is returned when the Accessible is being asked for the first child +// To create your own IAccessibles, use the VTStandardAccessible unit as a reference, +// and assign your Accessibles to the variables in the unit's initialization. +// You only need to add the unit to your project, and voilá, you have an accessible string tree! +// +// Written by Marco Zehe. (c) 2007 + +interface + +uses + System.Classes, Winapi.oleacc, VirtualTrees; + +type + IVTAccessibleProvider = interface + function CreateIAccessible(ATree: TBaseVirtualTree): IAccessible; + end; + + TVTAccessibilityFactory = class(TObject) + strict private class var + FAccessibilityAvailable: Boolean; + FVTAccessibleFactory: TVTAccessibilityFactory; + strict private + FAccessibleProviders: TInterfaceList; + private + class procedure FreeFactory; + public + constructor Create; + destructor Destroy; override; + function CreateIAccessible(ATree: TBaseVirtualTree): IAccessible; + class function GetAccessibilityFactory: TVTAccessibilityFactory; static; + procedure RegisterAccessibleProvider(const AProvider: IVTAccessibleProvider); + procedure UnRegisterAccessibleProvider(const AProvider: IVTAccessibleProvider); + end; + + +implementation + +{ TVTAccessibilityFactory } + +constructor TVTAccessibilityFactory.Create; +begin + inherited Create; + FAccessibleProviders := TInterfaceList.Create; + FAccessibleProviders.Clear; +end; + +function TVTAccessibilityFactory.CreateIAccessible( + ATree: TBaseVirtualTree): IAccessible; +var + I: Integer; + TmpIAccessible: IAccessible; +// returns an IAccessible. +// 1. If the Accessible property of the passed-in tree is nil, +// the first registered element will be returned. +// Usually, this is the IAccessible that provides information about the tree itself. +// If it is not nil, we'll check whether the AccessibleItem is nil. +// If it is, we'll look in the registered IAccessibles for the appropriate one. +// Each IAccessibleProvider will check the tree for properties to determine whether it is responsible. +// We'll work top to bottom, from the most complicated to the most simple. +// The index for these should all be greater than 0, e g the IAccessible for the tree itself should always be registered first, then any IAccessible items. +begin + Result := nil; + if ATree <> nil then + begin + if ATree.Accessible = nil then + begin + if FAccessibleProviders.Count > 0 then + begin + Result := IVTAccessibleProvider(FAccessibleProviders.Items[0]).CreateIAccessible(ATree); + Exit; + end; + end; + if ATree.AccessibleItem = nil then + begin + if FAccessibleProviders.Count > 0 then + begin + for I := FAccessibleProviders.Count - 1 downto 1 do + begin + TmpIAccessible := IVTAccessibleProvider(FAccessibleProviders.Items[I]).CreateIAccessible(ATree); + if TmpIAccessible <> nil then + begin + Result := TmpIAccessible; + Break; + end; + end; + if TmpIAccessible = nil then + begin + Result := IVTAccessibleProvider(FAccessibleProviders.Items[0]).CreateIAccessible(ATree); + end; + end; + end + else + Result := ATree.AccessibleItem; + end; +end; + +destructor TVTAccessibilityFactory.Destroy; +begin + FAccessibleProviders.Free; + FAccessibleProviders := nil; + inherited Destroy; +end; + +class procedure TVTAccessibilityFactory.FreeFactory; +begin + FVTAccessibleFactory.Free; +end; + +procedure TVTAccessibilityFactory.RegisterAccessibleProvider(const AProvider: IVTAccessibleProvider); +// Ads a provider if it is not already registered +begin + if FAccessibleProviders.IndexOf(AProvider) < 0 then + FAccessibleProviders.Add(AProvider) +end; + +procedure TVTAccessibilityFactory.UnRegisterAccessibleProvider(const AProvider: IVTAccessibleProvider); +// Unregisters/removes an IAccessible provider if it is present +begin + if FAccessibleProviders.IndexOf(AProvider) >= 0 then + FAccessibleProviders.Remove(AProvider); +end; + +class function TVTAccessibilityFactory.GetAccessibilityFactory: TVTAccessibilityFactory; +// Accessibility helper function to create a singleton class that will create or return +// the IAccessible interface for the tree and the focused node. + +begin + // first, check if we've loaded the library already + if not FAccessibilityAvailable then + FAccessibilityAvailable := True; + if FAccessibilityAvailable then + begin + // Check to see if the class has already been created. + if FVTAccessibleFactory = nil then + FVTAccessibleFactory := TVTAccessibilityFactory.Create; + Result := FVTAccessibleFactory; + end + else + Result := nil; +end; + +initialization + +finalization + TVTAccessibilityFactory.FreeFactory; + +end. + + diff --git a/components/virtualtreeview/Source/VirtualTrees.Actions.pas b/components/virtualtreeview/Source/VirtualTrees.Actions.pas index 3800d77d..8e607810 100644 --- a/components/virtualtreeview/Source/VirtualTrees.Actions.pas +++ b/components/virtualtreeview/Source/VirtualTrees.Actions.pas @@ -7,8 +7,7 @@ uses System.Actions, Vcl.Controls, Vcl.ActnList, - VirtualTrees, - VirtualTrees.Types; + VirtualTrees; type TVirtualTreeAction = class(TCustomAction) diff --git a/components/virtualtreeview/Source/VirtualTrees.ClipBoard.pas b/components/virtualtreeview/Source/VirtualTrees.ClipBoard.pas index b35c9416..e995a877 100644 --- a/components/virtualtreeview/Source/VirtualTrees.ClipBoard.pas +++ b/components/virtualtreeview/Source/VirtualTrees.ClipBoard.pas @@ -32,8 +32,7 @@ uses Winapi.Windows, Winapi.ActiveX, System.Classes, - VirtualTrees, - VirtualTrees.Types; + VirtualTrees; type TClipboardFormatEntry = record @@ -99,16 +98,6 @@ type class function FindFormat(Fmt: Word; var Description: string): TVirtualTreeClass; overload; end; -var - // Clipboard format IDs used in OLE drag'n drop and clipboard transfers. - CF_VIRTUALTREE, - CF_VTREFERENCE, - CF_VRTF, - CF_VRTFNOOBJS, // Unfortunately CF_RTF* is already defined as being - // registration strings so I have to use different identifiers. - CF_HTML, - CF_CSV: Word; - implementation diff --git a/components/virtualtreeview/Source/VirtualTrees.Colors.pas b/components/virtualtreeview/Source/VirtualTrees.Colors.pas deleted file mode 100644 index dcb859fa..00000000 --- a/components/virtualtreeview/Source/VirtualTrees.Colors.pas +++ /dev/null @@ -1,252 +0,0 @@ -unit VirtualTrees.Colors; - -interface - -uses - System.Classes, - Vcl.Graphics, - Vcl.Themes, - Vcl.Controls; - -type - //class to collect all switchable colors into one place - TVTColors = class(TPersistent) - private type - TVTColorEnum = (cDisabledColor, cDropMarkColor, cDropTargetColor, cFocusedSelectionColor, cGridLineColor, cTreeLineColor, cUnfocusedSelectionColor, cBorderColor, cHotColor, - cFocusedSelectionBorderColor, cUnfocusedSelectionBorderColor, cDropTargetBorderColor, cSelectionRectangleBlendColor, cSelectionRectangleBorderColor, cHeaderHotColor, - cSelectionTextColor, cUnfocusedColor); - - //Please make sure that the published Color properties at the corresponding index - //have the same color if you change anything here! - const - cDefaultColors : array [TVTColorEnum] of TColor = (clBtnShadow, //DisabledColor - clHighlight, //DropMarkColor - clHighlight, //DropTargetColor - clHighlight, //FocusedSelectionColor - clBtnFace, //GridLineColor - clBtnShadow, //TreeLineColor - clInactiveCaption, //UnfocusedSelectionColor - clBtnFace, //BorderColor - clWindowText, //HotColor - clHighlight, //FocusedSelectionBorderColor - clInactiveCaption, //UnfocusedSelectionBorderColor - clHighlight, //DropTargetBorderColor - clHighlight, //SelectionRectangleBlendColor - clHighlight, //SelectionRectangleBorderColor - clBtnShadow, //HeaderHotColor - clHighlightText, //SelectionTextColor - clInactiveCaptionText); //UnfocusedColor [IPK] - - private - FOwner : TCustomControl; - FColors : array [TVTColorEnum] of TColor; //[IPK] 15 -> 16 - function GetColor(const Index : TVTColorEnum) : TColor; - procedure SetColor(const Index : TVTColorEnum; const Value : TColor); - function GetBackgroundColor : TColor; - function GetHeaderFontColor : TColor; - function GetNodeFontColor : TColor; - public - constructor Create(AOwner : TCustomControl); - - procedure Assign(Source : TPersistent); override; - function GetSelectedNodeFontColor(Focused : boolean) : TColor; - property BackGroundColor : TColor read GetBackgroundColor; - property HeaderFontColor : TColor read GetHeaderFontColor; - property NodeFontColor : TColor read GetNodeFontColor; - //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(AControl : TControl = nil) : TCustomStyleServices; - published - property BorderColor : TColor index cBorderColor read GetColor write SetColor default clBtnFace; - property DisabledColor : TColor index cDisabledColor read GetColor write SetColor default clBtnShadow; - property DropMarkColor : TColor index cDropMarkColor read GetColor write SetColor default clHighlight; - property DropTargetColor : TColor index cDropTargetColor read GetColor write SetColor default clHighlight; - property DropTargetBorderColor : TColor index cDropTargetBorderColor read GetColor write SetColor default clHighlight; - ///The background color of selected nodes in case the tree has the focus, or the toPopupMode flag is set. - property FocusedSelectionColor : TColor index cFocusedSelectionColor read GetColor write SetColor default clHighlight; - ///The border color of selected nodes when the tree has the focus. - property FocusedSelectionBorderColor : TColor index cFocusedSelectionBorderColor read GetColor write SetColor default clHighlight; - property GridLineColor : TColor index cGridLineColor read GetColor write SetColor default clBtnFace; - property HeaderHotColor : TColor index cHeaderHotColor read GetColor write SetColor default clBtnShadow; - property HotColor : TColor index cHotColor read GetColor write SetColor default clWindowText; - property SelectionRectangleBlendColor : TColor index cSelectionRectangleBlendColor read GetColor write SetColor default clHighlight; - property SelectionRectangleBorderColor : TColor index cSelectionRectangleBorderColor read GetColor write SetColor default clHighlight; - ///The text color of selected nodes - property SelectionTextColor : TColor index cSelectionTextColor read GetColor write SetColor default clHighlightText; - property TreeLineColor : TColor index cTreeLineColor read GetColor write SetColor default clBtnShadow; - property UnfocusedColor : TColor index cUnfocusedColor read GetColor write SetColor default clInactiveCaptionText; //[IPK] Added - ///The background color of selected nodes in case the tree does not have the focus and the toPopupMode flag is not set. - property UnfocusedSelectionColor : TColor index cUnfocusedSelectionColor read GetColor write SetColor default clInactiveCaption; - ///The border color of selected nodes in case the tree does not have the focus and the toPopupMode flag is not set. - property UnfocusedSelectionBorderColor : TColor index cUnfocusedSelectionBorderColor read GetColor write SetColor default clInactiveCaption; - end; - -implementation - -uses - WinApi.Windows, - VirtualTrees, - VirtualTrees.Utils, - VirtualTrees.StyleHooks; - -type - TBaseVirtualTreeCracker = class(TBaseVirtualTree); - - TVTColorsHelper = class helper for TVTColors - function TreeView : TBaseVirtualTreeCracker; - end; - - //----------------- TVTColors ------------------------------------------------------------------------------------------ - -constructor TVTColors.Create(AOwner : TCustomControl); -var - CE : TVTColorEnum; -begin - FOwner := AOwner; - for CE := Low(TVTColorEnum) to High(TVTColorEnum) do - FColors[CE] := cDefaultColors[CE]; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTColors.GetBackgroundColor : TColor; -begin - //XE2 VCL Style - if TreeView.VclStyleEnabled and (seClient in FOwner.StyleElements) then - Result := StyleServices.GetStyleColor(scTreeView) - else - Result := TreeView.Color; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTColors.GetColor(const Index : TVTColorEnum) : TColor; -begin - //Only try to fetch the color via StyleServices if theses are enabled - //Return default/user defined color otherwise - if TreeView.VclStyleEnabled then - begin - //If the ElementDetails are not defined, fall back to the SystemColor - case Index of - cDisabledColor : - if not StyleServices.GetElementColor(StyleServices.GetElementDetails(ttItemDisabled), ecTextColor, Result) then - Result := StyleServices.GetSystemColor(FColors[Index]); - cTreeLineColor : - if not StyleServices.GetElementColor(StyleServices.GetElementDetails(ttBranch), ecBorderColor, Result) then - Result := StyleServices.GetSystemColor(FColors[Index]); - cBorderColor : - if (seBorder in FOwner.StyleElements) then - Result := StyleServices.GetSystemColor(FColors[Index]) - else - Result := FColors[Index]; - cHotColor : - if not StyleServices.GetElementColor(StyleServices.GetElementDetails(ttItemHot), ecTextColor, Result) then - Result := StyleServices.GetSystemColor(FColors[Index]); - cHeaderHotColor : - if not StyleServices.GetElementColor(StyleServices.GetElementDetails(thHeaderItemHot), ecTextColor, Result) then - Result := StyleServices.GetSystemColor(FColors[Index]); - cSelectionTextColor : - if not StyleServices.GetElementColor(StyleServices.GetElementDetails(ttItemSelected), ecTextColor, Result) then - Result := StyleServices.GetSystemColor(clHighlightText); - cUnfocusedColor : - if not StyleServices.GetElementColor(StyleServices.GetElementDetails(ttItemSelectedNotFocus), ecTextColor, Result) then - Result := StyleServices.GetSystemColor(FColors[Index]); - else - Result := StyleServices.GetSystemColor(FColors[Index]); - end; - end - else - Result := FColors[Index]; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTColors.GetHeaderFontColor : TColor; -begin - //XE2+ VCL Style - if TreeView.VclStyleEnabled and (seFont in FOwner.StyleElements) then - StyleServices.GetElementColor(StyleServices.GetElementDetails(thHeaderItemNormal), ecTextColor, Result) - else - Result := TreeView.Header.Font.Color; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTColors.GetNodeFontColor : TColor; -begin - if TreeView.VclStyleEnabled and (seFont in FOwner.StyleElements) then - StyleServices.GetElementColor(StyleServices.GetElementDetails(ttItemNormal), ecTextColor, Result) - else - Result := TreeView.Font.Color; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTColors.GetSelectedNodeFontColor(Focused : boolean) : TColor; -begin - if Focused then - begin - if (tsUseExplorerTheme in TreeView.TreeStates) and not IsHighContrastEnabled then - begin - Result := NodeFontColor - end - else - Result := SelectionTextColor - end//if Focused - else - Result := UnfocusedColor; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTColors.SetColor(const Index : TVTColorEnum; const Value : TColor); -begin - if FColors[Index] <> Value then - begin - FColors[Index] := Value; - if not (csLoading in FOwner.ComponentState) and FOwner.HandleAllocated then - begin - //Cause helper bitmap rebuild if the button color changed. - case Index of - cTreeLineColor : - begin - TreeView.PrepareBitmaps(True, False); - FOwner.Invalidate; - end; - cBorderColor : - RedrawWindow(FOwner.Handle, nil, 0, RDW_FRAME or RDW_INVALIDATE or RDW_NOERASE or RDW_NOCHILDREN) - else - FOwner.Invalidate; - end; - end; - end; -end; - -function TVTColors.StyleServices(AControl : TControl) : TCustomStyleServices; -begin - if AControl = nil then - AControl := FOwner; - Result := VTStyleServices(AControl); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTColors.Assign(Source : TPersistent); -begin - if Source is TVTColors then - begin - FColors := TVTColors(Source).FColors; - if TreeView.UpdateCount = 0 then - TreeView.Invalidate; - end - else - inherited; -end; - -{ TVTColorsHelper } - -function TVTColorsHelper.TreeView : TBaseVirtualTreeCracker; -begin - Result := TBaseVirtualTreeCracker(FOwner); -end; - -end. diff --git a/components/virtualtreeview/Source/VirtualTrees.DataObject.pas b/components/virtualtreeview/Source/VirtualTrees.DataObject.pas deleted file mode 100644 index 368e3763..00000000 --- a/components/virtualtreeview/Source/VirtualTrees.DataObject.pas +++ /dev/null @@ -1,482 +0,0 @@ -unit VirtualTrees.DataObject; - -interface - -uses - WinApi.ActiveX, - WinApi.Windows, - VirtualTrees.Types, - Vcl.Controls; - -type - // IDataObject.SetData support - TInternalStgMedium = packed record - Format : TClipFormat; - Medium : TStgMedium; - end; - - TInternalStgMediumArray = array of TInternalStgMedium; - - // This data object is used in two different places. One is for clipboard operations and the other while dragging. - TVTDataObject = class(TInterfacedObject, IDataObject) - private - FOwner : TCustomControl; // The tree which provides clipboard or drag data. - FForClipboard : Boolean; // Determines which data to render with GetData. - FFormatEtcArray : TFormatEtcArray; - FInternalStgMediumArray : TInternalStgMediumArray; // The available formats in the DataObject - FAdviseHolder : IDataAdviseHolder; // Reference to an OLE supplied implementation for advising. - protected - function CanonicalIUnknown(const TestUnknown : IUnknown) : IUnknown; - function EqualFormatEtc(FormatEtc1, FormatEtc2 : TFormatEtc) : Boolean; - function FindFormatEtc(TestFormatEtc : TFormatEtc; const FormatEtcArray : TFormatEtcArray) : integer; - function FindInternalStgMedium(Format : TClipFormat) : PStgMedium; - function HGlobalClone(HGlobal : THandle) : THandle; - function RenderInternalOLEData(const FormatEtcIn : TFormatEtc; var Medium : TStgMedium; var OLEResult : HResult) : Boolean; - function StgMediumIncRef(const InStgMedium : TStgMedium; var OutStgMedium : TStgMedium; CopyInMedium : Boolean; const DataObject : IDataObject) : HResult; - - property ForClipboard : Boolean read FForClipboard; - property FormatEtcArray : TFormatEtcArray read FFormatEtcArray write FFormatEtcArray; - property InternalStgMediumArray : TInternalStgMediumArray read FInternalStgMediumArray write FInternalStgMediumArray; - property Owner : TCustomControl read FOwner; - public - constructor Create(AOwner : TCustomControl; ForClipboard : Boolean); virtual; - destructor Destroy; override; - - function DAdvise(const FormatEtc : TFormatEtc; advf : integer; const advSink : IAdviseSink; out dwConnection : integer) : HResult; virtual; stdcall; - function DUnadvise(dwConnection : integer) : HResult; virtual; stdcall; - function EnumDAdvise(out enumAdvise : IEnumStatData) : HResult; virtual; stdcall; - function EnumFormatEtc(Direction : integer; out EnumFormatEtc : IEnumFormatEtc) : HResult; virtual; stdcall; - function GetCanonicalFormatEtc(const FormatEtc : TFormatEtc; out FormatEtcOut : TFormatEtc) : HResult; virtual; stdcall; - function GetData(const FormatEtcIn : TFormatEtc; out Medium : TStgMedium) : HResult; virtual; stdcall; - function GetDataHere(const FormatEtc : TFormatEtc; out Medium : TStgMedium) : HResult; virtual; stdcall; - function QueryGetData(const FormatEtc : TFormatEtc) : HResult; virtual; stdcall; - function SetData(const FormatEtc : TFormatEtc; var Medium : TStgMedium; DoRelease : BOOL) : HResult; virtual; stdcall; - end; - -implementation - -uses - VirtualTrees, - VirtualTrees.ClipBoard, - VirtualTrees.DragnDrop; - -type - TVTCracker = class(TBaseVirtualTree); - - //----------------- TVTDataObject -------------------------------------------------------------------------------------- - -constructor TVTDataObject.Create(AOwner : TCustomControl; ForClipboard : Boolean); -begin - inherited Create; - - FOwner := AOwner; - FForClipboard := ForClipboard; - TVTCracker(FOwner).GetNativeClipboardFormats(FFormatEtcArray); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -destructor TVTDataObject.Destroy; -var - I : integer; - StgMedium : PStgMedium; -begin - // Cancel a pending clipboard operation if this data object was created for the clipboard and - // is freed because something else is placed there. - if FForClipboard and not (tsClipboardFlushing in TBaseVirtualTree(FOwner).TreeStates) then - TBaseVirtualTree(FOwner).CancelCutOrCopy; - - // Release any internal clipboard formats - for I := 0 to High(FormatEtcArray) do - begin - StgMedium := FindInternalStgMedium(FormatEtcArray[I].cfFormat); - if Assigned(StgMedium) then - ReleaseStgMedium(StgMedium^); - end; - - FormatEtcArray := nil; - inherited; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTDataObject.CanonicalIUnknown(const TestUnknown : IUnknown) : IUnknown; -// Uses COM object identity: An explicit call to the IUnknown::QueryInterface method, requesting the IUnknown -// interface, will always return the same pointer. -begin - if Assigned(TestUnknown) then - begin - if TestUnknown.QueryInterface(IUnknown, Result) = 0 then - Result._Release // Don't actually need it just need the pointer value - else - Result := TestUnknown; - end - else - Result := TestUnknown; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTDataObject.EqualFormatEtc(FormatEtc1, FormatEtc2 : TFormatEtc) : Boolean; -begin - Result := (FormatEtc1.cfFormat = FormatEtc2.cfFormat) and (FormatEtc1.ptd = FormatEtc2.ptd) and (FormatEtc1.dwAspect = FormatEtc2.dwAspect) and - (FormatEtc1.lindex = FormatEtc2.lindex) and (FormatEtc1.tymed and FormatEtc2.tymed <> 0); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTDataObject.FindFormatEtc(TestFormatEtc : TFormatEtc; const FormatEtcArray : TFormatEtcArray) : integer; -var - I : integer; -begin - Result := - 1; - for I := 0 to High(FormatEtcArray) do - begin - if EqualFormatEtc(TestFormatEtc, FormatEtcArray[I]) then - begin - Result := I; - Break; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTDataObject.FindInternalStgMedium(Format : TClipFormat) : PStgMedium; -var - I : integer; -begin - Result := nil; - for I := 0 to High(InternalStgMediumArray) do - begin - if Format = InternalStgMediumArray[I].Format then - begin - Result := @InternalStgMediumArray[I].Medium; - Break; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTDataObject.HGlobalClone(HGlobal : THandle) : THandle; -// Returns a global memory block that is a copy of the passed memory block. -var - Size : Cardinal; - Data, NewData : PByte; -begin - Size := GlobalSize(HGlobal); - Result := GlobalAlloc(GPTR, Size); - Data := GlobalLock(HGlobal); - try - NewData := GlobalLock(Result); - try - Move(Data^, NewData^, Size); - finally - GlobalUnLock(Result); - end; - finally - GlobalUnLock(HGlobal); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTDataObject.RenderInternalOLEData(const FormatEtcIn : TFormatEtc; var Medium : TStgMedium; var OLEResult : HResult) : Boolean; -// Tries to render one of the formats which have been stored via the SetData method. -// Since this data is already there it is just copied or its reference count is increased (depending on storage medium). -var - InternalMedium : PStgMedium; -begin - Result := True; - InternalMedium := FindInternalStgMedium(FormatEtcIn.cfFormat); - if Assigned(InternalMedium) then - OLEResult := StgMediumIncRef(InternalMedium^, Medium, False, Self as IDataObject) - else - Result := False; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTDataObject.StgMediumIncRef(const InStgMedium : TStgMedium; var OutStgMedium : TStgMedium; CopyInMedium : Boolean; const DataObject : IDataObject) : HResult; -// InStgMedium is the data that is requested, OutStgMedium is the data that we are to return either a copy of or -// increase the IDataObject's reference and send ourselves back as the data (unkForRelease). The InStgMedium is usually -// the result of a call to find a particular FormatEtc that has been stored locally through a call to SetData. -// If CopyInMedium is not true we already have a local copy of the data when the SetData function was called (during -// that call the CopyInMedium must be true). Then as the caller asks for the data through GetData we do not have to make -// copy of the data for the caller only to have them destroy it then need us to copy it again if necessary. -// This way we increase the reference count to ourselves and pass the STGMEDIUM structure initially stored in SetData. -// This way when the caller frees the structure it sees the unkForRelease is not nil and calls Release on the object -// instead of destroying the actual data. -var - Len : integer; -begin - Result := S_OK; - - // Simply copy all fields to start with. - OutStgMedium := InStgMedium; - // The data handled here always results from a call of SetData we got. This ensures only one storage format - // is indicated and hence the case statement below is safe (IDataObject.GetData can optionally use several - // storage formats). - case InStgMedium.tymed of - TYMED_HGLOBAL : - begin - if CopyInMedium then - begin - // Generate a unique copy of the data passed - OutStgMedium.HGlobal := HGlobalClone(InStgMedium.HGlobal); - if OutStgMedium.HGlobal = 0 then - Result := E_OUTOFMEMORY; - end - else - // Don't generate a copy just use ourselves and the copy previously saved. - OutStgMedium.unkForRelease := Pointer(DataObject); // Does not increase RefCount. - end; - TYMED_FILE : - begin - Len := lstrLenW(InStgMedium.lpszFileName) + 1; // Don't forget the terminating null character. - OutStgMedium.lpszFileName := CoTaskMemAlloc(2 * Len); - Move(InStgMedium.lpszFileName^, OutStgMedium.lpszFileName^, 2 * Len); - end; - TYMED_ISTREAM : - IUnknown(OutStgMedium.stm)._AddRef; - TYMED_ISTORAGE : - IUnknown(OutStgMedium.stg)._AddRef; - TYMED_GDI : - if not CopyInMedium then - // Don't generate a copy just use ourselves and the previously saved data. - OutStgMedium.unkForRelease := Pointer(DataObject) // Does not increase RefCount. - else - Result := DV_E_TYMED; // Don't know how to copy GDI objects right now. - TYMED_MFPICT : - if not CopyInMedium then - // Don't generate a copy just use ourselves and the previously saved data. - OutStgMedium.unkForRelease := Pointer(DataObject) // Does not increase RefCount. - else - Result := DV_E_TYMED; // Don't know how to copy MetaFile objects right now. - TYMED_ENHMF : - if not CopyInMedium then - // Don't generate a copy just use ourselves and the previously saved data. - OutStgMedium.unkForRelease := Pointer(DataObject) // Does not increase RefCount. - else - Result := DV_E_TYMED; // Don't know how to copy enhanced metafiles objects right now. - else - Result := DV_E_TYMED; - end; - - if (Result = S_OK) and Assigned(OutStgMedium.unkForRelease) then - IUnknown(OutStgMedium.unkForRelease)._AddRef; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTDataObject.DAdvise(const FormatEtc : TFormatEtc; advf : integer; const advSink : IAdviseSink; out dwConnection : integer) : HResult; -// Advise sink management is greatly simplified by the IDataAdviseHolder interface. -// We use this interface and forward all concerning calls to it. -begin - Result := S_OK; - if FAdviseHolder = nil then - Result := CreateDataAdviseHolder(FAdviseHolder); - if Result = S_OK then - Result := FAdviseHolder.Advise(Self as IDataObject, FormatEtc, advf, advSink, dwConnection); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTDataObject.DUnadvise(dwConnection : integer) : HResult; -begin - if FAdviseHolder = nil then - Result := E_NOTIMPL - else - Result := FAdviseHolder.Unadvise(dwConnection); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTDataObject.EnumDAdvise(out enumAdvise : IEnumStatData) : HResult; -begin - if FAdviseHolder = nil then - Result := OLE_E_ADVISENOTSUPPORTED - else - Result := FAdviseHolder.enumAdvise(enumAdvise); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTDataObject.EnumFormatEtc(Direction : integer; out EnumFormatEtc : IEnumFormatEtc) : HResult; -var - NewList : TEnumFormatEtc; -begin - Result := E_FAIL; - if Direction = DATADIR_GET then - begin - NewList := TEnumFormatEtc.Create(FormatEtcArray); - EnumFormatEtc := NewList as IEnumFormatEtc; - Result := S_OK; - end - else - EnumFormatEtc := nil; - if EnumFormatEtc = nil then - Result := OLE_S_USEREG; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTDataObject.GetCanonicalFormatEtc(const FormatEtc : TFormatEtc; out FormatEtcOut : TFormatEtc) : HResult; -begin - Result := DATA_S_SAMEFORMATETC; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTDataObject.GetData(const FormatEtcIn : TFormatEtc; out Medium : TStgMedium) : HResult; -// Data is requested by clipboard or drop target. This method dispatchs the call -// depending on the data being requested. -var - I : integer; - Data : PVTReference; -begin - // The tree reference format is always supported and returned from here. - if FormatEtcIn.cfFormat = CF_VTREFERENCE then - begin - // Note: this format is not used while flushing the clipboard to avoid a dangling reference - // when the owner tree is destroyed before the clipboard data is replaced with something else. - if tsClipboardFlushing in TBaseVirtualTree(FOwner).TreeStates then - Result := E_FAIL - else - begin - Medium.HGlobal := GlobalAlloc(GHND or GMEM_SHARE, SizeOf(TVTReference)); - Data := GlobalLock(Medium.HGlobal); - Data.Process := GetCurrentProcessID; - Data.Tree := TBaseVirtualTree(FOwner); - GlobalUnLock(Medium.HGlobal); - Medium.tymed := TYMED_HGLOBAL; - Medium.unkForRelease := nil; - Result := S_OK; - end; - end - else - begin - try - // See if we accept this type and if not get the correct return value. - Result := QueryGetData(FormatEtcIn); - if Result = S_OK then - begin - for I := 0 to High(FormatEtcArray) do - begin - if EqualFormatEtc(FormatEtcIn, FormatEtcArray[I]) then - begin - if not RenderInternalOLEData(FormatEtcIn, Medium, Result) then - Result := TVTCracker(FOwner).RenderOLEData(FormatEtcIn, Medium, FForClipboard); - Break; - end; - end; - end; - except - ZeroMemory(@Medium, SizeOf(Medium)); - Result := E_FAIL; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTDataObject.GetDataHere(const FormatEtc : TFormatEtc; out Medium : TStgMedium) : HResult; -begin - Result := E_NOTIMPL; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTDataObject.QueryGetData(const FormatEtc : TFormatEtc) : HResult; -var - I : integer; -begin - Result := DV_E_CLIPFORMAT; - for I := 0 to High(FFormatEtcArray) do - begin - if FormatEtc.cfFormat = FFormatEtcArray[I].cfFormat then - begin - if (FormatEtc.tymed and FFormatEtcArray[I].tymed) <> 0 then - begin - if FormatEtc.dwAspect = FFormatEtcArray[I].dwAspect then - begin - if FormatEtc.lindex = FFormatEtcArray[I].lindex then - begin - Result := S_OK; - Break; - end - else - Result := DV_E_LINDEX; - end - else - Result := DV_E_DVASPECT; - end - else - Result := DV_E_TYMED; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTDataObject.SetData(const FormatEtc : TFormatEtc; var Medium : TStgMedium; DoRelease : BOOL) : HResult; -// Allows dynamic adding to the IDataObject during its existance. Most noteably it is used to implement -// IDropSourceHelper and allows to set a special format for optimized moves during a shell transfer. -var - Index : integer; - LocalStgMedium : PStgMedium; -begin - // See if we already have a format of that type available. - Index := FindFormatEtc(FormatEtc, FormatEtcArray); - if Index > - 1 then - begin - // Just use the TFormatEct in the array after releasing the data. - LocalStgMedium := FindInternalStgMedium(FormatEtcArray[Index].cfFormat); - if Assigned(LocalStgMedium) then - begin - ReleaseStgMedium(LocalStgMedium^); - ZeroMemory(LocalStgMedium, SizeOf(LocalStgMedium^)); - end; - end - else - begin - // It is a new format so create a new TFormatCollectionItem, copy the - // FormatEtc parameter into the new object and and put it in the list. - SetLength(FFormatEtcArray, Length(FormatEtcArray) + 1); - FormatEtcArray[High(FormatEtcArray)] := FormatEtc; - - // Create a new InternalStgMedium and initialize it and associate it with the format. - SetLength(FInternalStgMediumArray, Length(InternalStgMediumArray) + 1); - InternalStgMediumArray[High(InternalStgMediumArray)].Format := FormatEtc.cfFormat; - LocalStgMedium := @InternalStgMediumArray[High(InternalStgMediumArray)].Medium; - ZeroMemory(LocalStgMedium, SizeOf(LocalStgMedium^)); - end; - - if DoRelease then - begin - // We are simply being given the data and we take control of it. - LocalStgMedium^ := Medium; - Result := S_OK; - end - else - begin - // We need to reference count or copy the data and keep our own references to it. - Result := StgMediumIncRef(Medium, LocalStgMedium^, True, Self as IDataObject); - - // Can get a circular reference if the client calls GetData then calls SetData with the same StgMedium. - // Because the unkForRelease for the IDataObject can be marshalled it is necessary to get pointers that - // can be correctly compared. See the IDragSourceHelper article by Raymond Chen at MSDN. - if Assigned(LocalStgMedium.unkForRelease) then - begin - if CanonicalIUnknown(Self) = CanonicalIUnknown(IUnknown(LocalStgMedium.unkForRelease)) then - IUnknown(LocalStgMedium.unkForRelease) := nil; // release the interface - end; - end; - - // Tell all registered advice sinks about the data change. - if Assigned(FAdviseHolder) then - FAdviseHolder.SendOnDataChange(Self as IDataObject, 0, 0); -end; - -end. diff --git a/components/virtualtreeview/Source/VirtualTrees.DragImage.pas b/components/virtualtreeview/Source/VirtualTrees.DragImage.pas deleted file mode 100644 index 1b6b3a4d..00000000 --- a/components/virtualtreeview/Source/VirtualTrees.DragImage.pas +++ /dev/null @@ -1,564 +0,0 @@ -unit VirtualTrees.DragImage; - -interface - -uses - WinApi.Windows, - WinApi.ActiveX, - System.Types, - Vcl.Controls, - Vcl.Graphics; - -{$MINENUMSIZE 1, make enumerations as small as possible} - - -type - // Drag image support for the tree. - TVTTransparency = 0 .. 255; - TVTBias = - 128 .. 127; - - // Simple move limitation for the drag image. - TVTDragMoveRestriction = (dmrNone, dmrHorizontalOnly, dmrVerticalOnly); - - TVTDragImageStates = set of (disHidden, // Internal drag image is currently hidden (always hidden if drag image helper interfaces are used). - disInDrag, // Drag image class is currently being used. - disPrepared, // Drag image class is prepared. - disSystemSupport // Running on Windows 2000 or higher. System supports drag images natively. - ); - - // Class to manage header and tree drag image during a drag'n drop operation. - TVTDragImage = class - private - FOwner : TCustomControl; - FBackImage, // backup of overwritten screen area - FAlphaImage, // target for alpha blending - FDragImage : TBitmap; // the actual drag image to blend to screen - FImagePosition, // position of image (upper left corner) in screen coordinates - FLastPosition : TPoint; // last mouse position in screen coordinates - FTransparency : TVTTransparency; // alpha value of the drag image (0 - fully transparent, 255 - fully opaque) - FPreBlendBias, // value to darken or lighten the drag image before it is blended - FPostBlendBias : TVTBias; // value to darken or lighten the alpha blend result - FFade : Boolean; // determines whether to fade the drag image from center to borders or not - FRestriction : TVTDragMoveRestriction; // determines in which directions the drag image can be moved - FColorKey : TColor; // color to make fully transparent regardless of any other setting - FStates : TVTDragImageStates; // Determines the states of the drag image class. - function GetVisible : Boolean; // True if the drag image is currently hidden (used only when dragging) - procedure InternalShowDragImage(ScreenDC : HDC); - procedure MakeAlphaChannel(Source, Target : TBitmap); - public - constructor Create(AOwner : TCustomControl); - destructor Destroy; override; - - function DragTo(P : TPoint; ForceRepaint : Boolean) : Boolean; - procedure EndDrag; - function GetDragImageRect : TRect; - procedure HideDragImage; - procedure PrepareDrag(DragImage : TBitmap; ImagePosition, HotSpot : TPoint; const DataObject : IDataObject); - procedure RecaptureBackground(Tree : TCustomControl; R : TRect; VisibleRegion : HRGN; CaptureNCArea, ReshowDragImage : Boolean); - procedure ShowDragImage; - function WillMove(P : TPoint) : Boolean; - property ColorKey : TColor read FColorKey write FColorKey default clWindow; - property Fade : Boolean read FFade write FFade default False; - property ImagePosition : TPoint read FImagePosition; - property LastPosition : TPoint read FLastPosition; - property MoveRestriction : TVTDragMoveRestriction read FRestriction write FRestriction default dmrNone; - property PreBlendBias : TVTBias read FPreBlendBias write FPreBlendBias default 0; - property Transparency : TVTTransparency read FTransparency write FTransparency default 128; - property Visible : Boolean read GetVisible; - end; - -implementation - -uses - WinApi.ShlObj, - WinApi.Messages, - System.SysUtils, - System.Math, - VirtualTrees, - VirtualTrees.DragnDrop, - VirtualTrees.Types, - VirtualTrees.Utils; - -//----------------- TVTDragImage --------------------------------------------------------------------------------------- - -constructor TVTDragImage.Create(AOwner : TCustomControl); -begin - FOwner := AOwner; - FTransparency := 128; - FPreBlendBias := 0; - FPostBlendBias := 0; - FFade := False; - FRestriction := dmrNone; - FColorKey := clNone; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -destructor TVTDragImage.Destroy; -begin - EndDrag; - - inherited; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTDragImage.GetVisible : Boolean; -// Returns True if the internal drag image is used (i.e. the system does not natively support drag images) and -// the internal image is currently visible on screen. -begin - Result := FStates * [disHidden, disInDrag, disPrepared, disSystemSupport] = [disInDrag, disPrepared]; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTDragImage.InternalShowDragImage(ScreenDC : HDC); -// Frequently called helper routine to actually do the blend and put it onto the screen. -// Only used if the system does not support drag images. -var - BlendMode : TBlendMode; -begin - with FAlphaImage do - BitBlt(Canvas.Handle, 0, 0, Width, Height, FBackImage.Canvas.Handle, 0, 0, SRCCOPY); - if not FFade and (FColorKey = clNone) then - BlendMode := bmConstantAlpha - else - BlendMode := bmMasterAlpha; - with FDragImage do - AlphaBlend(Canvas.Handle, FAlphaImage.Canvas.Handle, Rect(0, 0, Width, Height), Point(0, 0), BlendMode, FTransparency, FPostBlendBias); - - with FAlphaImage do - BitBlt(ScreenDC, FImagePosition.X, FImagePosition.Y, Width, Height, Canvas.Handle, 0, 0, SRCCOPY); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTDragImage.MakeAlphaChannel(Source, Target : TBitmap); -// Helper method to create a proper alpha channel in Target (which must be in 32 bit pixel format), depending -// on the settings for the drag image and the color values in Source. -// Only used if the system does not support drag images. -type - PBGRA = ^TBGRA; - - TBGRA = packed record - case Boolean of - False : - (Color : Cardinal); - True : - (BGR : array [0 .. 2] of Byte; - Alpha : Byte); - end; - -var - Color, ColorKeyRef : COLORREF; - UseColorKey : Boolean; - SourceRun, TargetRun : PBGRA; - X, Y, MaxDimension, HalfWidth, HalfHeight : Integer; - T : Extended; -begin - UseColorKey := ColorKey <> clNone; - ColorKeyRef := ColorToRGB(ColorKey) and $FFFFFF; - // Color values are in the form BGR (red on LSB) while bitmap colors are in the form ARGB (blue on LSB) - // hence we have to swap red and blue in the color key. - with TBGRA(ColorKeyRef) do - begin - X := BGR[0]; - BGR[0] := BGR[2]; - BGR[2] := X; - end; - - with Target do - begin - MaxDimension := Max(Width, Height); - - HalfWidth := Width div 2; - HalfHeight := Height div 2; - for Y := 0 to Height - 1 do - begin - TargetRun := Scanline[Y]; - SourceRun := Source.Scanline[Y]; - for X := 0 to Width - 1 do - begin - Color := SourceRun.Color and $FFFFFF; - if UseColorKey and (Color = ColorKeyRef) then - TargetRun.Alpha := 0 - else - begin - // If the color is not the given color key (or none is used) then do full calculation of a bell curve. - T := Exp( - 8 * Sqrt(Sqr((X - HalfWidth) / MaxDimension) + Sqr((Y - HalfHeight) / MaxDimension))); - TargetRun.Alpha := Round(255 * T); - end; - Inc(SourceRun); - Inc(TargetRun); - end; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTDragImage.DragTo(P : TPoint; ForceRepaint : Boolean) : Boolean; -// Moves the drag image to a new position, which is determined from the passed point P and the previous -// mouse position. -// ForceRepaint is True if something on the screen changed and the back image must be refreshed. - -var - ScreenDC : HDC; - DeltaX, DeltaY : Integer; - - // optimized drag image move support - RSamp1, RSamp2, // newly added parts from screen which will be overwritten - RDraw1, RDraw2, // parts to be restored to screen - RScroll, RClip : TRect; // ScrollDC of the existent background -begin - // Determine distances to move the drag image. Take care for restrictions. - case FRestriction of - dmrHorizontalOnly : - begin - DeltaX := FLastPosition.X - P.X; - DeltaY := 0; - end; - dmrVerticalOnly : - begin - DeltaX := 0; - DeltaY := FLastPosition.Y - P.Y; - end; - else // dmrNone - DeltaX := FLastPosition.X - P.X; - DeltaY := FLastPosition.Y - P.Y; - end; - - Result := (DeltaX <> 0) or (DeltaY <> 0) or ForceRepaint; - if Result then - begin - if Visible then - begin - // All this stuff is only called if we have to handle the drag image ourselves. If the system supports - // drag image then this is all never executed. - ScreenDC := GetDC(0); - try - if (Abs(DeltaX) >= FDragImage.Width) or (Abs(DeltaY) >= FDragImage.Height) or ForceRepaint then - begin - // If moved more than image size then just restore old screen and blit image to new position. - BitBlt(ScreenDC, FImagePosition.X, FImagePosition.Y, FBackImage.Width, FBackImage.Height, FBackImage.Canvas.Handle, 0, 0, SRCCOPY); - - if ForceRepaint then - UpdateWindow(FOwner.Handle); - - Inc(FImagePosition.X, - DeltaX); - Inc(FImagePosition.Y, - DeltaY); - - BitBlt(FBackImage.Canvas.Handle, 0, 0, FBackImage.Width, FBackImage.Height, ScreenDC, FImagePosition.X, FImagePosition.Y, SRCCOPY); - end - else - begin - // overlapping copy - FillDragRectangles(FDragImage.Width, FDragImage.Height, DeltaX, DeltaY, RClip, RScroll, RSamp1, RSamp2, RDraw1, RDraw2); - - with FBackImage.Canvas do - begin - // restore uncovered areas of the screen - if DeltaX = 0 then - begin - BitBlt(ScreenDC, FImagePosition.X + RDraw2.Left, FImagePosition.Y + RDraw2.Top, RDraw2.Right, RDraw2.Bottom, Handle, RDraw2.Left, RDraw2.Top, SRCCOPY); - end - else - begin - if DeltaY = 0 then - begin - BitBlt(ScreenDC, FImagePosition.X + RDraw1.Left, FImagePosition.Y + RDraw1.Top, RDraw1.Right, RDraw1.Bottom, Handle, RDraw1.Left, RDraw1.Top, SRCCOPY); - end - else - begin - BitBlt(ScreenDC, FImagePosition.X + RDraw1.Left, FImagePosition.Y + RDraw1.Top, RDraw1.Right, RDraw1.Bottom, Handle, RDraw1.Left, RDraw1.Top, SRCCOPY); - BitBlt(ScreenDC, FImagePosition.X + RDraw1.Left, FImagePosition.Y + RDraw1.Top, RDraw1.Right, RDraw1.Bottom, Handle, RDraw1.Left, RDraw1.Top, SRCCOPY); - end; - end; - - // move existent background - ScrollDC(Handle, DeltaX, DeltaY, RScroll, RClip, 0, nil); - - Inc(FImagePosition.X, - DeltaX); - Inc(FImagePosition.Y, - DeltaY); - - // Get first and second additional rectangle from screen. - if DeltaX = 0 then - begin - BitBlt(Handle, RSamp2.Left, RSamp2.Top, RSamp2.Right, RSamp2.Bottom, ScreenDC, FImagePosition.X + RSamp2.Left, FImagePosition.Y + RSamp2.Top, SRCCOPY); - end - else if DeltaY = 0 then - begin - BitBlt(Handle, RSamp1.Left, RSamp1.Top, RSamp1.Right, RSamp1.Bottom, ScreenDC, FImagePosition.X + RSamp1.Left, FImagePosition.Y + RSamp1.Top, SRCCOPY); - end - else - begin - BitBlt(Handle, RSamp1.Left, RSamp1.Top, RSamp1.Right, RSamp1.Bottom, ScreenDC, FImagePosition.X + RSamp1.Left, FImagePosition.Y + RSamp1.Top, SRCCOPY); - BitBlt(Handle, RSamp2.Left, RSamp2.Top, RSamp2.Right, RSamp2.Bottom, ScreenDC, FImagePosition.X + RSamp2.Left, FImagePosition.Y + RSamp2.Top, SRCCOPY); - end; - end; - end; - InternalShowDragImage(ScreenDC); - finally - ReleaseDC(0, ScreenDC); - end; - end; - FLastPosition.X := P.X; - FLastPosition.Y := P.Y; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTDragImage.EndDrag; -begin - HideDragImage; - FStates := FStates - [disInDrag, disPrepared]; - - FBackImage.Free; - FBackImage := nil; - FDragImage.Free; - FDragImage := nil; - FAlphaImage.Free; - FAlphaImage := nil; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTDragImage.GetDragImageRect : TRect; -// Returns the current size and position of the drag image (screen coordinates). -begin - if Visible then - begin - with FBackImage do - Result := Rect(FImagePosition.X, FImagePosition.Y, FImagePosition.X + Width, FImagePosition.Y + Height); - end - else - Result := Rect(0, 0, 0, 0); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTDragImage.HideDragImage; -var - ScreenDC : HDC; -begin - if Visible then - begin - Include(FStates, disHidden); - ScreenDC := GetDC(0); - try - // restore screen - with FBackImage do - BitBlt(ScreenDC, FImagePosition.X, FImagePosition.Y, Width, Height, Canvas.Handle, 0, 0, SRCCOPY); - finally - ReleaseDC(0, ScreenDC); - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTDragImage.PrepareDrag(DragImage : TBitmap; ImagePosition, HotSpot : TPoint; const DataObject : IDataObject); -// Creates all necessary structures to do alpha blended dragging using the given image. -// ImagePostion and HotSpot are given in screen coordinates. The first determines where to place the drag image while -// the second is the initial mouse position. -// This method also determines whether the system supports drag images natively. If so then only minimal structures -// are created. - -var - Width, Height : Integer; - DragSourceHelper : IDragSourceHelper; - DragInfo : TSHDragImage; - lDragSourceHelper2 : IDragSourceHelper2; // Needed to get Windows Vista+ style drag hints. - lNullPoint : TPoint; -begin - Width := DragImage.Width; - Height := DragImage.Height; - - // Determine whether the system supports the drag helper interfaces. - if Assigned(DataObject) and Succeeded(CoCreateInstance(CLSID_DragDropHelper, nil, CLSCTX_INPROC_SERVER, IDragSourceHelper, DragSourceHelper)) then - begin - Include(FStates, disSystemSupport); - lNullPoint := Point(0, 0); - if Supports(DragSourceHelper, IDragSourceHelper2, lDragSourceHelper2) then - lDragSourceHelper2.SetFlags(DSH_ALLOWDROPDESCRIPTIONTEXT); // Show description texts - // First let the system try to initialze the DragSourceHelper, this works fine for file system objects (CF_HDROP) - StandardOLEFormat.cfFormat := CF_HDROP; - if not Succeeded(DataObject.QueryGetData(StandardOLEFormat)) or not Succeeded(DragSourceHelper.InitializeFromWindow(0, lNullPoint, DataObject)) then - begin - // Supply the drag source helper with our drag image. - DragInfo.sizeDragImage.cx := Width; - DragInfo.sizeDragImage.cy := Height; - DragInfo.ptOffset.X := Width div 2; - DragInfo.ptOffset.Y := Height div 2; - DragInfo.hbmpDragImage := CopyImage(DragImage.Handle, IMAGE_BITMAP, Width, Height, LR_COPYRETURNORG); - DragInfo.crColorKey := ColorToRGB(FColorKey); - if not Succeeded(DragSourceHelper.InitializeFromBitmap(@DragInfo, DataObject)) then - begin - DeleteObject(DragInfo.hbmpDragImage); - Exclude(FStates, disSystemSupport); - end; - end; - end - else - Exclude(FStates, disSystemSupport); - - if not (disSystemSupport in FStates) then - begin - FLastPosition := HotSpot; - - FDragImage := TBitmap.Create; - FDragImage.PixelFormat := pf32Bit; - FDragImage.SetSize(Width, Height); - - FAlphaImage := TBitmap.Create; - FAlphaImage.PixelFormat := pf32Bit; - FAlphaImage.SetSize(Width, Height); - - FBackImage := TBitmap.Create; - FBackImage.PixelFormat := pf32Bit; - FBackImage.SetSize(Width, Height); - - // Copy the given drag image and apply pre blend bias if required. - if FPreBlendBias = 0 then - with FDragImage do - BitBlt(Canvas.Handle, 0, 0, Width, Height, DragImage.Canvas.Handle, 0, 0, SRCCOPY) - else - AlphaBlend(DragImage.Canvas.Handle, FDragImage.Canvas.Handle, Rect(0, 0, Width, Height), Point(0, 0), bmConstantAlpha, 255, FPreBlendBias); - - // Create a proper alpha channel also if no fading is required (transparent parts). - MakeAlphaChannel(DragImage, FDragImage); - - FImagePosition := ImagePosition; - - // Initially the drag image is hidden and will be shown during the immediately following DragEnter event. - FStates := FStates + [disInDrag, disHidden, disPrepared]; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTDragImage.RecaptureBackground(Tree : TCustomControl; R : TRect; VisibleRegion : HRGN; CaptureNCArea, ReshowDragImage : Boolean); -// Notification by the drop target tree to update the background image because something in the tree has changed. -// Note: The passed rectangle is given in client coordinates of the current drop target tree (given in Tree). -// The caller does not check if the given rectangle is actually within the drag image. Hence this method must do -// all the checks. -// This method does nothing if the system manages the drag image. - -var - DragRect, ClipRect : TRect; - PaintTarget : TPoint; - PaintOptions : TVTInternalPaintOptions; - ScreenDC : HDC; - -begin - // Recapturing means we want the tree to paint the new part into our back bitmap instead to the screen. - if Visible then - begin - // Create the minimum rectangle to be recaptured. - MapWindowPoints(Tree.Handle, 0, R, 2); - DragRect := GetDragImageRect; - IntersectRect(R, R, DragRect); - - OffsetRgn(VisibleRegion, - DragRect.Left, - DragRect.Top); - - // The target position for painting in the drag image is relative and can be determined from screen coordinates too. - PaintTarget.X := R.Left - DragRect.Left; - PaintTarget.Y := R.Top - DragRect.Top; - - // The source rectangle is determined by the offsets in the tree. - MapWindowPoints(0, Tree.Handle, R, 2); - OffsetRect(R, - TBaseVirtualTree(Tree).OffsetX, - TBaseVirtualTree(Tree).OffsetY); - - // Finally let the tree paint the relevant part and upate the drag image on screen. - PaintOptions := [poBackground, poColumnColor, poDrawFocusRect, poDrawDropMark, poDrawSelection, poGridLines]; - with FBackImage do - begin - ClipRect.TopLeft := PaintTarget; - ClipRect.Right := ClipRect.Left + R.Right - R.Left; - ClipRect.Bottom := ClipRect.Top + R.Bottom - R.Top; - // TODO: somehow with clipping, the background image is not drawn on the - // backup image. Need to be diagnosed and fixed. For now, we have coded - // a work around in DragTo where this is used by using the condition - // IsInHeader. (found when solving issue 248) - ClipCanvas(Canvas, ClipRect, VisibleRegion); - TBaseVirtualTree(Tree).PaintTree(Canvas, R, PaintTarget, PaintOptions); - - if CaptureNCArea then - begin - // Header is painted in this part only so when you use this routine and want - // to capture the header in backup image, this flag should be ON. - // For the non-client area we only need the visible region of the window as limit for painting. - SelectClipRgn(Canvas.Handle, VisibleRegion); - // Since WM_PRINT cannot be given a position where to draw we simply move the window origin and - // get the same effect. - GetWindowRect(Tree.Handle, ClipRect); - SetCanvasOrigin(Canvas, DragRect.Left - ClipRect.Left, DragRect.Top - ClipRect.Top); - Tree.Perform(WM_PRINT, WPARAM(Canvas.Handle), PRF_NONCLIENT); - SetCanvasOrigin(Canvas, 0, 0); - end; - SelectClipRgn(Canvas.Handle, 0); - - if ReshowDragImage then - begin - GDIFlush; - ScreenDC := GetDC(0); - try - InternalShowDragImage(ScreenDC); - finally - ReleaseDC(0, ScreenDC); - end; - end; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTDragImage.ShowDragImage; -// Shows the drag image after it has been hidden by HideDragImage. -// Note: there might be a new background now. -// Also this method does nothing if the system manages the drag image. - -var - ScreenDC : HDC; -begin - if FStates * [disInDrag, disHidden, disPrepared, disSystemSupport] = [disInDrag, disHidden, disPrepared] then - begin - Exclude(FStates, disHidden); - - GDIFlush; - ScreenDC := GetDC(0); - try - BitBlt(FBackImage.Canvas.Handle, 0, 0, FBackImage.Width, FBackImage.Height, ScreenDC, FImagePosition.X, FImagePosition.Y, SRCCOPY); - - InternalShowDragImage(ScreenDC); - finally - ReleaseDC(0, ScreenDC); - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTDragImage.WillMove(P : TPoint) : Boolean; -// This method determines whether the drag image would "physically" move when DragTo would be called with the same -// target point. -// Always returns False if the system drag image support is available. -begin - Result := Visible; - if Result then - begin - // Determine distances to move the drag image. Take care for restrictions. - case FRestriction of - dmrHorizontalOnly : - Result := FLastPosition.X <> P.X; - dmrVerticalOnly : - Result := FLastPosition.Y <> P.Y; - else // dmrNone - Result := (FLastPosition.X <> P.X) or (FLastPosition.Y <> P.Y); - end; - end; -end; - -end. diff --git a/components/virtualtreeview/Source/VirtualTrees.DragnDrop.pas b/components/virtualtreeview/Source/VirtualTrees.DragnDrop.pas deleted file mode 100644 index 4b56a456..00000000 --- a/components/virtualtreeview/Source/VirtualTrees.DragnDrop.pas +++ /dev/null @@ -1,342 +0,0 @@ -unit VirtualTrees.DragnDrop; - -interface - -uses - WinApi.Windows, - WinApi.ActiveX, - WinApi.ShlObj, - System.Types, - Vcl.Graphics, - Vcl.Controls, - VirtualTrees.Types, - VirtualTrees; - -type - TEnumFormatEtc = class(TInterfacedObject, IEnumFormatEtc) - private - FFormatEtcArray : TFormatEtcArray; - FCurrentIndex : Integer; - public - constructor Create(const AFormatEtcArray : TFormatEtcArray); - - function Clone(out Enum : IEnumFormatEtc) : HResult; stdcall; - function Next(celt : Integer; out elt; pceltFetched : PLongint) : HResult; stdcall; - function Reset : HResult; stdcall; - function Skip(celt : Integer) : HResult; stdcall; - end; - - // ----- OLE drag'n drop handling - - IVTDragManager = interface(IUnknown) - ['{C4B25559-14DA-446B-8901-0C879000EB16}'] - procedure ForceDragLeave; stdcall; - function GetDataObject : IDataObject; stdcall; - function GetDragSource : TBaseVirtualTree; stdcall; - function GetDropTargetHelperSupported : Boolean; stdcall; - function GetIsDropTarget : Boolean; stdcall; - - property DataObject : IDataObject read GetDataObject; - property DragSource : TBaseVirtualTree read GetDragSource; - property DropTargetHelperSupported : Boolean read GetDropTargetHelperSupported; - property IsDropTarget : Boolean read GetIsDropTarget; - end; - - // TVTDragManager is a class to manage drag and drop in a Virtual Treeview. - TVTDragManager = class(TInterfacedObject, IVTDragManager, IDropSource, IDropTarget) - private - FOwner, // The tree which is responsible for drag management. - FDragSource : TBaseVirtualTree; // Reference to the source tree if the source was a VT, might be different than the owner tree. - FIsDropTarget : Boolean; // True if the owner is currently the drop target. - FDataObject : IDataObject; // A reference to the data object passed in by DragEnter (only used when the owner tree is the current drop target). - FDropTargetHelper : IDropTargetHelper; // Win2k > Drag image support - FFullDragging : BOOL; // True, if full dragging is currently enabled in the system. - - function GetDataObject : IDataObject; stdcall; - function GetDragSource : TBaseVirtualTree; stdcall; - function GetDropTargetHelperSupported : Boolean; stdcall; - function GetIsDropTarget : Boolean; stdcall; - public - constructor Create(AOwner : TBaseVirtualTree); virtual; - destructor Destroy; override; - - function DragEnter(const DataObject : IDataObject; KeyState : Integer; Pt : TPoint; var Effect : Longint) : HResult; stdcall; - function DragLeave : HResult; stdcall; - function DragOver(KeyState : Integer; Pt : TPoint; var Effect : Longint) : HResult; stdcall; - function Drop(const DataObject : IDataObject; KeyState : Integer; Pt : TPoint; var Effect : Integer) : HResult; stdcall; - procedure ForceDragLeave; stdcall; - function GiveFeedback(Effect : Integer) : HResult; stdcall; - function QueryContinueDrag(EscapePressed : BOOL; KeyState : Integer) : HResult; stdcall; - end; - -var - StandardOLEFormat : TFormatEtc = ( - // Format must later be set. - cfFormat : 0; - // No specific target device to render on. - ptd : nil; - // Normal content to render. - dwAspect : DVASPECT_CONTENT; - // No specific page of multipage data (we don't use multipage data by default). - lindex : - 1; - // Acceptable storage formats are IStream and global memory. The first is preferred. - tymed : TYMED_ISTREAM or TYMED_HGLOBAL;); - -implementation - -uses - VirtualTrees.DataObject; - -type - TBaseVirtualTreeCracker = class(TBaseVirtualTree); - - TVTDragManagerHelper = class helper for TVTDragManager - function TreeView : TBaseVirtualTreeCracker; - end; - - - //----------------- TEnumFormatEtc ------------------------------------------------------------------------------------- - -constructor TEnumFormatEtc.Create(const AFormatEtcArray : TFormatEtcArray); -var - I : Integer; -begin - inherited Create; - // Make a local copy of the format data. - SetLength(FFormatEtcArray, Length(AFormatEtcArray)); - for I := 0 to High(AFormatEtcArray) do - FFormatEtcArray[I] := AFormatEtcArray[I]; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TEnumFormatEtc.Clone(out Enum : IEnumFormatEtc) : HResult; -var - AClone : TEnumFormatEtc; -begin - Result := S_OK; - try - AClone := TEnumFormatEtc.Create(FFormatEtcArray); - AClone.FCurrentIndex := FCurrentIndex; - Enum := AClone as IEnumFormatEtc; - except - Result := E_FAIL; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TEnumFormatEtc.Next(celt : Integer; out elt; pceltFetched : PLongint) : HResult; -var - CopyCount : Integer; -begin - Result := S_FALSE; - CopyCount := Length(FFormatEtcArray) - FCurrentIndex; - if celt < CopyCount then - CopyCount := celt; - if CopyCount > 0 then - begin - Move(FFormatEtcArray[FCurrentIndex], elt, CopyCount * SizeOf(TFormatEtc)); - Inc(FCurrentIndex, CopyCount); - Result := S_OK; - end; - if Assigned(pceltFetched) then - pceltFetched^ := CopyCount; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TEnumFormatEtc.Reset : HResult; -begin - FCurrentIndex := 0; - Result := S_OK; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TEnumFormatEtc.Skip(celt : Integer) : HResult; -begin - if FCurrentIndex + celt < High(FFormatEtcArray) then - begin - Inc(FCurrentIndex, celt); - Result := S_OK; - end - else - Result := S_FALSE; -end; - - -//---------------------------------------------------------------------------------------------------------------------- - -// OLE drag and drop support classes -// This is quite heavy stuff (compared with the VCL implementation) but is much better suited to fit the needs -// of DD'ing various kinds of virtual data and works also between applications. - - -//----------------- TVTDragManager ------------------------------------------------------------------------------------- - -constructor TVTDragManager.Create(AOwner : TBaseVirtualTree); -begin - inherited Create; - FOwner := AOwner; - - // Create an instance of the drop target helper interface. This will fail but not harm on systems which do - // not support this interface (everything below Windows 2000); - CoCreateInstance(CLSID_DragDropHelper, nil, CLSCTX_INPROC_SERVER, IID_IDropTargetHelper, FDropTargetHelper); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -destructor TVTDragManager.Destroy; -begin - // Set the owner's reference to us to nil otherwise it will access an invalid pointer - // after our desctruction is complete. - TreeView.ClearDragManager; - inherited; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTDragManager.GetDataObject : IDataObject; -begin - // When the owner tree starts a drag operation then it gets a data object here to pass it to the OLE subsystem. - // In this case there is no local reference to a data object and one is created (but not stored). - // If there is a local reference then the owner tree is currently the drop target and the stored interface is - // that of the drag initiator. - if Assigned(FDataObject) then - Result := FDataObject - else - begin - Result := TreeView.DoCreateDataObject; - if (Result = nil) and not Assigned(TreeView.OnCreateDataObject) then - // Do not create a TVTDataObject if the event handler explicitely decided not to supply one, issue #736. - Result := TVTDataObject.Create(FOwner, False) as IDataObject; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTDragManager.GetDragSource : TBaseVirtualTree; -begin - Result := FDragSource; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTDragManager.GetDropTargetHelperSupported : Boolean; -begin - Result := Assigned(FDropTargetHelper); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTDragManager.GetIsDropTarget : Boolean; -begin - Result := FIsDropTarget; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTDragManager.DragEnter(const DataObject : IDataObject; KeyState : Integer; Pt : TPoint; var Effect : Integer) : HResult; -begin - FDataObject := DataObject; - FIsDropTarget := True; - - SystemParametersInfo(SPI_GETDRAGFULLWINDOWS, 0, @FFullDragging, 0); - // If full dragging of window contents is disabled in the system then our tree windows will be locked - // and cannot be updated during a drag operation. With the following call painting is again enabled. - if not FFullDragging then - LockWindowUpdate(0); - if Assigned(FDropTargetHelper) and FFullDragging then - begin - if toAutoScroll in TreeView.TreeOptions.AutoOptions then - FDropTargetHelper.DragEnter(FOwner.Handle, DataObject, Pt, Effect) - else - FDropTargetHelper.DragEnter(0, DataObject, Pt, Effect); // Do not pass handle, otherwise the IDropTargetHelper will perform autoscroll. Issue #486 - end; - FDragSource := TreeView.GetTreeFromDataObject(DataObject); - Result := TreeView.DragEnter(KeyState, Pt, Effect); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTDragManager.DragLeave : HResult; -begin - if Assigned(FDropTargetHelper) and FFullDragging then - FDropTargetHelper.DragLeave; - - TreeView.DragLeave; - FIsDropTarget := False; - FDragSource := nil; - FDataObject := nil; - Result := NOERROR; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTDragManager.DragOver(KeyState : Integer; Pt : TPoint; var Effect : Integer) : HResult; -begin - if Assigned(FDropTargetHelper) and FFullDragging then - FDropTargetHelper.DragOver(Pt, Effect); - - Result := TreeView.DragOver(FDragSource, KeyState, dsDragMove, Pt, Effect); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTDragManager.Drop(const DataObject : IDataObject; KeyState : Integer; Pt : TPoint; var Effect : Integer) : HResult; -begin - if Assigned(FDropTargetHelper) and FFullDragging then - FDropTargetHelper.Drop(DataObject, Pt, Effect); - - Result := TreeView.DragDrop(DataObject, KeyState, Pt, Effect); - FIsDropTarget := False; - FDataObject := nil; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTDragManager.ForceDragLeave; -// Some drop targets, e.g. Internet Explorer leave a drag image on screen instead removing it when they receive -// a drop action. This method calls the drop target helper's DragLeave method to ensure it removes the drag image from -// screen. Unfortunately, sometimes not even this does help (e.g. when dragging text from VT to a text field in IE). -begin - if Assigned(FDropTargetHelper) and FFullDragging then - FDropTargetHelper.DragLeave; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTDragManager.GiveFeedback(Effect : Integer) : HResult; -begin - Result := DRAGDROP_S_USEDEFAULTCURSORS; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTDragManager.QueryContinueDrag(EscapePressed : BOOL; KeyState : Integer) : HResult; -var - RButton, LButton : Boolean; -begin - LButton := (KeyState and MK_LBUTTON) <> 0; - RButton := (KeyState and MK_RBUTTON) <> 0; - - // Drag'n drop canceled by pressing both mouse buttons or Esc? - if (LButton and RButton) or EscapePressed then - Result := DRAGDROP_S_CANCEL - else - // Drag'n drop finished? - if not (LButton or RButton) then - Result := DRAGDROP_S_DROP - else - Result := S_OK; -end; - -{ TVTDragManagerHelper } - -function TVTDragManagerHelper.TreeView : TBaseVirtualTreeCracker; -begin - Result := TBaseVirtualTreeCracker(FOwner); -end; - -end. diff --git a/components/virtualtreeview/Source/VirtualTrees.DrawTree.pas b/components/virtualtreeview/Source/VirtualTrees.DrawTree.pas deleted file mode 100644 index 357394b6..00000000 --- a/components/virtualtreeview/Source/VirtualTrees.DrawTree.pas +++ /dev/null @@ -1,331 +0,0 @@ -unit VirtualTrees.DrawTree; - -interface - -uses - System.Types, - System.Classes, - VirtualTrees.Types, - VirtualTrees; - - -type - // Tree descendant to let an application draw its stuff itself. - TCustomVirtualDrawTree = class(TBaseVirtualTree) - private - FOnDrawNode: TVTDrawNodeEvent; - FOnGetCellContentMargin: TVTGetCellContentMarginEvent; - FOnGetNodeWidth: TVTGetNodeWidthEvent; - protected - function DoGetCellContentMargin(Node: PVirtualNode; Column: TColumnIndex; - CellContentMarginType: TVTCellContentMarginType = ccmtAllSides; Canvas: TCanvas = nil): TPoint; override; - function DoGetNodeWidth(Node: PVirtualNode; Column: TColumnIndex; Canvas: TCanvas = nil): Integer; override; - procedure DoPaintNode(var PaintInfo: TVTPaintInfo); override; - function GetDefaultHintKind: TVTHintKind; override; - - property OnDrawNode: TVTDrawNodeEvent read FOnDrawNode write FOnDrawNode; - property OnGetCellContentMargin: TVTGetCellContentMarginEvent read FOnGetCellContentMargin write FOnGetCellContentMargin; - property OnGetNodeWidth: TVTGetNodeWidthEvent read FOnGetNodeWidth write FOnGetNodeWidth; - end; - - [ComponentPlatformsAttribute(pidWin32 or pidWin64)] - TVirtualDrawTree = class(TCustomVirtualDrawTree) - private - function GetOptions: TVirtualTreeOptions; - procedure SetOptions(const Value: TVirtualTreeOptions); - protected - function GetOptionsClass: TTreeOptionsClass; override; - public - property Canvas; - property LastDragEffect; - property CheckImageKind; // should no more be published to make #622 fix working - published - property Action; - property Align; - property Alignment; - property Anchors; - property AnimationDuration; - property AutoExpandDelay; - property AutoScrollDelay; - property AutoScrollInterval; - property Background; - property BackgroundOffsetX; - property BackgroundOffsetY; - property BiDiMode; - property BevelEdges; - property BevelInner; - property BevelOuter; - property BevelKind; - property BevelWidth; - property BorderStyle; - property BottomSpace; - property ButtonFillMode; - property ButtonStyle; - property BorderWidth; - property ChangeDelay; - property ClipboardFormats; - property Color; - property Colors; - property Constraints; - property Ctl3D; - property CustomCheckImages; - property DefaultNodeHeight; - property DefaultPasteMode; - property DragCursor; - property DragHeight; - property DragKind; - property DragImageKind; - property DragMode; - property DragOperations; - property DragType; - property DragWidth; - property DrawSelectionMode; - property EditDelay; - property Enabled; - property Font; - property Header; - property HintMode; - property HotCursor; - property Images; - property IncrementalSearch; - property IncrementalSearchDirection; - property IncrementalSearchStart; - property IncrementalSearchTimeout; - property Indent; - property LineMode; - property LineStyle; - property Margin; - property NodeAlignment; - property NodeDataSize; - property OperationCanceled; - property ParentBiDiMode; - property ParentColor default False; - property ParentCtl3D; - property ParentFont; - property ParentShowHint; - property PopupMenu; - property RootNodeCount; - property ScrollBarOptions; - property SelectionBlendFactor; - property SelectionCurveRadius; - property ShowHint; - property StateImages; - property TabOrder; - property TabStop default True; - property TextMargin; - property TreeOptions: TVirtualTreeOptions read GetOptions write SetOptions; - property Visible; - property WantTabs; - - property OnAddToSelection; - property OnAdvancedHeaderDraw; - property OnAfterAutoFitColumn; - property OnAfterAutoFitColumns; - property OnAfterCellPaint; - property OnAfterColumnExport; - property OnAfterColumnWidthTracking; - property OnAfterGetMaxColumnWidth; - property OnAfterHeaderExport; - property OnAfterHeaderHeightTracking; - property OnAfterItemErase; - property OnAfterItemPaint; - property OnAfterNodeExport; - property OnAfterPaint; - property OnAfterTreeExport; - property OnBeforeAutoFitColumn; - property OnBeforeAutoFitColumns; - property OnBeforeCellPaint; - property OnBeforeColumnExport; - property OnBeforeColumnWidthTracking; - property OnBeforeDrawTreeLine; - property OnBeforeGetMaxColumnWidth; - property OnBeforeHeaderExport; - property OnBeforeHeaderHeightTracking; - property OnBeforeItemErase; - property OnBeforeItemPaint; - property OnBeforeNodeExport; - property OnBeforePaint; - property OnBeforeTreeExport; - property OnCanSplitterResizeColumn; - property OnCanSplitterResizeHeader; - property OnCanSplitterResizeNode; - property OnChange; - property OnChecked; - property OnChecking; - property OnClick; - property OnCollapsed; - property OnCollapsing; - property OnColumnClick; - property OnColumnDblClick; - property OnColumnExport; - property OnColumnResize; - property OnColumnVisibilityChanged; - property OnColumnWidthDblClickResize; - property OnColumnWidthTracking; - property OnCompareNodes; - property OnContextPopup; - property OnCreateDataObject; - property OnCreateDragManager; - property OnCreateEditor; - property OnDblClick; - property OnDragAllowed; - property OnDragOver; - property OnDragDrop; - property OnDrawHint; - property OnDrawNode; - property OnEdited; - property OnEditing; - property OnEndDock; - property OnEndDrag; - property OnEndOperation; - property OnEnter; - property OnExit; - property OnExpanded; - property OnExpanding; - property OnFocusChanged; - property OnFocusChanging; - property OnFreeNode; - property OnGetCellIsEmpty; - property OnGetCursor; - property OnGetHeaderCursor; - property OnGetHelpContext; - property OnGetHintKind; - property OnGetHintSize; - property OnGetImageIndex; - property OnGetImageIndexEx; - property OnGetLineStyle; - property OnGetNodeDataSize; - property OnGetNodeWidth; - property OnGetPopupMenu; - property OnGetUserClipboardFormats; - property OnHeaderAddPopupItem; - property OnHeaderClick; - property OnHeaderDblClick; - property OnHeaderDragged; - property OnHeaderDraggedOut; - property OnHeaderDragging; - property OnHeaderDraw; - property OnHeaderDrawQueryElements; - property OnHeaderHeightTracking; - property OnHeaderHeightDblClickResize; - property OnHeaderMouseDown; - property OnHeaderMouseMove; - property OnHeaderMouseUp; - property OnHotChange; - property OnIncrementalSearch; - property OnInitChildren; - property OnInitNode; - property OnKeyAction; - property OnKeyDown; - property OnKeyPress; - property OnKeyUp; - property OnLoadNode; - property OnLoadTree; - property OnMeasureItem; - property OnMouseDown; - property OnMouseMove; - property OnMouseUp; - property OnMouseWheel; - property OnNodeClick; - property OnNodeCopied; - property OnNodeCopying; - property OnNodeDblClick; - property OnNodeExport; - property OnNodeHeightTracking; - property OnNodeHeightDblClickResize; - property OnNodeMoved; - property OnNodeMoving; - property OnPaintBackground; - property OnPrepareButtonBitmaps; - property OnRemoveFromSelection; - property OnRenderOLEData; - property OnResetNode; - property OnResize; - property OnSaveNode; - property OnSaveTree; - property OnScroll; - property OnShowScrollBar; - property OnStartDock; - property OnStartDrag; - property OnStartOperation; - property OnStateChange; - property OnStructureChange; - property OnUpdating; - property OnCanResize; - property OnGesture; - property Touch; - property StyleElements; - end; - - -implementation - -//---------------------------------------------------------------------------------------------------------------------- - -function TCustomVirtualDrawTree.DoGetCellContentMargin(Node: PVirtualNode; Column: TColumnIndex; - CellContentMarginType: TVTCellContentMarginType = ccmtAllSides; Canvas: TCanvas = nil): TPoint; - -begin - Result := Point(0, 0); - if Canvas = nil then - Canvas := Self.Canvas; - - if Assigned(FOnGetCellContentMargin) then - FOnGetCellContentMargin(Self, Canvas, Node, Column, CellContentMarginType, Result); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TCustomVirtualDrawTree.DoGetNodeWidth(Node: PVirtualNode; Column: TColumnIndex; Canvas: TCanvas = nil): Integer; - -begin - Result := 2 * TextMargin; - if Canvas = nil then - Canvas := Self.Canvas; - - if Assigned(FOnGetNodeWidth) then - FOnGetNodeWidth(Self, Canvas, Node, Column, Result); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TCustomVirtualDrawTree.DoPaintNode(var PaintInfo: TVTPaintInfo); - -begin - if Assigned(FOnDrawNode) then - FOnDrawNode(Self, PaintInfo); -end; - -function TCustomVirtualDrawTree.GetDefaultHintKind: TVTHintKind; - -begin - Result := vhkOwnerDraw; -end; - -//----------------- TVirtualDrawTree ----------------------------------------------------------------------------------- - -function TVirtualDrawTree.GetOptions: TVirtualTreeOptions; - -begin - Result := inherited TreeOptions as TVirtualTreeOptions; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualDrawTree.SetOptions(const Value: TVirtualTreeOptions); - -begin - TreeOptions.Assign(Value); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVirtualDrawTree.GetOptionsClass: TTreeOptionsClass; - -begin - Result := TVirtualTreeOptions; -end; - - - -end. diff --git a/components/virtualtreeview/Source/VirtualTrees.EditLink.pas b/components/virtualtreeview/Source/VirtualTrees.EditLink.pas deleted file mode 100644 index 0a64ce7f..00000000 --- a/components/virtualtreeview/Source/VirtualTrees.EditLink.pas +++ /dev/null @@ -1,893 +0,0 @@ -unit VirtualTrees.EditLink; - -// Base class for inplace node editors implementing IVTEditLink interface -// and default node editor. - -interface - -uses - WinApi.Messages, - System.Types, - System.Classes, - Vcl.Controls, - Vcl.StdCtrls, - VirtualTrees, - VirtualTrees.Types; - -type - //Edit support Classes. - TStringEditLink = class; - - TVTEdit = class(TCustomEdit) - private - procedure CMAutoAdjust(var Message : TMessage); message CM_AUTOADJUST; - procedure CMExit(var Message : TMessage); message CM_EXIT; - procedure CMRelease(var Message : TMessage); message CM_RELEASE; - procedure CNCommand(var Message : TWMCommand); message CN_COMMAND; - procedure WMChar(var Message : TWMChar); message WM_CHAR; - procedure WMDestroy(var Message : TWMDestroy); message WM_DESTROY; - procedure WMGetDlgCode(var Message : TWMGetDlgCode); message WM_GETDLGCODE; - procedure WMKeyDown(var Message : TWMKeyDown); message WM_KEYDOWN; - protected - FRefLink : IVTEditLink; - FLink : TStringEditLink; - procedure AutoAdjustSize; virtual; - function CalcMinHeight : Integer; virtual; - procedure CreateParams(var Params : TCreateParams); override; - function GetTextSize : TSize; virtual; - procedure KeyPress(var Key : Char); override; - public - constructor Create(Link : TStringEditLink); reintroduce; - procedure ClearLink; - procedure ClearRefLink; - procedure Release; virtual; - - property AutoSelect; - property AutoSize; - property BorderStyle; - property CharCase; - property HideSelection; - property MaxLength; - property OEMConvert; - property PasswordChar; - end; - - TBaseEditLink = class; - - TEditLinkEditEvent = procedure (Sender: TBaseEditLink; var Result: Boolean) of object; - TEditLinkPrepareEditEvent = procedure (Sender: TBaseEditLink; var Edit: TControl; var Result: Boolean) of object; - - // Most abstract base class for implementing IVTEditLink. - // Knows almost nothing about associated Edit control and doesn't perform any - // actions on it. Contains some properties that are not used directly but could - // be useful in descendant classes. Follows general extension approach - all - // IVTEditLink methods are virtual and most of them call DoXXX virtual methods - // which in turn call event handlers so these extension options possible: - // - overriding main API methods to run additional actions before, after or - // instead of basic class code. - // (+) Lesser modification of existing classes - // (-) Event handlers are already launched after calling parent method - // (-) It's critical to check Result of parent method and exit immediately - // on False - this value means no action is done. - // (-) Returning Result is necessary - // - overriding DoXXX methods to run additional actions inside basic class code - // (+) No need in returning - lesser boilerplate code - // (-) Should call inherited to launch event handlers (OK if not using them) - // - assign event handlers in end-user code - // (+) Access to external classes with data to copy to EditLink editor. - // (-) Lesser encapsulation - TBaseEditLink = class(TInterfacedObject, IVTEditLink) - strict protected - FEdit: TControl; // One of the property editor classes. - FTree : TCustomVirtualStringTree; //A back reference to the tree calling. - FNode : PVirtualNode; //The node to be edited. - FColumn : TColumnIndex; //The column of the node. - FStopping : Boolean; //Set to True when the edit link requests stopping the edit action. - FAlignment : TAlignment; - FBiDiMode: TBiDiMode; - - // custom event handlers - FOnPrepareEdit: TEditLinkPrepareEditEvent; - FOnBeginEdit, - FOnEndEdit, - FOnCancelEdit: TEditLinkEditEvent; - - procedure SetEdit(const Value : TControl); //Setter for the FEdit member; - public - // IVTEditLink API - function BeginEdit : Boolean; virtual; stdcall; - function CancelEdit : Boolean; virtual; stdcall; - function EndEdit : Boolean; virtual; stdcall; - function GetBounds : TRect; virtual; stdcall; abstract; - function PrepareEdit(Tree : TBaseVirtualTree; Node : PVirtualNode; Column : TColumnIndex) : Boolean; virtual; stdcall; - procedure ProcessMessage(var Message : TMessage); virtual; stdcall; abstract; - procedure SetBounds(R : TRect); virtual; stdcall; abstract; - - // Methods to plug custom actions into main ones. In base class only call event handlers. - // Descendants may modify Result to cancel further flow. - procedure DoBeginEdit(var Result: Boolean); virtual; - procedure DoCancelEdit(var Result: Boolean); virtual; - procedure DoEndEdit(var Result: Boolean); virtual; - procedure DoPrepareEdit(var Result: Boolean); virtual; - - property Alignment : TAlignment read FAlignment; - property BiDiMode: TBiDiMode read FBiDiMode; - property Column : TColumnIndex read FColumn; //[IPK] Make Column(Index) accessible - property Node : PVirtualNode read FNode; //[IPK] Make FNode accessible - property Tree : TCustomVirtualStringTree read FTree; - property Stopping : Boolean read FStopping; - - property OnBeginEdit: TEditLinkEditEvent read FOnBeginEdit write FOnBeginEdit; - property OnCancelEdit: TEditLinkEditEvent read FOnCancelEdit write FOnCancelEdit; - property OnEndEdit: TEditLinkEditEvent read FOnEndEdit write FOnEndEdit; - property OnPrepareEdit: TEditLinkPrepareEditEvent read FOnPrepareEdit write FOnPrepareEdit; - end; - - // Edit link that has TWinControl-based Edit. Performs visibility and focus actions, - // transfers window messages to Edit control. - TWinControlEditLink = class(TBaseEditLink) - protected - function GetEdit: TWinControl; //Getter for the FEdit member; - procedure SetEdit(const Value : TWinControl); //Setter for the FEdit member; - public - destructor Destroy; override; - - function BeginEdit : Boolean; override; stdcall; - function CancelEdit : Boolean; override; stdcall; - function EndEdit : Boolean; override; stdcall; - function GetBounds : TRect; override; stdcall; - procedure ProcessMessage(var Message : TMessage); override; stdcall; - - property Edit : TWinControl read GetEdit write SetEdit; - end; - - // Edit link that implements default node text editor. - TStringEditLink = class(TWinControlEditLink) - protected - FTextBounds : TRect; //Smallest rectangle around the text. - function GetEdit: TVTEdit; //Getter for the FEdit member; - procedure SetEdit(const Value : TVTEdit); //Setter for the FEdit member; - public - constructor Create; - - function BeginEdit : Boolean; override; stdcall; - function CancelEdit : Boolean; override; stdcall; - function EndEdit : Boolean; override; stdcall; - function PrepareEdit(Tree : TBaseVirtualTree; Node : PVirtualNode; Column : TColumnIndex) : Boolean; override; stdcall; - procedure SetBounds(R : TRect); override; stdcall; - - property Edit : TVTEdit read GetEdit write SetEdit; - end; - -implementation - -uses - WinApi.Windows, - System.SysUtils, - System.Math, - Vcl.Graphics, - Vcl.Forms; - -type - TCustomVirtualStringTreeCracker = class(TCustomVirtualStringTree); - -//----------------- TVTEdit -------------------------------------------------------------------------------------------- - -//Implementation of a generic node caption editor. - -constructor TVTEdit.Create(Link : TStringEditLink); -begin - inherited Create(nil); - if not Assigned(Link) then - raise EArgumentException.Create('Parameter Link must not be nil.'); - ShowHint := False; - ParentShowHint := False; - //This assignment increases the reference count for the interface. - FRefLink := Link; - //This reference is used to access the link. - FLink := Link; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTEdit.ClearLink; -begin - FLink := nil -end; - -//---------------------------------------------------------------------------------------------------------------------- -procedure TVTEdit.ClearRefLink; -begin - FRefLink := nil -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTEdit.CalcMinHeight : Integer; -var - textHeight : Integer; -begin - //Get the actual text height. - textHeight := GetTextSize.cy; - //The minimal height is the actual text height in pixels plus the the non client area. - Result := textHeight + (Height - ClientHeight); - //Also, proportionally to the text size, additional pixel(s) needs to be added for the caret. - Result := Result + Trunc(textHeight * 0.05); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTEdit.CMAutoAdjust(var Message : TMessage); -begin - AutoAdjustSize; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTEdit.CMExit(var Message : TMessage); -begin - if Assigned(FLink) and not FLink.Stopping then - with TCustomVirtualStringTreeCracker(FLink.Tree) do - begin - if (toAutoAcceptEditChange in TreeOptions.StringOptions) then - DoEndEdit - else - DoCancelEdit; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTEdit.CMRelease(var Message : TMessage); -begin - Free; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTEdit.CNCommand(var Message : TWMCommand); -begin - if Assigned(FLink) and Assigned(FLink.Tree) and (Message.NotifyCode = EN_UPDATE) and not (vsMultiline in FLink.Node.States) then - //Instead directly calling AutoAdjustSize it is necessary on Win9x/Me to decouple this notification message - //and eventual resizing. Hence we use a message to accomplish that. - AutoAdjustSize() - else - inherited; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTEdit.WMChar(var Message : TWMChar); -begin - if not (Message.CharCode in [VK_ESCAPE, VK_TAB]) then - inherited; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTEdit.WMDestroy(var Message : TWMDestroy); -begin - //If editing stopped by other means than accept or cancel then we have to do default processing for - //pending changes. - if Assigned(FLink) and not FLink.Stopping and not (csRecreating in Self.ControlState) then - begin - with TCustomVirtualStringTreeCracker(FLink.Tree) do - begin - if (toAutoAcceptEditChange in TreeOptions.StringOptions) and Modified then - Text[FLink.Node, FLink.Column] := FLink.Edit.Text; - end; - FLink := nil; - FRefLink := nil; - end; - - inherited; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTEdit.WMGetDlgCode(var Message : TWMGetDlgCode); -begin - inherited; - - Message.Result := Message.Result or DLGC_WANTALLKEYS or DLGC_WANTTAB or DLGC_WANTARROWS; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTEdit.WMKeyDown(var Message : TWMKeyDown); -//Handles some control keys. - -var - Shift : TShiftState; - EndEdit : Boolean; - Tree : TBaseVirtualTree; - NextNode : PVirtualNode; - ColumnCandidate : Integer; - EditOptions : TVTEditOptions; - Column : TVirtualTreeColumn; -begin - Tree := FLink.Tree; - case Message.CharCode of - VK_ESCAPE : - begin - TCustomVirtualStringTreeCracker(Tree).DoCancelEdit; - end; - VK_RETURN : - begin - EndEdit := not (vsMultiline in FLink.Node.States); - if not EndEdit then - begin - //If a multiline node is being edited the finish editing only if Ctrl+Enter was pressed, - //otherwise allow to insert line breaks into the text. - Shift := KeyDataToShiftState(Message.KeyData); - EndEdit := ssCtrl in Shift; - end; - if EndEdit then - begin - Tree := FLink.Tree; - FLink.Tree.InvalidateNode(FLink.Node); - NextNode := Tree.GetNextVisible(FLink.Node, True); - TCustomVirtualStringTreeCracker(FLink.Tree).DoEndEdit; - - //get edit options for column as priority. If column has toDefaultEdit - //use global edit options for tree - EditOptions := TCustomVirtualStringTreeCracker(Tree).TreeOptions.EditOptions; //default - ColumnCandidate := - 1; - if Tree.Header.Columns.Count > 0 then //are there any columns? - begin - Column := Tree.Header.Columns[Tree.FocusedColumn]; - if Column.EditOptions <> toDefaultEdit then - EditOptions := Column.EditOptions; - - //next column candidate for toVerticalEdit and toHorizontalEdit - if Column.EditNextColumn <> - 1 then - ColumnCandidate := Column.EditNextColumn; - end; - - case EditOptions of - toDefaultEdit : - TCustomVirtualStringTreeCracker(Tree).TrySetFocus; - toVerticalEdit : - if NextNode <> nil then - begin - Tree.FocusedNode := NextNode; - - //for toVerticalEdit ColumnCandidate is also proper, - //select ColumnCandidate column in row below - if ColumnCandidate <> - 1 then - begin - Tree.FocusedColumn := ColumnCandidate; - TCustomVirtualStringTreeCracker(Tree).EditColumn := ColumnCandidate; - end; - - if Tree.CanEdit(Tree.FocusedNode, Tree.FocusedColumn) then - TCustomVirtualStringTreeCracker(Tree).DoEdit; - end; - toHorizontalEdit : - begin - if ColumnCandidate = - 1 then - begin - //for toHorizontalEdit if property EditNextColumn is not used - //try to use just next column - ColumnCandidate := Tree.FocusedColumn + 1; - while (ColumnCandidate < Tree.Header.Columns.Count) and not Tree.CanEdit(Tree.FocusedNode, ColumnCandidate) do - Inc(ColumnCandidate); - end - else if not Tree.CanEdit(Tree.FocusedNode, ColumnCandidate) then - ColumnCandidate := Tree.Header.Columns.Count; //omit "focus/edit column" (see below) - - if ColumnCandidate < Tree.Header.Columns.Count then - begin - Tree.FocusedColumn := ColumnCandidate; - TCustomVirtualStringTreeCracker(Tree).EditColumn := ColumnCandidate; - TCustomVirtualStringTreeCracker(Tree).DoEdit; - end; - end; - end; - end; - end; - VK_UP : - begin - if not (vsMultiline in FLink.Node.States) then - Message.CharCode := VK_LEFT; - inherited; - end; - VK_DOWN : - begin - if not (vsMultiline in FLink.Node.States) then - Message.CharCode := VK_RIGHT; - inherited; - end; - VK_TAB : - begin - if Tree.IsEditing then - begin - Tree.InvalidateNode(FLink.Node); - if ssShift in KeyDataToShiftState(Message.KeyData) then - NextNode := Tree.GetPreviousVisible(FLink.Node, True)//Shift+Tab goes to previous mode - else - NextNode := Tree.GetNextVisible(FLink.Node, True); - Tree.EndEditNode; - //check NextNode, otherwise we got AV - if NextNode <> nil then - begin - //Continue editing next node - Tree.ClearSelection(); - Tree.Selected[NextNode] := True; - if Tree.CanEdit(Tree.FocusedNode, Tree.FocusedColumn) then - TCustomVirtualStringTreeCracker(Tree).DoEdit; - end; - end; - end; - Ord('A') : - begin - if Tree.IsEditing and ([ssCtrl] = KeyboardStateToShiftState) then - begin - Self.SelectAll(); - Message.CharCode := 0; - end; - end; - else - inherited; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTEdit.AutoAdjustSize; -//Changes the size of the edit to accomodate as much as possible of its text within its container window. -//NewChar describes the next character which will be added to the edit's text. - -var - Size : TSize; -begin - if not (vsMultiline in FLink.Node.States) and not (toGridExtensions in TCustomVirtualStringTreeCracker(FLink.Tree).TreeOptions.MiscOptions { see issue #252 } ) then - begin - //avoid flicker - SendMessage(Handle, WM_SETREDRAW, 0, 0); - try - Size := GetTextSize; - Inc(Size.cx, 2 * TCustomVirtualStringTreeCracker(FLink.Tree).TextMargin); - //Repaint associated node if the edit becomes smaller. - if Size.cx < Width then - FLink.Tree.Invalidate(); - - if FLink.Alignment = taRightJustify then - FLink.SetBounds(Rect(Left + Width - Size.cx, Top, Left + Width, Top + Max(Size.cy, Height))) - else - FLink.SetBounds(Rect(Left, Top, Left + Size.cx, Top + Max(Size.cy, Height))); - finally - SendMessage(Handle, WM_SETREDRAW, 1, 0); - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTEdit.CreateParams(var Params : TCreateParams); -begin - inherited; - if not Assigned(FLink.Node) then - exit; //Prevent AV exceptions occasionally seen in code below - - //Only with multiline style we can use the text formatting rectangle. - //This does not harm formatting as single line control, if we don't use word wrapping. - with Params do - begin - Style := Style or ES_MULTILINE; - if vsMultiline in FLink.Node.States then - Style := Style and not (ES_AUTOHSCROLL or WS_HSCROLL) or WS_VSCROLL or ES_AUTOVSCROLL; - if tsUseThemes in FLink.Tree.TreeStates then - begin - Style := Style and not WS_BORDER; - ExStyle := ExStyle or WS_EX_CLIENTEDGE; - end - else - begin - Style := Style or WS_BORDER; - ExStyle := ExStyle and not WS_EX_CLIENTEDGE; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTEdit.GetTextSize : TSize; -var - DC : HDC; - LastFont : THandle; -begin - DC := GetDC(Handle); - LastFont := SelectObject(DC, Font.Handle); - try - //Read needed space for the current text. - GetTextExtentPoint32(DC, PChar(Text + 'yG'), Length(Text) + 2, Result); - finally - SelectObject(DC, LastFont); - ReleaseDC(Handle, DC); - end; -end; - -procedure TVTEdit.KeyPress(var Key : Char); -begin - if (Key = #13) and Assigned(FLink) and not (vsMultiline in FLink.Node.States) then - Key := #0; //Filter out return keys as they will be added to the text, avoids #895 - inherited; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTEdit.Release; -begin - if HandleAllocated then - PostMessage(Handle, CM_RELEASE, 0, 0); -end; - -//----------------- TBaseEditLink ------------------------------------------------------------------------------------ - -procedure TBaseEditLink.SetEdit(const Value : TControl); -begin - if Assigned(FEdit) then - FEdit.Free; - FEdit := Value; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseEditLink.BeginEdit : Boolean; -//Notifies the edit link that editing can start now. descendants may cancel node edit -//by returning False. - -begin - Result := not FStopping; - if Result then - DoBeginEdit(Result); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseEditLink.CancelEdit : Boolean; - -// Performs edit cancelling. - -begin - Result := not FStopping; - if Result then - begin - // Let descendants cancel the cancel - DoCancelEdit(Result); - if not Result then - Exit; - FStopping := True; - FTree.CancelEditNode; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseEditLink.EndEdit : Boolean; - -// Performs edit ending. - -begin - Result := not FStopping; - if Result then - begin - // Let descendants cancel the end - DoEndEdit(Result); - if not Result then - Exit; - FStopping := True; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseEditLink.PrepareEdit(Tree : TBaseVirtualTree; Node : PVirtualNode; Column : TColumnIndex) : Boolean; - -// Performs general init: assign Tree, Node, Column, other properties; destroys previous -// edit instance. - -begin - Result := Tree is TCustomVirtualStringTree; - if not Result then Exit; // should not happen - - FTree := Tree as TCustomVirtualStringTree; - FNode := Node; - FColumn := Column; - if Column <= NoColumn then - begin - FBidiMode := FTree.BidiMode; - FAlignment := TCustomVirtualStringTreeCracker(FTree).Alignment; - end - else - begin - FBidiMode := FTree.Header.Columns[Column].BidiMode; - FAlignment := FTree.Header.Columns[Column].Alignment; - end; - SetEdit(nil); // always dispose edit - - DoPrepareEdit(Result); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseEditLink.DoBeginEdit(var Result: Boolean); -begin - if Assigned(OnBeginEdit) then - OnBeginEdit(Self, Result); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseEditLink.DoCancelEdit(var Result: Boolean); -begin - if Assigned(OnCancelEdit) then - OnCancelEdit(Self, Result); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseEditLink.DoEndEdit(var Result: Boolean); -begin - if Assigned(OnEndEdit) then - OnEndEdit(Self, Result); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseEditLink.DoPrepareEdit(var Result: Boolean); -begin - if Assigned(OnPrepareEdit) then - OnPrepareEdit(Self, FEdit, Result); -end; - -//----------------- TWinControlEditLink ------------------------------------------------------------------------------------ - -destructor TWinControlEditLink.Destroy; -begin - //FEdit.Free; casues issue #357. Fix: - if Assigned(FEdit) and Edit.HandleAllocated then - PostMessage(Edit.Handle, CM_RELEASE, 0, 0); - inherited; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TWinControlEditLink.GetEdit: TWinControl; -begin - Result := TWinControl(FEdit); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TWinControlEditLink.SetEdit(const Value: TWinControl); -begin - inherited SetEdit(Value); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TWinControlEditLink.BeginEdit: Boolean; -begin - Result := inherited; - if Result then - begin - Edit.Show; - Edit.SetFocus; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TWinControlEditLink.CancelEdit: Boolean; -begin - Result := inherited; - if Result then - begin - Edit.Hide; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TWinControlEditLink.GetBounds : TRect; -begin - Result := FEdit.BoundsRect; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TWinControlEditLink.ProcessMessage(var Message : TMessage); -begin - FEdit.WindowProc(Message); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TWinControlEditLink.EndEdit: Boolean; -begin - Result := inherited; - if Result then - begin - Edit.Hide; - end; -end; - -//----------------- TStringEditLink ------------------------------------------------------------------------------------ - -constructor TStringEditLink.Create; -begin - inherited; - FEdit := TVTEdit.Create(Self); - with Edit do - begin - Visible := False; - BorderStyle := bsSingle; - AutoSize := False; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TStringEditLink.GetEdit: TVTEdit; -begin - Result := TVTEdit(FEdit); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TStringEditLink.SetEdit(const Value : TVTEdit); -begin - inherited SetEdit(Value); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TStringEditLink.BeginEdit : Boolean; -begin - Result := inherited; - if Result then - begin - Edit.SelectAll; - Edit.AutoAdjustSize; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TStringEditLink.CancelEdit : Boolean; -begin - Result := inherited; - if Result then - begin - Edit.ClearLink; - Edit.ClearRefLink; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TStringEditLink.EndEdit : Boolean; -begin - Result := inherited; - if Result then - try - if Edit.Modified then - FTree.Text[FNode, FColumn] := Edit.Text; - Edit.ClearLink; - Edit.ClearRefLink; - except - FStopping := False; - raise; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TStringEditLink.PrepareEdit(Tree : TBaseVirtualTree; Node : PVirtualNode; Column : TColumnIndex) : Boolean; -var - Text : string; -begin - Result := inherited; - if Result then - begin - Edit := TVTEdit.Create(Self); - Edit.Visible := False; - Edit.BorderStyle := bsSingle; - Edit.AutoSize := True; - Edit.Parent := Tree; - //Initial size, font and text of the node. - FTree.GetTextInfo(Node, Column, Edit.Font, FTextBounds, Text); - Edit.Font.Color := clWindowText; - Edit.RecreateWnd; - Edit.AutoSize := False; - Edit.Text := Text; - Edit.BidiMode := FBidiMode; - if Edit.BidiMode <> bdLeftToRight then - ChangeBidiModeAlignment(FAlignment); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TStringEditLink.SetBounds(R : TRect); -//Sets the outer bounds of the edit control and the actual edit area in the control. - -var - lOffset, tOffset, Height : Integer; - offsets : TVTOffsets; -begin - if not FStopping then - begin - //Check if the provided rect height is smaller than the edit control height. - Height := R.Bottom - R.Top; - if Height < Edit.ClientHeight then - begin - //If the height is smaller than the minimal height we must correct it, otherwise the caret will be invisible. - tOffset := Edit.CalcMinHeight - Height; - if tOffset > 0 then - Inc(R.Bottom, tOffset); - end; - - //Set the edit's bounds but make sure there's a minimum width and the right border does not - //extend beyond the parent's left/right border. - if R.Left < 0 then - R.Left := 0; - if R.Right - R.Left < 30 then - begin - if FAlignment = taRightJustify then - R.Left := R.Right - 30 - else - R.Right := R.Left + 30; - end; - if R.Right > FTree.ClientWidth then - R.Right := FTree.ClientWidth; - Edit.BoundsRect := R; - - //The selected text shall exclude the text margins and be centered vertically. - //We have to take out the two pixel border of the edit control as well as a one pixel "edit border" the - //control leaves around the (selected) text. - R := Edit.ClientRect; - - //If toGridExtensions are turned on, we can fine tune the left margin (or the right margin if RTL is on) - //of the text to exactly match the text in the tree cell. - if (toGridExtensions in TCustomVirtualStringTreeCracker(FTree).TreeOptions.MiscOptions) and - ((FAlignment = taLeftJustify) and (Edit.BidiMode = bdLeftToRight) or (FAlignment = taRightJustify) and (Edit.BidiMode <> bdLeftToRight)) then - begin - //Calculate needed text area offset. - FTree.GetOffsets(FNode, offsets, ofsText, FColumn); - if FColumn = FTree.Header.MainColumn then - begin - if offsets[ofsToggleButton] < 0 then - lOffset := - (offsets[ofsToggleButton] + 2) - else - lOffset := 0; - end - else - lOffset := offsets[ofsText] - offsets[ofsMargin] + 1; - //Apply the offset. - if Edit.BidiMode = bdLeftToRight then - Inc(R.Left, lOffset) - else - Dec(R.Right, lOffset); - end; - - lOffset := IfThen(vsMultiline in FNode.States, 0, 2); - if tsUseThemes in FTree.TreeStates then - Inc(lOffset); - InflateRect(R, - TCustomVirtualStringTreeCracker(FTree).TextMargin + lOffset, lOffset); - if not (vsMultiline in FNode.States) then - begin - tOffset := FTextBounds.Top - Edit.Top; - //Do not apply a negative offset, the cursor will disappear. - if tOffset > 0 then - OffsetRect(R, 0, tOffset); - end; - R.Top := Max( - 1, R.Top); //A value smaller than -1 will prevent the edit cursor from being shown by Windows, see issue #159 - R.Left := Max( - 1, R.Left); - SendMessage(Edit.Handle, EM_SETRECTNP, 0, LPARAM(@R)); - end; -end; - -end. diff --git a/components/virtualtreeview/Source/VirtualTrees.Export.pas b/components/virtualtreeview/Source/VirtualTrees.Export.pas index 3ce4a9fb..8ae32cd0 100644 --- a/components/virtualtreeview/Source/VirtualTrees.Export.pas +++ b/components/virtualtreeview/Source/VirtualTrees.Export.pas @@ -26,10 +26,7 @@ uses System.SysUtils, System.StrUtils, System.Generics.Collections, - System.UITypes, - VirtualTrees.Types, - VirtualTrees.ClipBoard, - VirtualTrees.Header; + System.UITypes; type TCustomVirtualStringTreeCracker = class(TCustomVirtualStringTree) diff --git a/components/virtualtreeview/Source/VirtualTrees.Header.pas b/components/virtualtreeview/Source/VirtualTrees.Header.pas deleted file mode 100644 index 6d6568e9..00000000 --- a/components/virtualtreeview/Source/VirtualTrees.Header.pas +++ /dev/null @@ -1,5922 +0,0 @@ -unit VirtualTrees.Header; - -interface - -uses - System.Classes, - System.Types, - System.Generics.Collections, - WinApi.Windows, - WinApi.Messages, - Vcl.Graphics, - Vcl.Menus, - Vcl.ImgList, - Vcl.Controls, - Vcl.Themes, - Vcl.GraphUtil, - System.UITypes, - VirtualTrees.StyleHooks, - VirtualTrees.Utils, - VirtualTrees.Types, - VirtualTrees.DragImage; - - -{$MINENUMSIZE 1, make enumerations as small as possible} - - -const - DefaultColumnOptions = [coAllowClick, coDraggable, coEnabled, coParentColor, coParentBidiMode, coResizable, - coShowDropMark, coVisible, coAllowFocus, coEditable, coStyleColor]; - -type - TVTHeader = class; - TVirtualTreeColumn = class; - - // This structure carries all important information about header painting and is used in the advanced header painting. - THeaderPaintInfo = record - TargetCanvas : TCanvas; - Column : TVirtualTreeColumn; - PaintRectangle : TRect; - TextRectangle : TRect; - IsHoverIndex, - IsDownIndex, - IsEnabled, - ShowHeaderGlyph, - ShowSortGlyph, - ShowRightBorder : Boolean; - DropMark : TVTDropMarkMode; - GlyphPos, - SortGlyphPos : TPoint; - SortGlyphSize : TSize; - procedure DrawSortArrow(pDirection : TSortDirection); - procedure DrawDropMark(); - end; - - TVirtualTreeColumns = class; - - TVirtualTreeColumn = class(TCollectionItem) - private - const - cDefaultColumnSpacing = 3; - private - FText, - FHint : string; - FWidth : TDimension; - FPosition : TColumnPosition; - FMinWidth : TDimension; - FMaxWidth : TDimension; - FStyle : TVirtualTreeColumnStyle; - FImageIndex : TImageIndex; - FBiDiMode : TBiDiMode; - FLayout : TVTHeaderColumnLayout; - FMargin, - FSpacing : TDimension; - FOptions : TVTColumnOptions; - FEditOptions : TVTEditOptions; - FEditNextColumn : TDimension; - FTag : NativeInt; - FAlignment : TAlignment; - FCaptionAlignment : TAlignment; // Alignment of the caption. - FLastWidth : TDimension; - FColor : TColor; - FBonusPixel : Boolean; - FSpringRest : Single; // Accumulator for width adjustment when auto spring option is enabled. - FCaptionText : string; - FCheckBox : Boolean; - FCheckType : TCheckType; - FCheckState : TCheckState; - FImageRect : TRect; - FHasImage : Boolean; - FDefaultSortDirection : TSortDirection; - function GetCaptionAlignment : TAlignment; - function GetCaptionWidth : TDimension; - function GetLeft : TDimension; - function IsBiDiModeStored : Boolean; - function IsCaptionAlignmentStored : Boolean; - function IsColorStored : Boolean; - procedure SetAlignment(const Value : TAlignment); - procedure SetBiDiMode(Value : TBiDiMode); - procedure SetCaptionAlignment(const Value : TAlignment); - procedure SetCheckBox(Value : Boolean); - procedure SetCheckState(Value : TCheckState); - procedure SetCheckType(Value : TCheckType); - procedure SetColor(const Value : TColor); - procedure SetImageIndex(Value : TImageIndex); - procedure SetLayout(Value : TVTHeaderColumnLayout); - procedure SetMargin(Value : TDimension); - procedure SetMaxWidth(Value : TDimension); - procedure SetMinWidth(Value : TDimension); - procedure SetOptions(Value : TVTColumnOptions); - procedure SetPosition(Value : TColumnPosition); - procedure SetSpacing(Value : TDimension); - procedure SetStyle(Value : TVirtualTreeColumnStyle); - - protected - FLeft : TDimension; - procedure ChangeScale(M, D : TDimension; isDpiChange : Boolean); virtual; - procedure ComputeHeaderLayout(var PaintInfo : THeaderPaintInfo; DrawFormat : Cardinal; CalculateTextRect : Boolean = False); - procedure DefineProperties(Filer : TFiler); override; - procedure GetAbsoluteBounds(var Left, Right : TDimension); - function GetDisplayName : string; override; - function GetText : string; virtual; // [IPK] - procedure SetText(const Value : string); virtual; // [IPK] private to protected & virtual - function GetOwner : TVirtualTreeColumns; reintroduce; - procedure InternalSetWidth(const Value : TDimension); //bypass side effects in SetWidth - procedure ReadHint(Reader : TReader); - procedure ReadText(Reader : TReader); - procedure SetCollection(Value : TCollection); override; - procedure SetWidth(Value : TDimension); - public - constructor Create(Collection : TCollection); override; - destructor Destroy; override; - - procedure Assign(Source : TPersistent); override; - function Equals(OtherColumnObj : TObject) : Boolean; override; - function GetRect : TRect; virtual; - property HasImage : Boolean read FHasImage; - property ImageRect : TRect read FImageRect; - procedure LoadFromStream(const Stream : TStream; Version : Integer); - procedure ParentBiDiModeChanged; - procedure ParentColorChanged; - procedure RestoreLastWidth; - function GetEffectiveColor() : TColor; - procedure SaveToStream(const Stream : TStream); - function UseRightToLeftReading : Boolean; - - property BonusPixel : Boolean read FBonusPixel write FBonusPixel; - property CaptionText : string read FCaptionText; - property LastWidth : TDimension read FLastWidth; - property Left : TDimension read GetLeft; - property Owner : TVirtualTreeColumns read GetOwner; - property SpringRest : Single read FSpringRest write FSpringRest; - published - property Alignment : TAlignment read FAlignment write SetAlignment default taLeftJustify; - property BiDiMode : TBiDiMode read FBiDiMode write SetBiDiMode stored IsBiDiModeStored; - property CaptionAlignment : TAlignment read GetCaptionAlignment write SetCaptionAlignment - stored IsCaptionAlignmentStored default taLeftJustify; - property CaptionWidth : TDimension read GetCaptionWidth; - property CheckType : TCheckType read FCheckType write SetCheckType default ctCheckBox; - property CheckState : TCheckState read FCheckState write SetCheckState default csUncheckedNormal; - property CheckBox : Boolean read FCheckBox write SetCheckBox default False; - property Color : TColor read FColor write SetColor stored IsColorStored; - property DefaultSortDirection : TSortDirection read FDefaultSortDirection write FDefaultSortDirection default sdAscending; - property Hint : string read FHint write FHint; - property ImageIndex : TImageIndex read FImageIndex write SetImageIndex default - 1; - property Layout : TVTHeaderColumnLayout read FLayout write SetLayout default blGlyphLeft; - property Margin : TDimension read FMargin write SetMargin default 4; - property MaxWidth : TDimension read FMaxWidth write SetMaxWidth default 10000; - property MinWidth : TDimension read FMinWidth write SetMinWidth default 10; - property Options : TVTColumnOptions read FOptions write SetOptions default DefaultColumnOptions; - property EditOptions : TVTEditOptions read FEditOptions write FEditOptions default toDefaultEdit; - property EditNextColumn : TDimension read FEditNextColumn write FEditNextColumn default - 1; - property Position : TColumnPosition read FPosition write SetPosition; - property Spacing : TDimension read FSpacing write SetSpacing default cDefaultColumnSpacing; - property Style : TVirtualTreeColumnStyle read FStyle write SetStyle default vsText; - property Tag : NativeInt read FTag write FTag default 0; - property Text : string read GetText write SetText; - property Width : TDimension read FWidth write SetWidth default 50; - end; - - TVirtualTreeColumnClass = class of TVirtualTreeColumn; - - TColumnsArray = array of TVirtualTreeColumn; - TCardinalArray = array of Cardinal; - TIndexArray = array of TColumnIndex; - - TVirtualTreeColumns = class(TCollection) - private - FHeader : TVTHeader; - FHeaderBitmap : TBitmap; // backbuffer for drawing - FHoverIndex, // currently "hot" column - FDownIndex, // Column on which a mouse button is held down. - FTrackIndex : TColumnIndex; // Index of column which is currently being resized. - FClickIndex : TColumnIndex; // Index of the last clicked column. - FCheckBoxHit : Boolean; // True if the last click was on a header checkbox. - FPositionToIndex : TIndexArray; - FDefaultWidth : TDimension; // the width columns are created with - FNeedPositionsFix : Boolean; // True if FixPositions must still be called after DFM loading or Bidi mode change. - FClearing : Boolean; // True if columns are being deleted entirely. - FColumnPopupMenu : TPopupMenu; // Member for storing the TVTHeaderPopupMenu - - function GetCount : TDimension; - function GetItem(Index : TColumnIndex) : TVirtualTreeColumn; - function GetNewIndex(P : TPoint; var OldIndex : TColumnIndex) : Boolean; - procedure SetDefaultWidth(Value : TDimension); - procedure SetItem(Index : TColumnIndex; Value : TVirtualTreeColumn); - function GetTreeView: TCustomControl; - protected - // drag support - FDragIndex : TColumnIndex; // index of column currently being dragged - FDropTarget : TColumnIndex; // current target column (index) while dragging - FDropBefore : Boolean; // True if drop position is in the left half of a column, False for the right - // side to drop the dragged column to - - procedure AdjustAutoSize(CurrentIndex : TColumnIndex; Force : Boolean = False); - function AdjustDownColumn(P : TPoint) : TColumnIndex; - function AdjustHoverColumn(P : TPoint) : Boolean; - procedure AdjustPosition(Column : TVirtualTreeColumn; Position : Cardinal); - function CanSplitterResize(P : TPoint; Column : TColumnIndex) : Boolean; - procedure DoCanSplitterResize(P : TPoint; Column : TColumnIndex; var Allowed : Boolean); virtual; - procedure DrawButtonText(DC : HDC; Caption : string; Bounds : TRect; Enabled, Hot : Boolean; DrawFormat : Cardinal; - WrapCaption : Boolean); - procedure FixPositions; - function GetColumnAndBounds(P : TPoint; var ColumnLeft, ColumnRight : TDimension; Relative : Boolean = True) : Integer; - function GetOwner : TPersistent; override; - function HandleClick(P : TPoint; Button : TMouseButton; Force, DblClick : Boolean) : Boolean; virtual; - procedure HeaderPopupMenuAddHeaderPopupItem(const Sender : TObject; const Column : TColumnIndex; var Cmd : TAddPopupItemType); - procedure IndexChanged(OldIndex, NewIndex : Integer); - procedure InitializePositionArray; - procedure Notify(Item : TCollectionItem; Action : System.Classes.TCollectionNotification); override; - procedure ReorderColumns(RTL : Boolean); - procedure SetHoverIndex(Index : TColumnIndex); - procedure Update(Item : TCollectionItem); override; - procedure UpdatePositions(Force : Boolean = False); - - property HeaderBitmap : TBitmap read FHeaderBitmap; - property PositionToIndex : TIndexArray read FPositionToIndex; - property HoverIndex : TColumnIndex read FHoverIndex write FHoverIndex; - property DownIndex : TColumnIndex read FDownIndex write FDownIndex; - property CheckBoxHit : Boolean read FCheckBoxHit write FCheckBoxHit; - // 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(AControl : TControl = nil) : TCustomStyleServices; - public - constructor Create(AOwner : TVTHeader); virtual; - destructor Destroy; override; - - function Add : TVirtualTreeColumn; virtual; - procedure AnimatedResize(Column : TColumnIndex; NewWidth : TDimension); - procedure Assign(Source : TPersistent); override; - procedure Clear; virtual; - function ColumnFromPosition(P : TPoint; Relative : Boolean = True) : TColumnIndex; overload; virtual; - function ColumnFromPosition(PositionIndex : TColumnPosition) : TColumnIndex; overload; virtual; - function Equals(OtherColumnsObj : TObject) : Boolean; override; - procedure GetColumnBounds(Column : TColumnIndex; var Left, Right : TDimension); - function GetFirstVisibleColumn(ConsiderAllowFocus : Boolean = False) : TColumnIndex; - function GetLastVisibleColumn(ConsiderAllowFocus : Boolean = False) : TColumnIndex; - function GetFirstColumn : TColumnIndex; - function GetNextColumn(Column : TColumnIndex) : TColumnIndex; - function GetNextVisibleColumn(Column : TColumnIndex; ConsiderAllowFocus : Boolean = False) : TColumnIndex; - function GetPreviousColumn(Column : TColumnIndex) : TColumnIndex; - function GetPreviousVisibleColumn(Column : TColumnIndex; ConsiderAllowFocus : Boolean = False) : TColumnIndex; - function GetScrollWidth : TDimension; - function GetVisibleColumns : TColumnsArray; - function GetVisibleFixedWidth : TDimension; - function IsValidColumn(Column : TColumnIndex) : Boolean; - procedure LoadFromStream(const Stream : TStream; Version : Integer); - procedure PaintHeader(DC : HDC; R : TRect; HOffset : TDimension); overload; virtual; - procedure PaintHeader(TargetCanvas : TCanvas; R : TRect; const Target : TPoint; - RTLOffset : TDimension = 0); overload; virtual; - procedure SaveToStream(const Stream : TStream); - procedure EndUpdate(); override; - function TotalWidth : TDimension; - - property Count : Integer read GetCount; - property ClickIndex : TColumnIndex read FClickIndex write FClickIndex; - property DefaultWidth : TDimension read FDefaultWidth write SetDefaultWidth; - property DragIndex : TColumnIndex read FDragIndex write FDragIndex; - property DropBefore : Boolean read FDropBefore write FDropBefore; - property DropTarget : TColumnIndex read FDropTarget write FDropTarget; - property Items[Index : TColumnIndex] : TVirtualTreeColumn read GetItem write SetItem; default; - property Header: TVTHeader read FHeader; - property TrackIndex : TColumnIndex read FTrackIndex write FTrackIndex; - property TreeView : TCustomControl read GetTreeView; - end; - - TVirtualTreeColumnsClass = class of TVirtualTreeColumns; - - TVTConstraintPercent = 0 .. 100; - - TVTFixedAreaConstraints = class(TPersistent) - private - FHeader : TVTHeader; - FMaxHeightPercent, FMaxWidthPercent, FMinHeightPercent, FMinWidthPercent : TVTConstraintPercent; - FOnChange : TNotifyEvent; - procedure SetConstraints(Index : Integer; Value : TVTConstraintPercent); - protected - procedure Change; - property Header : TVTHeader read FHeader; - public - constructor Create(AOwner : TVTHeader); - - procedure Assign(Source : TPersistent); override; - property OnChange : TNotifyEvent read FOnChange write FOnChange; - published - property MaxHeightPercent : TVTConstraintPercent index 0 read FMaxHeightPercent write SetConstraints default 0; - property MaxWidthPercent : TVTConstraintPercent index 1 read FMaxWidthPercent write SetConstraints default 95; - property MinHeightPercent : TVTConstraintPercent index 2 read FMinHeightPercent write SetConstraints default 0; - property MinWidthPercent : TVTConstraintPercent index 3 read FMinWidthPercent write SetConstraints default 0; - end; - - TVTHeaderStyle = (hsThickButtons, //TButton look and feel - hsFlatButtons, //flatter look than hsThickButton, like an always raised flat TToolButton - hsPlates //flat TToolButton look and feel (raise on hover etc.) - ); - - TVTHeaderOption = (hoAutoResize, //Adjust a column so that the header never exceeds the client width of the owner control. - hoColumnResize, //Resizing columns with the mouse is allowed. - hoDblClickResize, //Allows a column to resize itself to its largest entry. - hoDrag, //Dragging columns is allowed. - hoHotTrack, //Header captions are highlighted when mouse is over a particular column. - hoOwnerDraw, //Header items with the owner draw style can be drawn by the application via event. - hoRestrictDrag, //Header can only be dragged horizontally. - hoShowHint, //Show application defined header hint. - hoShowImages, //Show header images. - hoShowSortGlyphs, //Allow visible sort glyphs. - hoVisible, //Header is visible. - hoAutoSpring, //Distribute size changes of the header to all columns, which are sizable and have the coAutoSpring option enabled. - hoFullRepaintOnResize, //Fully invalidate the header (instead of subsequent columns only) when a column is resized. - hoDisableAnimatedResize, //Disable animated resize for all columns. - hoHeightResize, //Allow resizing header height via mouse. - hoHeightDblClickResize, //Allow the header to resize itself to its default height. - hoHeaderClickAutoSort, //Clicks on the header will make the clicked column the SortColumn or toggle sort direction if it already was the sort column - hoAutoColumnPopupMenu, //Show a context menu for activating and deactivating columns on right click - hoAutoResizeInclCaption //Includes the header caption for the auto resizing - ); - TVTHeaderOptions = set of TVTHeaderOption; - - THeaderState = (hsAutoSizing, //auto size chain is in progess, do not trigger again on WM_SIZE - hsDragging, //header dragging is in progress (only if enabled) - hsDragPending, //left button is down, user might want to start dragging a column - hsLoading, //The header currently loads from stream, so updates are not necessary. - hsColumnWidthTracking, //column resizing is in progress - hsColumnWidthTrackPending, //left button is down, user might want to start resize a column - hsHeightTracking, //height resizing is in progress - hsHeightTrackPending, //left button is down, user might want to start changing height - hsResizing, //multi column resizing in progress - hsScaling, //the header is scaled after a change of FixedAreaConstraints or client size - hsNeedScaling //the header needs to be scaled - ); - THeaderStates = set of THeaderState; - - TVTHeader = class(TPersistent) - private - FOwner : TCustomControl; - FColumns : TVirtualTreeColumns; - FHeight : TDimension; - FFont : TFont; - FParentFont : Boolean; - FOptions : TVTHeaderOptions; - FStyle : TVTHeaderStyle; //button style - FBackgroundColor : TColor; - FAutoSizeIndex : TColumnIndex; - FPopupMenu : TPopupMenu; - FMainColumn : TColumnIndex; //the column which holds the tree - FMaxHeight : TDimension; - FMinHeight : TDimension; - FDefaultHeight : TDimension; - FFixedAreaConstraints : TVTFixedAreaConstraints; //Percentages for the fixed area (header, fixed columns). - FImages : TCustomImageList; - FImageChangeLink : TChangeLink; //connections to the image list to get notified about changes - fSplitterHitTolerance : TDimension; //For property SplitterHitTolerance - FSortColumn : TColumnIndex; - FSortDirection : TSortDirection; - FDragImage : TVTDragImage; //drag image management during header drag - FLastWidth : TDimension; //Used to adjust spring columns. This is the width of all visible columns, not the header rectangle. - FRestoreSelectionColumnIndex : Integer; //The column that is used to implement the coRestoreSelection option - function GetMainColumn : TColumnIndex; - function GetUseColumns : Boolean; - function IsFontStored : Boolean; - procedure SetAutoSizeIndex(Value : TColumnIndex); - procedure SetBackground(Value : TColor); - procedure SetColumns(Value : TVirtualTreeColumns); - procedure SetDefaultHeight(Value : TDimension); - procedure SetFont(const Value : TFont); - procedure SetHeight(Value : TDimension); - procedure SetImages(const Value : TCustomImageList); - procedure SetMainColumn(Value : TColumnIndex); - procedure SetMaxHeight(Value : TDimension); - procedure SetMinHeight(Value : TDimension); - procedure SetOptions(Value : TVTHeaderOptions); - procedure SetParentFont(Value : Boolean); - procedure SetSortColumn(Value : TColumnIndex); - procedure SetSortDirection(const Value : TSortDirection); - procedure SetStyle(Value : TVTHeaderStyle); - function GetRestoreSelectionColumnIndex : Integer; - protected - FStates : THeaderStates; //Used to keep track of internal states the header can enter. - FDragStart : TPoint; //initial mouse drag position - FTrackStart : TPoint; //client coordinates of the tracking start point - FTrackPoint : TPoint; //Client coordinate where the tracking started. - FDoingAutoFitColumns : Boolean; //Flag to avoid using the stored width for Main column - - procedure FontChanged(Sender : TObject); virtual; - procedure AutoScale(isDpiChange: Boolean); virtual; - function CanSplitterResize(P : TPoint) : Boolean; - function CanWriteColumns : Boolean; virtual; - procedure ChangeScale(M, D : TDimension; isDpiChange : Boolean); virtual; - function DetermineSplitterIndex(P : TPoint) : Boolean; virtual; - procedure DoAfterAutoFitColumn(Column : TColumnIndex); virtual; - procedure DoAfterColumnWidthTracking(Column : TColumnIndex); virtual; - procedure DoAfterHeightTracking; virtual; - function DoBeforeAutoFitColumn(Column : TColumnIndex; SmartAutoFitType : TSmartAutoFitType) : Boolean; virtual; - procedure DoBeforeColumnWidthTracking(Column : TColumnIndex; Shift : TShiftState); virtual; - procedure DoBeforeHeightTracking(Shift : TShiftState); virtual; - procedure DoCanSplitterResize(P : TPoint; var Allowed : Boolean); virtual; - function DoColumnWidthDblClickResize(Column : TColumnIndex; P : TPoint; Shift : TShiftState) : Boolean; virtual; - function DoColumnWidthTracking(Column : TColumnIndex; Shift : TShiftState; var TrackPoint : TPoint; P : TPoint) : Boolean; virtual; - function DoGetPopupMenu(Column : TColumnIndex; Position : TPoint) : TPopupMenu; virtual; - function DoHeightTracking(var P : TPoint; Shift : TShiftState) : Boolean; virtual; - function DoHeightDblClickResize(var P : TPoint; Shift : TShiftState) : Boolean; virtual; - procedure DoSetSortColumn(Value : TColumnIndex; pSortDirection : TSortDirection); virtual; - procedure DragTo(P : TPoint); virtual; - procedure FixedAreaConstraintsChanged(Sender : TObject); - function GetColumnsClass : TVirtualTreeColumnsClass; virtual; - function GetOwner : TPersistent; override; - function GetShiftState : TShiftState; - function HandleHeaderMouseMove(var Message : TWMMouseMove) : Boolean; - function HandleMessage(var Message : TMessage) : Boolean; virtual; - procedure ImageListChange(Sender : TObject); - procedure PrepareDrag(P, Start : TPoint); - procedure ReadColumns(Reader : TReader); - procedure RecalculateHeader; virtual; - procedure RescaleHeader; - procedure UpdateMainColumn; - procedure UpdateSpringColumns; - procedure WriteColumns(Writer : TWriter); - procedure InternalSetMainColumn(const Index : TColumnIndex); - procedure InternalSetAutoSizeIndex(const Index : TColumnIndex); - procedure InternalSetSortColumn(const Index : TColumnIndex); - public - constructor Create(AOwner : TCustomControl); virtual; - destructor Destroy; override; - - function AllowFocus(ColumnIndex : TColumnIndex) : Boolean; - procedure Assign(Source : TPersistent); override; - procedure AutoFitColumns(); overload; - procedure AutoFitColumns(Animated : Boolean; SmartAutoFitType : TSmartAutoFitType = smaUseColumnOption; RangeStartCol : Integer = NoColumn; RangeEndCol : Integer = NoColumn); overload; virtual; - function InHeader(P : TPoint) : Boolean; virtual; - function InHeaderSplitterArea(P : TPoint) : Boolean; virtual; - procedure Invalidate(Column : TVirtualTreeColumn; ExpandToBorder : Boolean = False; UpdateNowFlag : Boolean = False); - procedure LoadFromStream(const Stream : TStream); virtual; - function ResizeColumns(ChangeBy : TDimension; RangeStartCol : TColumnIndex; RangeEndCol : TColumnIndex; Options : TVTColumnOptions = [coVisible]) : TDimension; - procedure RestoreColumns; - procedure SaveToStream(const Stream : TStream); virtual; - procedure StyleChanged(); virtual; - - property DragImage : TVTDragImage read FDragImage; - property RestoreSelectionColumnIndex : Integer read GetRestoreSelectionColumnIndex write FRestoreSelectionColumnIndex default NoColumn; - property States : THeaderStates read FStates; - property Treeview : TCustomControl read FOwner; - property UseColumns : Boolean read GetUseColumns; - property doingAutoFitColumns : Boolean read FDoingAutoFitColumns; - published - property AutoSizeIndex : TColumnIndex read FAutoSizeIndex write SetAutoSizeIndex; - property Background : TColor read FBackgroundColor write SetBackground default clBtnFace; - property Columns : TVirtualTreeColumns read FColumns write SetColumns stored False; //Stored by the owner tree to support VFI. - property DefaultHeight : Integer read FDefaultHeight write SetDefaultHeight default 19; - property Font : TFont read FFont write SetFont stored IsFontStored; - property FixedAreaConstraints : TVTFixedAreaConstraints read FFixedAreaConstraints write FFixedAreaConstraints; - property Height : Integer read FHeight write SetHeight default 19; - property Images : TCustomImageList read FImages write SetImages; - property MainColumn : TColumnIndex read GetMainColumn write SetMainColumn default 0; - property MaxHeight : Integer read FMaxHeight write SetMaxHeight default 10000; - property MinHeight : Integer read FMinHeight write SetMinHeight default 10; - property Options : TVTHeaderOptions read FOptions write SetOptions default [hoColumnResize, hoDrag, hoShowSortGlyphs]; - property ParentFont : Boolean read FParentFont write SetParentFont default True; - property PopupMenu : TPopupMenu read FPopupMenu write FPopupMenu; - property SortColumn : TColumnIndex read FSortColumn write SetSortColumn default NoColumn; - property SortDirection : TSortDirection read FSortDirection write SetSortDirection default sdAscending; - property SplitterHitTolerance : Integer read fSplitterHitTolerance write fSplitterHitTolerance default 8; - //The area in pixels around a spliter which is sensitive for resizing - property Style : TVTHeaderStyle read FStyle write SetStyle default hsThickButtons; - end; - - TVTHeaderClass = class of TVTHeader; - -implementation - -uses - WinApi.ShlObj, - WinApi.UxTheme, - System.Math, - System.SysUtils, - Vcl.Forms, - VirtualTrees, - VirtualTrees.HeaderPopup; - -type - TVirtualTreeColumnsCracker = class(TVirtualTreeColumns); - TVirtualTreeColumnCracker = class(TVirtualTreeColumn); - TBaseVirtualTreeCracker = class(TBaseVirtualTree); - - TVTHeaderHelper = class helper for TVTHeader - public - function Tree : TBaseVirtualTreeCracker; - end; - - TVirtualTreeColumnHelper = class helper for TVirtualTreeColumn - function TreeViewControl : TBaseVirtualTreeCracker; - function Header : TVTHeader; - end; - - TVirtualTreeColumnsHelper = class helper for TVirtualTreeColumns - function TreeViewControl : TBaseVirtualTreeCracker; - end; - - - - //----------------- TVTFixedAreaConstraints ---------------------------------------------------------------------------- - -constructor TVTFixedAreaConstraints.Create(AOwner : TVTHeader); - -begin - inherited Create; - FMaxWidthPercent := 95; - FHeader := AOwner; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTFixedAreaConstraints.SetConstraints(Index : Integer; Value : TVTConstraintPercent); - -begin - case Index of - 0 : - if Value <> FMaxHeightPercent then - begin - FMaxHeightPercent := Value; - if (Value > 0) and (Value < FMinHeightPercent) then - FMinHeightPercent := Value; - Change; - end; - 1 : - if Value <> FMaxWidthPercent then - begin - FMaxWidthPercent := Value; - if (Value > 0) and (Value < FMinWidthPercent) then - FMinWidthPercent := Value; - Change; - end; - 2 : - if Value <> FMinHeightPercent then - begin - FMinHeightPercent := Value; - if (FMaxHeightPercent > 0) and (Value > FMaxHeightPercent) then - FMaxHeightPercent := Value; - Change; - end; - 3 : - if Value <> FMinWidthPercent then - begin - FMinWidthPercent := Value; - if (FMaxWidthPercent > 0) and (Value > FMaxWidthPercent) then - FMaxWidthPercent := Value; - Change; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTFixedAreaConstraints.Change; - -begin - if Assigned(FOnChange) then - FOnChange(Self); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTFixedAreaConstraints.Assign(Source : TPersistent); - -begin - if Source is TVTFixedAreaConstraints then - begin - FMaxHeightPercent := TVTFixedAreaConstraints(Source).FMaxHeightPercent; - FMaxWidthPercent := TVTFixedAreaConstraints(Source).FMaxWidthPercent; - FMinHeightPercent := TVTFixedAreaConstraints(Source).FMinHeightPercent; - FMinWidthPercent := TVTFixedAreaConstraints(Source).FMinWidthPercent; - Change; - end - else - inherited; -end; - -//----------------- TVTHeader ----------------------------------------------------------------------------------------- - -constructor TVTHeader.Create(AOwner : TCustomControl); - -begin - inherited Create; - FOwner := AOwner; - FColumns := GetColumnsClass.Create(Self); - FHeight := 19; - FDefaultHeight := FHeight; - FMinHeight := 10; - FMaxHeight := 10000; - FFont := TFont.Create; - FFont.OnChange := FontChanged; - FParentFont := True; - FBackgroundColor := clBtnFace; - FOptions := [hoColumnResize, hoDrag, hoShowSortGlyphs]; - - FImageChangeLink := TChangeLink.Create; - FImageChangeLink.OnChange := ImageListChange; - - FSortColumn := NoColumn; - FSortDirection := sdAscending; - FMainColumn := NoColumn; - - FDragImage := TVTDragImage.Create(AOwner); - with FDragImage do - begin - Fade := False; - PreBlendBias := - 50; - Transparency := 140; - end; - - fSplitterHitTolerance := 8; - FFixedAreaConstraints := TVTFixedAreaConstraints.Create(Self); - FFixedAreaConstraints.OnChange := FixedAreaConstraintsChanged; - - FDoingAutoFitColumns := False; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -destructor TVTHeader.Destroy; - -begin - FDragImage.Free; - FFixedAreaConstraints.Free; - FImageChangeLink.Free; - FFont.Free; - FColumns.Clear; //TCollection's Clear method is not virtual, so we have to call our own Clear method manually. - FColumns.Free; - inherited; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTHeader.FontChanged(Sender : TObject); -begin - inherited; - {$IF CompilerVersion < 31} - AutoScale(false); - {$IFEND} -end; - -procedure TVTHeader.AutoScale(isDpiChange: Boolean); -var - I : Integer; - lMaxHeight : Integer; -begin - if (toAutoChangeScale in TBaseVirtualTreeCracker(Tree).TreeOptions.AutoOptions) and not isDpiChange then - begin - //Ensure a minimum header size based on the font, so that all text is visible. - //First find the largest Columns[].Spacing - lMaxHeight := 0; - for I := 0 to Self.Columns.Count - 1 do - lMaxHeight := Max(lMaxHeight, Columns[I].Spacing); - //Calculate the required height based on the font, this is important as the user might just have increased the size of the system icon font. - with TBitmap.Create do - try - Canvas.Font.Assign(FFont); - lMaxHeight := lMaxHeight { top spacing } + (lMaxHeight div 2) { minimum bottom spacing } + Canvas.TextHeight('Q'); - finally - Free; - end; - //Get the maximum of the scaled original value and the minimum needed header height. - lMaxHeight := Max(lMaxHeight, FHeight); - //Set the calculated size - Self.SetHeight(lMaxHeight); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTHeader.GetMainColumn : TColumnIndex; -begin - if FColumns.Count > 0 then - Result := FMainColumn - else - Result := NoColumn; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTHeader.GetUseColumns : Boolean; -begin - Result := FColumns.Count > 0; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTHeader.IsFontStored : Boolean; -begin - Result := not ParentFont; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTHeader.SetAutoSizeIndex(Value : TColumnIndex); -begin - if FAutoSizeIndex <> Value then - begin - FAutoSizeIndex := Value; - if hoAutoResize in FOptions then - TVirtualTreeColumnsCracker(Columns).AdjustAutoSize(InvalidColumn); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTHeader.SetBackground(Value : TColor); -begin - if FBackgroundColor <> Value then - begin - FBackgroundColor := Value; - Invalidate(nil); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTHeader.SetColumns(Value : TVirtualTreeColumns); - -begin - FColumns.Assign(Value); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTHeader.SetDefaultHeight(Value : Integer); -begin - if Value < FMinHeight then - Value := FMinHeight; - if Value > FMaxHeight then - Value := FMaxHeight; - - if FHeight = FDefaultHeight then - SetHeight(Value); - FDefaultHeight := Value; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTHeader.SetFont(const Value : TFont); -begin - FFont.Assign(Value); - FParentFont := False; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTHeader.SetHeight(Value : Integer); -var - RelativeMaxHeight, RelativeMinHeight, EffectiveMaxHeight, EffectiveMinHeight : Integer; -begin - if not Tree.HandleAllocated then - begin - FHeight := Value; - Include(FStates, hsNeedScaling); - end - else - begin - with FFixedAreaConstraints do - begin - RelativeMaxHeight := ((Tree.ClientHeight + FHeight) * FMaxHeightPercent) div 100; - RelativeMinHeight := ((Tree.ClientHeight + FHeight) * FMinHeightPercent) div 100; - - EffectiveMinHeight := IfThen(FMaxHeightPercent > 0, Min(RelativeMaxHeight, FMinHeight), FMinHeight); - EffectiveMaxHeight := IfThen(FMinHeightPercent > 0, Max(RelativeMinHeight, FMaxHeight), FMaxHeight); - - Value := Min(Max(Value, EffectiveMinHeight), EffectiveMaxHeight); - if FMinHeightPercent > 0 then - Value := Max(RelativeMinHeight, Value); - if FMaxHeightPercent > 0 then - Value := Min(RelativeMaxHeight, Value); - end; - - if FHeight <> Value then - begin - FHeight := Value; - if not (csLoading in Tree.ComponentState) and not (hsScaling in FStates) then - RecalculateHeader; - Tree.Invalidate; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTHeader.SetImages(const Value : TCustomImageList); - -begin - if FImages <> Value then - begin - if Assigned(FImages) then - begin - FImages.UnRegisterChanges(FImageChangeLink); - FImages.RemoveFreeNotification(FOwner); - end; - FImages := Value; - if Assigned(FImages) then - begin - FImages.RegisterChanges(FImageChangeLink); - FImages.FreeNotification(FOwner); - end; - if not (csLoading in Tree.ComponentState) then - Invalidate(nil); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTHeader.SetMainColumn(Value : TColumnIndex); - -begin - if (csLoading in Tree.ComponentState) or (csDestroying in Tree.ComponentState) then - FMainColumn := Value - else - begin - if Value < 0 then - Value := 0; - if Value > FColumns.Count - 1 then - Value := FColumns.Count - 1; - if Value <> FMainColumn then - begin - FMainColumn := Value; - Tree.MainColumnChanged; - if not (toExtendedFocus in Tree.TreeOptions.SelectionOptions) then - Tree.FocusedColumn := FMainColumn; - Tree.Invalidate; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTHeader.SetMaxHeight(Value : Integer); - -begin - if Value < FMinHeight then - Value := FMinHeight; - FMaxHeight := Value; - SetHeight(FHeight); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTHeader.SetMinHeight(Value : Integer); - -begin - if Value < 0 then - Value := 0; - if Value > FMaxHeight then - Value := FMaxHeight; - FMinHeight := Value; - SetHeight(FHeight); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTHeader.SetOptions(Value : TVTHeaderOptions); - -var - ToBeSet, ToBeCleared : TVTHeaderOptions; - -begin - ToBeSet := Value - FOptions; - ToBeCleared := FOptions - Value; - FOptions := Value; - - if (hoAutoResize in (ToBeSet + ToBeCleared)) and (FColumns.Count > 0) then - begin - TVirtualTreeColumnsCracker(FColumns).AdjustAutoSize(InvalidColumn); - if Tree.HandleAllocated then - begin - Tree.UpdateHorizontalScrollBar(False); - if hoAutoResize in ToBeSet then - Tree.Invalidate; - end; - end; - - if not (csLoading in Tree.ComponentState) and Tree.HandleAllocated then - begin - if hoVisible in (ToBeSet + ToBeCleared) then - RecalculateHeader; - Invalidate(nil); - Tree.Invalidate; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTHeader.SetParentFont(Value : Boolean); - -begin - if FParentFont <> Value then - begin - FParentFont := Value; - if FParentFont then - FFont.Assign(TBaseVirtualTree(FOwner).Font); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTHeader.SetSortColumn(Value : TColumnIndex); - -begin - if csLoading in Tree.ComponentState then - FSortColumn := Value - else - DoSetSortColumn(Value, FSortDirection); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTHeader.SetSortDirection(const Value : TSortDirection); - -begin - if Value <> FSortDirection then - begin - FSortDirection := Value; - Invalidate(nil); - if ((toAutoSort in Tree.TreeOptions.AutoOptions) or (hoHeaderClickAutoSort in Options)) and (Tree.UpdateCount = 0) then - Tree.SortTree(FSortColumn, FSortDirection, True); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTHeader.CanSplitterResize(P : TPoint) : Boolean; - -begin - Result := hoHeightResize in FOptions; - DoCanSplitterResize(P, Result); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTHeader.SetStyle(Value : TVTHeaderStyle); - -begin - if FStyle <> Value then - begin - FStyle := Value; - if not (csLoading in Tree.ComponentState) then - Invalidate(nil); - end; -end; - -procedure TVTHeader.StyleChanged(); -begin - {$IF CompilerVersion < 31} - AutoScale(False); //Elements may have changed in size - {$IFEND} -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTHeader.CanWriteColumns : Boolean; - -//descendants may override this to optionally prevent column writing (e.g. if they are build dynamically). - -begin - Result := True; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTHeader.ChangeScale(M, D : Integer; isDpiChange : Boolean); -var - I : Integer; -begin - //This method is only executed if toAutoChangeScale is set - FMinHeight := MulDiv(FMinHeight, M, D); - FMaxHeight := MulDiv(FMaxHeight, M, D); - Self.Height := MulDiv(FHeight, M, D); - if not ParentFont then - Font.Height := MulDiv(Font.Height, M, D); - //Scale the columns widths too - for I := 0 to FColumns.Count - 1 do - TVirtualTreeColumnCracker(Self.FColumns[I]).ChangeScale(M, D, isDpiChange); - if not isDpiChange then - AutoScale(isDpiChange); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTHeader.DetermineSplitterIndex(P : TPoint) : Boolean; - -//Tries to find the index of that column whose right border corresponds to P. -//Result is True if column border was hit (with -3..+5 pixels tolerance). -//For continuous resizing the current track index and the column's left/right border are set. -//Note: The hit test is checking from right to left (or left to right in RTL mode) to make enlarging of zero-sized -//columns possible. - -var - VisibleFixedWidth : Integer; - SplitPoint : Integer; - - //--------------- local function -------------------------------------------- - - function IsNearBy(IsFixedCol : Boolean; LeftTolerance, RightTolerance : Integer) : Boolean; - - begin - if IsFixedCol then - Result := (P.X < SplitPoint + Tree.EffectiveOffsetX + RightTolerance) and (P.X > SplitPoint + Tree.EffectiveOffsetX - LeftTolerance) - else - Result := (P.X > VisibleFixedWidth) and (P.X < SplitPoint + RightTolerance) and (P.X > SplitPoint - LeftTolerance); - end; - -//--------------- end local function ---------------------------------------- - -var - I : Integer; - LeftTolerance : Integer; //The area left of the column divider which allows column resizing -begin - Result := False; - - if FColumns.Count > 0 then - begin - FColumns.TrackIndex := NoColumn; - VisibleFixedWidth := FColumns.GetVisibleFixedWidth; - LeftTolerance := Round(SplitterHitTolerance * 0.6); - if Tree.UseRightToLeftAlignment then - begin - SplitPoint := - Tree.EffectiveOffsetX; - if FColumns.TotalWidth < Tree.ClientWidth then - Inc(SplitPoint, Tree.ClientWidth - FColumns.TotalWidth); - - for I := 0 to FColumns.Count - 1 do - with TVirtualTreeColumnsCracker(FColumns), Items[PositionToIndex[I]] do - if coVisible in Options then - begin - if IsNearBy(coFixed in Options, LeftTolerance, SplitterHitTolerance - LeftTolerance) then - begin - if CanSplitterResize(P, PositionToIndex[I]) then - begin - Result := True; - TrackIndex := PositionToIndex[I]; - - //Keep the right border of this column. This and the current mouse position - //directly determine the current column width. - FTrackPoint.X := SplitPoint + IfThen(coFixed in Options, Tree.EffectiveOffsetX) + Width; - FTrackPoint.Y := P.Y; - Break; - end; - end; - Inc(SplitPoint, Width); - end; - end - else - begin - SplitPoint := - Tree.EffectiveOffsetX + FColumns.TotalWidth; - - for I := FColumns.Count - 1 downto 0 do - with TVirtualTreeColumnsCracker(FColumns), Items[PositionToIndex[I]] do - if coVisible in Options then - begin - if IsNearBy(coFixed in Options, SplitterHitTolerance - LeftTolerance, LeftTolerance) then - begin - if CanSplitterResize(P, PositionToIndex[I]) then - begin - Result := True; - TrackIndex := PositionToIndex[I]; - - //Keep the left border of this column. This and the current mouse position - //directly determine the current column width. - FTrackPoint.X := SplitPoint + IfThen(coFixed in Options, Tree.EffectiveOffsetX) - Width; - FTrackPoint.Y := P.Y; - Break; - end; - end; - Dec(SplitPoint, Width); - end; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTHeader.DoAfterAutoFitColumn(Column : TColumnIndex); - -begin - if Assigned(Tree.OnAfterAutoFitColumn) then - Tree.OnAfterAutoFitColumn(Self, Column); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTHeader.DoAfterColumnWidthTracking(Column : TColumnIndex); - -//Tell the application that a column width tracking operation has been finished. - -begin - if Assigned(Tree.OnAfterColumnWidthTracking) then - Tree.OnAfterColumnWidthTracking(Self, Column); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTHeader.DoAfterHeightTracking; - -//Tell the application that a height tracking operation has been finished. - -begin - if Assigned(Tree.OnAfterHeaderHeightTracking) then - Tree.OnAfterHeaderHeightTracking(Self); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTHeader.DoBeforeAutoFitColumn(Column : TColumnIndex; SmartAutoFitType : TSmartAutoFitType) : Boolean; - -//Query the application if we may autofit a column. - -begin - Result := True; - if Assigned(Tree.OnBeforeAutoFitColumn) then - Tree.OnBeforeAutoFitColumn(Self, Column, SmartAutoFitType, Result); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTHeader.DoBeforeColumnWidthTracking(Column : TColumnIndex; Shift : TShiftState); - -//Tell the a application that a column width tracking operation may begin. - -begin - if Assigned(Tree.OnBeforeColumnWidthTracking) then - Tree.OnBeforeColumnWidthTracking(Self, Column, Shift); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTHeader.DoBeforeHeightTracking(Shift : TShiftState); - -//Tell the application that a height tracking operation may begin. - -begin - if Assigned(Tree.OnBeforeHeaderHeightTracking) then - Tree.OnBeforeHeaderHeightTracking(Self, Shift); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTHeader.DoCanSplitterResize(P : TPoint; var Allowed : Boolean); -begin - if Assigned(Tree.OnCanSplitterResizeHeader) then - Tree.OnCanSplitterResizeHeader(Self, P, Allowed); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTHeader.DoColumnWidthDblClickResize(Column : TColumnIndex; P : TPoint; Shift : TShiftState) : Boolean; - -//Queries the application whether a double click on the column splitter should resize the column. - -begin - Result := True; - if Assigned(Tree.OnColumnWidthDblClickResize) then - Tree.OnColumnWidthDblClickResize(Self, Column, Shift, P, Result); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTHeader.DoColumnWidthTracking(Column : TColumnIndex; Shift : TShiftState; var TrackPoint : TPoint; P : TPoint) : Boolean; - -begin - Result := True; - if Assigned(Tree.OnColumnWidthTracking) then - Tree.OnColumnWidthTracking(Self, Column, Shift, TrackPoint, P, Result); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTHeader.DoGetPopupMenu(Column : TColumnIndex; Position : TPoint) : TPopupMenu; - -//Queries the application whether there is a column specific header popup menu. - -var - AskParent : Boolean; - -begin - Result := PopupMenu; - if Assigned(Tree.OnGetPopupMenu) then - Tree.OnGetPopupMenu(TBaseVirtualTree(FOwner), nil, Column, Position, AskParent, Result); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTHeader.DoHeightTracking(var P : TPoint; Shift : TShiftState) : Boolean; - -begin - Result := True; - if Assigned(Tree.OnHeaderHeightTracking) then - Tree.OnHeaderHeightTracking(Self, P, Shift, Result); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTHeader.DoHeightDblClickResize(var P : TPoint; Shift : TShiftState) : Boolean; - -begin - Result := True; - if Assigned(Tree.OnHeaderHeightDblClickResize) then - Tree.OnHeaderHeightDblClickResize(Self, P, Shift, Result); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTHeader.DoSetSortColumn(Value : TColumnIndex; pSortDirection : TSortDirection); - -begin - if Value < NoColumn then - Value := NoColumn; - if Value > Columns.Count - 1 then - Value := Columns.Count - 1; - if FSortColumn <> Value then - begin - if FSortColumn > NoColumn then - Invalidate(Columns[FSortColumn]); - FSortColumn := Value; - FSortDirection := pSortDirection; - if FSortColumn > NoColumn then - Invalidate(Columns[FSortColumn]); - if ((toAutoSort in Tree.TreeOptions.AutoOptions) or (hoHeaderClickAutoSort in Options)) and (Tree.UpdateCount = 0) then - Tree.SortTree(FSortColumn, FSortDirection, True); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTHeader.DragTo(P : TPoint); - -//Moves the drag image to a new position, which is determined from the passed point P and the previous -//mouse position. - -var - I, NewTarget : Integer; - //optimized drag image move support - ClientP : TPoint; - Left, Right : Integer; - NeedRepaint : Boolean; //True if the screen needs an update (changed drop target or drop side) - -begin - //Determine new drop target and which side of it is prefered. - ClientP := Tree.ScreenToClient(P); - //Make coordinates relative to (0, 0) of the non-client area. - Inc(ClientP.Y, FHeight); - NewTarget := FColumns.ColumnFromPosition(ClientP); - NeedRepaint := (NewTarget <> InvalidColumn) and (NewTarget <> FColumns.DropTarget); - if NewTarget >= 0 then - begin - FColumns.GetColumnBounds(NewTarget, Left, Right); - if (ClientP.X < ((Left + Right) div 2)) <> FColumns.DropBefore then - begin - NeedRepaint := True; - FColumns.DropBefore := not FColumns.DropBefore; - end; - end; - - if NeedRepaint then - begin - //Invalidate columns which need a repaint. - if FColumns.DropTarget > NoColumn then - begin - I := FColumns.DropTarget; - FColumns.DropTarget := NoColumn; - Invalidate(FColumns.Items[I]); - end; - if (NewTarget > NoColumn) and (NewTarget <> FColumns.DropTarget) then - begin - Invalidate(FColumns.Items[NewTarget]); - FColumns.DropTarget := NewTarget; - end; - end; - - //Fix for various problems mentioned in issue 248. - if NeedRepaint then - begin - UpdateWindow(FOwner.Handle); - //The new routine recaptures the backup image after the updatewindow - //Note: We could have called this unconditionally but when called - //over the tree, doesn't capture the background image. Since our - //problems are in painting of the header, we call it only when the - //drag image is over the header. - if - //determine the case when the drag image is or was on the header area - (InHeader(FOwner.ScreenToClient(FDragImage.LastPosition)) or InHeader(FOwner.ScreenToClient(FDragImage.ImagePosition))) then - begin - GDIFlush; - TBaseVirtualTreeCracker(FOwner).UpdateWindowAndDragImage(TBaseVirtualTree(FOwner), TBaseVirtualTreeCracker(FOwner).HeaderRect, True, True); - end; - //since we took care of UpdateWindow above, there is no need to do an - //update window again by sending NeedRepaint. So switch off the second parameter. - NeedRepaint := False; - end; - - FDragImage.DragTo(P, NeedRepaint); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTHeader.FixedAreaConstraintsChanged(Sender : TObject); - -//This method gets called when FFixedAreaConstraints is changed. - -begin - if Tree.HandleAllocated then - RescaleHeader - else - Include(FStates, hsNeedScaling); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTHeader.GetColumnsClass : TVirtualTreeColumnsClass; - -//Returns the class to be used for the actual column implementation. descendants may optionally override this and -//return their own class. - -begin - Result := TVirtualTreeColumns; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTHeader.GetOwner : TPersistent; - -begin - Result := FOwner; -end; - -function TVTHeader.GetRestoreSelectionColumnIndex : Integer; -begin - if FRestoreSelectionColumnIndex >= 0 then - Result := FRestoreSelectionColumnIndex - else - Result := MainColumn; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTHeader.GetShiftState : TShiftState; - -begin - Result := []; - if GetKeyState(VK_SHIFT) < 0 then - Include(Result, ssShift); - if GetKeyState(VK_CONTROL) < 0 then - Include(Result, ssCtrl); - if GetKeyState(VK_MENU) < 0 then - Include(Result, ssAlt); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTHeader.HandleHeaderMouseMove(var Message : TWMMouseMove) : Boolean; - -var - P : TPoint; - NextColumn, I : TColumnIndex; - NewWidth : Integer; - -begin - Result := False; - with Message do - begin - P := Point(XPos, YPos); - if hsColumnWidthTrackPending in FStates then - begin - Tree.StopTimer(HeaderTimer); - FStates := FStates - [hsColumnWidthTrackPending] + [hsColumnWidthTracking]; - HandleHeaderMouseMove := True; - Result := 0; - end - else if hsHeightTrackPending in FStates then - begin - Tree.StopTimer(HeaderTimer); - FStates := FStates - [hsHeightTrackPending] + [hsHeightTracking]; - HandleHeaderMouseMove := True; - Result := 0; - end - else if hsColumnWidthTracking in FStates then - begin - if DoColumnWidthTracking(FColumns.TrackIndex, GetShiftState, FTrackPoint, P) then - begin - if Tree.UseRightToLeftAlignment then - begin - NewWidth := FTrackPoint.X - XPos; - NextColumn := FColumns.GetPreviousVisibleColumn(FColumns.TrackIndex); - end - else - begin - NewWidth := XPos - FTrackPoint.X; - NextColumn := FColumns.GetNextVisibleColumn(FColumns.TrackIndex); - end; - - //The autosized column cannot be resized using the mouse normally. Instead we resize the next - //visible column, so it look as we directly resize the autosized column. - if (hoAutoResize in FOptions) and (FColumns.TrackIndex = FAutoSizeIndex) and (NextColumn > NoColumn) and (coResizable in FColumns[NextColumn].Options) and - (FColumns[FColumns.TrackIndex].MinWidth < NewWidth) and (FColumns[FColumns.TrackIndex].MaxWidth > NewWidth) then - FColumns[NextColumn].Width := FColumns[NextColumn].Width - NewWidth + FColumns[FColumns.TrackIndex].Width - else - FColumns[FColumns.TrackIndex].Width := NewWidth; //1 EListError seen here (List index out of bounds (-1)) since 10/2013 - end; - HandleHeaderMouseMove := True; - Result := 0; - end - else if hsHeightTracking in FStates then - begin - if DoHeightTracking(P, GetShiftState) then - SetHeight(Integer(FHeight) + P.Y); - HandleHeaderMouseMove := True; - Result := 0; - end - else - begin - if hsDragPending in FStates then - begin - P := Tree.ClientToScreen(P); - //start actual dragging if allowed - if (hoDrag in FOptions) and Tree.DoHeaderDragging(TVirtualTreeColumnsCracker(FColumns).DownIndex) then - begin - if ((Abs(FDragStart.X - P.X) > Mouse.DragThreshold) or (Abs(FDragStart.Y - P.Y) > Mouse.DragThreshold)) then - begin - Tree.StopTimer(HeaderTimer); - with TVirtualTreeColumnsCracker(FColumns) do - begin - I := DownIndex; - DownIndex := NoColumn; - HoverIndex := NoColumn; - if I > NoColumn then - Invalidate(FColumns[I]); - end; - PrepareDrag(P, FDragStart); - FStates := FStates - [hsDragPending] + [hsDragging]; - HandleHeaderMouseMove := True; - Result := 0; - end; - end; - end - else if hsDragging in FStates then - begin - DragTo(Tree.ClientToScreen(Point(XPos, YPos))); - HandleHeaderMouseMove := True; - Result := 0; - end; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTHeader.HandleMessage(var Message : TMessage) : Boolean; - -//The header gets here the opportunity to handle certain messages before they reach the tree. This is important -//because the tree needs to handle various non-client area messages for the header as well as some dragging/tracking -//events. -//By returning True the message will not be handled further, otherwise the message is then dispatched -//to the proper message handlers. - -var - P : TPoint; - R : TRect; - I : TColumnIndex; - OldPosition : Integer; - HitIndex : TColumnIndex; - NewCursor : HCURSOR; - Button : TMouseButton; - IsInHeader, IsHSplitterHit, IsVSplitterHit : Boolean; - - //--------------- local function -------------------------------------------- - - function HSplitterHit : Boolean; - begin - Result := (hoColumnResize in FOptions) and DetermineSplitterIndex(P); - if Result and not InHeader(P) then - begin - // Code commented due to issue #1067. What was the orginal inention of this code? It does not make much sense unless you allow column resize outside the header. - //NextCol := FColumns.GetNextVisibleColumn(FColumns.TrackIndex); - //if not (coFixed in FColumns[FColumns.TrackIndex].Options) or (NextCol <= NoColumn) or - // (coFixed in FColumns[NextCol].Options) or (P.Y > Integer(Treeview.FRangeY)) then - Result := False; - end; - end; - -//--------------- end local function ---------------------------------------- - -begin - Result := False; - case Message.Msg of - WM_SIZE : - begin - if not (tsWindowCreating in TBaseVirtualTreeCracker(FOwner).TreeStates) then - if (hoAutoResize in FOptions) and not (hsAutoSizing in FStates) then - begin - TVirtualTreeColumnsCracker(FColumns).AdjustAutoSize(InvalidColumn); - Invalidate(nil); - end - else if not (hsScaling in FStates) then - begin - RescaleHeader; - Invalidate(nil); - end; - end; - CM_PARENTFONTCHANGED : - if FParentFont then - FFont.Assign(TBaseVirtualTreeCracker(FOwner).Font); - CM_BIDIMODECHANGED : - for I := 0 to FColumns.Count - 1 do - if coParentBiDiMode in FColumns[I].Options then - FColumns[I].ParentBiDiModeChanged; - WM_NCMBUTTONDOWN : - begin - with TWMNCMButtonDown(Message) do - P := Tree.ScreenToClient(Point(XCursor, YCursor)); - if InHeader(P) then - TBaseVirtualTreeCracker(FOwner).DoHeaderMouseDown(mbMiddle, GetShiftState, P.X, P.Y + Integer(FHeight)); - end; - WM_NCMBUTTONUP : - begin - with TWMNCMButtonUp(Message) do - P := FOwner.ScreenToClient(Point(XCursor, YCursor)); - if InHeader(P) then - begin - with TVirtualTreeColumnsCracker(FColumns) do - begin - HandleClick(P, mbMiddle, True, False); - TBaseVirtualTreeCracker(FOwner).DoHeaderMouseUp(mbMiddle, GetShiftState, P.X, P.Y + Integer(Self.FHeight)); - DownIndex := NoColumn; - CheckBoxHit := False; - end; - end; - end; - WM_LBUTTONDBLCLK, WM_NCLBUTTONDBLCLK, WM_NCMBUTTONDBLCLK, WM_NCRBUTTONDBLCLK : - begin - if Message.Msg <> WM_LBUTTONDBLCLK then - with TWMNCLButtonDblClk(Message) do - P := FOwner.ScreenToClient(Point(XCursor, YCursor)) - else - with TWMLButtonDblClk(Message) do - P := Point(XPos, YPos); - - if (hoHeightDblClickResize in FOptions) and InHeaderSplitterArea(P) and (FDefaultHeight > 0) then - begin - if DoHeightDblClickResize(P, GetShiftState) and (FDefaultHeight > 0) then - SetHeight(FMinHeight); - Result := True; - end - else if HSplitterHit and ((Message.Msg = WM_NCLBUTTONDBLCLK) or (Message.Msg = WM_LBUTTONDBLCLK)) and (hoDblClickResize in FOptions) and (FColumns.TrackIndex > NoColumn) - then - begin - //If the click was on a splitter then resize column to smallest width. - if DoColumnWidthDblClickResize(FColumns.TrackIndex, P, GetShiftState) then - AutoFitColumns(True, smaUseColumnOption, FColumns[FColumns.TrackIndex].Position, FColumns[FColumns.TrackIndex].Position); - Message.Result := 0; - Result := True; - end - else if InHeader(P) and (Message.Msg <> WM_LBUTTONDBLCLK) then - begin - case Message.Msg of - WM_NCMBUTTONDBLCLK : - Button := mbMiddle; - WM_NCRBUTTONDBLCLK : - Button := mbRight; - else - //WM_NCLBUTTONDBLCLK - Button := mbLeft; - end; - if Button = mbLeft then - TVirtualTreeColumnsCracker(FColumns).AdjustDownColumn(P); - TVirtualTreeColumnsCracker(FColumns).HandleClick(P, Button, True, True); - end; - end; - //The "hot" area of the headers horizontal splitter is partly within the client area of the the tree, so we need - //to handle WM_LBUTTONDOWN here, too. - WM_LBUTTONDOWN, WM_NCLBUTTONDOWN : - begin - - Application.CancelHint; - - if not (csDesigning in Tree.ComponentState) then - begin - with Tree do - begin - //make sure no auto scrolling is active... - StopTimer(ScrollTimer); - DoStateChange([], [tsScrollPending, tsScrolling]); - //... pending editing is cancelled (actual editing remains active) - StopTimer(EditTimer); - DoStateChange([], [tsEditPending]); - end; - end; - - if Message.Msg = WM_LBUTTONDOWN then - //Coordinates are already client area based. - with TWMLButtonDown(Message) do - begin - P := Point(XPos, YPos); - //#909 - FDragStart := Tree.ClientToScreen(P); - end - else - with TWMNCLButtonDown(Message) do - begin - //want the drag start point in screen coordinates - FDragStart := Point(XCursor, YCursor); - P := Tree.ScreenToClient(FDragStart); - end; - - IsInHeader := InHeader(P); - //in design-time header columns are always resizable - if (csDesigning in Tree.ComponentState) then - IsVSplitterHit := InHeaderSplitterArea(P) - else - IsVSplitterHit := InHeaderSplitterArea(P) and CanSplitterResize(P); - IsHSplitterHit := HSplitterHit; - - if IsVSplitterHit or IsHSplitterHit then - begin - FTrackStart := P; - TVirtualTreeColumnsCracker(FColumns).HoverIndex := NoColumn; - if IsVSplitterHit then - begin - if not (csDesigning in Tree.ComponentState) then - DoBeforeHeightTracking(GetShiftState); - Include(FStates, hsHeightTrackPending); - end - else - begin - if not (csDesigning in Tree.ComponentState) then - DoBeforeColumnWidthTracking(FColumns.TrackIndex, GetShiftState); - Include(FStates, hsColumnWidthTrackPending); - end; - - SetCapture(Tree.Handle); - Result := True; - Message.Result := 0; - end - else if IsInHeader then - begin - HitIndex := TVirtualTreeColumnsCracker(FColumns).AdjustDownColumn(P); - //in design-time header columns are always draggable - if ((csDesigning in Tree.ComponentState) and (HitIndex > NoColumn)) or ((hoDrag in FOptions) and (HitIndex > NoColumn) and (coDraggable in FColumns[HitIndex].Options)) - then - begin - //Show potential drag operation. - //Disabled columns do not start a drag operation because they can't be clicked. - Include(FStates, hsDragPending); - SetCapture(Tree.Handle); - Result := True; - Message.Result := 0; - end; - end; - - //This is a good opportunity to notify the application. - if not (csDesigning in Tree.ComponentState) and IsInHeader then - TBaseVirtualTreeCracker(FOwner).DoHeaderMouseDown(mbLeft, GetShiftState, P.X, P.Y + Integer(FHeight)); - end; - WM_NCRBUTTONDOWN : - begin - with TWMNCRButtonDown(Message) do - P := FOwner.ScreenToClient(Point(XCursor, YCursor)); - if InHeader(P) then - TBaseVirtualTreeCracker(FOwner).DoHeaderMouseDown(mbRight, GetShiftState, P.X, P.Y + Integer(FHeight)); - end; - WM_NCRBUTTONUP : - if not (csDesigning in FOwner.ComponentState) then - with TWMNCRButtonUp(Message) do - begin - Application.CancelHint; - P := FOwner.ScreenToClient(Point(XCursor, YCursor)); - if InHeader(P) then - begin - HandleMessage := TVirtualTreeColumnsCracker(FColumns).HandleClick(P, mbRight, True, False); - TBaseVirtualTreeCracker(FOwner).DoHeaderMouseUp(mbRight, GetShiftState, P.X, P.Y + Integer(FHeight)); - end; - end; - //When the tree window has an active mouse capture then we only get "client-area" messages. - WM_LBUTTONUP, WM_NCLBUTTONUP : - begin - Application.CancelHint; - - if FStates <> [] then - begin - ReleaseCapture; - if hsDragging in FStates then - begin - //successfull dragging moves columns - with TWMLButtonUp(Message) do - P := Tree.ClientToScreen(Point(XPos, YPos)); - GetWindowRect(Tree.Handle, R); - with FColumns do - begin - FDragImage.EndDrag; - - //Problem fixed: - //Column Header does not paint correctly after a drop in certain conditions - // ** The conditions are, drag is across header, mouse is not moved after - //the drop and the graphics hardware is slow in certain operations (encountered - //on Windows 10). - //Fix for the problem on certain systems where the dropped column header - //does not appear in the new position if the mouse is not moved after - //the drop. The reason is that the restore backup image operation (BitBlt) - //in the above EndDrag is slower than the header repaint in the code below - //and overlaps the new changed header with the older image. - //This happens because BitBlt seems to operate in its own thread in the - //graphics hardware and finishes later than the following code. - // - //To solve this problem, we introduce a small delay here so that the - //changed header in the following code is correctly repainted after - //the delayed BitBlt above has finished operation to restore the old - //backup image. - sleep(50); - - if (DropTarget > - 1) and (DropTarget <> DragIndex) and PtInRect(R, P) then - begin - OldPosition := FColumns[DragIndex].Position; - if FColumns.DropBefore then - begin - if FColumns[DragIndex].Position < FColumns[DropTarget].Position then - FColumns[DragIndex].Position := Max(0, FColumns[DropTarget].Position - 1) - else - FColumns[DragIndex].Position := FColumns[DropTarget].Position; - end - else - begin - if FColumns[DragIndex].Position < FColumns[DropTarget].Position then - FColumns[DragIndex].Position := FColumns[DropTarget].Position - else - FColumns[DragIndex].Position := FColumns[DropTarget].Position + 1; - end; - Tree.DoHeaderDragged(DragIndex, OldPosition); - end - else - Tree.DoHeaderDraggedOut(DragIndex, P); - DropTarget := NoColumn; - end; - Invalidate(nil); - end; - Result := True; - Message.Result := 0; - end; - - case Message.Msg of - WM_LBUTTONUP : - with TWMLButtonUp(Message) do - begin - with TVirtualTreeColumnsCracker(FColumns) do - begin - if DownIndex > NoColumn then - HandleClick(Point(XPos, YPos), mbLeft, False, False); - end; - if FStates <> [] then - TBaseVirtualTreeCracker(FOwner).DoHeaderMouseUp(mbLeft, KeysToShiftState(Keys), XPos, YPos); - end; - WM_NCLBUTTONUP : - with TWMNCLButtonUp(Message) do - begin - P := FOwner.ScreenToClient(Point(XCursor, YCursor)); - TVirtualTreeColumnsCracker(FColumns).HandleClick(P, mbLeft, False, False); - TBaseVirtualTreeCracker(FOwner).DoHeaderMouseUp(mbLeft, GetShiftState, P.X, P.Y + Integer(FHeight)); - end; - end; - - if FColumns.TrackIndex > NoColumn then - begin - if hsColumnWidthTracking in FStates then - DoAfterColumnWidthTracking(FColumns.TrackIndex); - Invalidate(Columns[FColumns.TrackIndex]); - FColumns.TrackIndex := NoColumn; - end; - with TVirtualTreeColumnsCracker(FColumns) do - begin - if DownIndex > NoColumn then - begin - Invalidate(FColumns[DownIndex]); - DownIndex := NoColumn; - end; - end; - if hsHeightTracking in FStates then - DoAfterHeightTracking; - - FStates := FStates - [hsDragging, hsDragPending, hsColumnWidthTracking, hsColumnWidthTrackPending, hsHeightTracking, hsHeightTrackPending]; - end; //WM_NCLBUTTONUP - //hovering, mouse leave detection - WM_NCMOUSEMOVE : - with TWMNCMouseMove(Message), TVirtualTreeColumnsCracker(FColumns) do - begin - P := Tree.ScreenToClient(Point(XCursor, YCursor)); - Tree.DoHeaderMouseMove(GetShiftState, P.X, P.Y + Integer(FHeight)); - if InHeader(P) and ((AdjustHoverColumn(P)) or ((DownIndex >= 0) and (HoverIndex <> DownIndex))) then - begin - //We need a mouse leave detection from here for the non client area. - //TODO: The best solution available would be the TrackMouseEvent API. - //With the drop of the support of Win95 totally and WinNT4 we should replace the timer. - Tree.StopTimer(HeaderTimer); - SetTimer(Tree.Handle, HeaderTimer, 50, nil); - //use Delphi's internal hint handling for header hints too - if hoShowHint in FOptions then - begin - //client coordinates! - XCursor := P.X; - YCursor := P.Y + Integer(FHeight); - Application.HintMouseMessage(FOwner, Message); - end; - end; - end; - WM_TIMER : - if TWMTimer(Message).TimerID = HeaderTimer then - begin - //determine current mouse position to check if it left the window - GetCursorPos(P); - P := Tree.ScreenToClient(P); - with TVirtualTreeColumnsCracker(FColumns) do - begin - if not InHeader(P) or ((DownIndex > NoColumn) and (HoverIndex <> DownIndex)) then - begin - Tree.StopTimer(HeaderTimer); - HoverIndex := NoColumn; - ClickIndex := NoColumn; - DownIndex := NoColumn; - CheckBoxHit := False; - Result := True; - Message.Result := 0; - Invalidate(nil); - end; - end; - end; - WM_MOUSEMOVE : //mouse capture and general message redirection - Result := HandleHeaderMouseMove(TWMMouseMove(Message)); - WM_SETCURSOR : - //Feature: design-time header - if (FStates = []) then - begin - //Retrieve last cursor position (GetMessagePos does not work here, I don't know why). - GetCursorPos(P); - - //Is the mouse in the header rectangle and near the splitters? - P := Tree.ScreenToClient(P); - IsHSplitterHit := HSplitterHit; - //in design-time header columns are always resizable - if (csDesigning in Tree.ComponentState) then - IsVSplitterHit := InHeaderSplitterArea(P) - else - IsVSplitterHit := InHeaderSplitterArea(P) and CanSplitterResize(P); - - if IsVSplitterHit or IsHSplitterHit then - begin - NewCursor := Screen.Cursors[Tree.Cursor]; - if IsVSplitterHit and ((hoHeightResize in FOptions) or (csDesigning in Tree.ComponentState)) then - NewCursor := Screen.Cursors[crVSplit] - else if IsHSplitterHit then - NewCursor := Screen.Cursors[crHSplit]; - - if not (csDesigning in Tree.ComponentState) then - Tree.DoGetHeaderCursor(NewCursor); - Result := NewCursor <> Screen.Cursors[crDefault]; - if Result then - begin - WinApi.Windows.SetCursor(NewCursor); - Message.Result := 1; - end; - end; - end - else - begin - Message.Result := 1; - Result := True; - end; - WM_KEYDOWN, WM_KILLFOCUS : - if (Message.Msg = WM_KILLFOCUS) or (TWMKeyDown(Message).CharCode = VK_ESCAPE) then - begin - if hsDragging in FStates then - begin - ReleaseCapture; - FDragImage.EndDrag; - Exclude(FStates, hsDragging); - FColumns.DropTarget := NoColumn; - Invalidate(nil); - Result := True; - Message.Result := 0; - end - else - begin - if [hsColumnWidthTracking, hsHeightTracking] * FStates <> [] then - begin - ReleaseCapture; - if hsColumnWidthTracking in FStates then - DoAfterColumnWidthTracking(FColumns.TrackIndex); - if hsHeightTracking in FStates then - DoAfterHeightTracking; - Result := True; - Message.Result := 0; - end; - - FStates := FStates - [hsColumnWidthTracking, hsColumnWidthTrackPending, hsHeightTracking, hsHeightTrackPending]; - end; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTHeader.ImageListChange(Sender : TObject); - -begin - if not (csDestroying in Tree.ComponentState) then - Invalidate(nil); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTHeader.PrepareDrag(P, Start : TPoint); - -//Initializes dragging of the header, P is the current mouse postion and Start the initial mouse position. - -var - Image : TBitmap; - ImagePos : TPoint; - DragColumn : TVirtualTreeColumn; - RTLOffset : Integer; - -begin - //Determine initial position of drag image (screen coordinates). - FColumns.DropTarget := NoColumn; - Start := Tree.ScreenToClient(Start); - Inc(Start.Y, FHeight); - FColumns.DragIndex := FColumns.ColumnFromPosition(Start); - DragColumn := FColumns[FColumns.DragIndex]; - - Image := TBitmap.Create; - with Image do - try - PixelFormat := pf32Bit; - SetSize(DragColumn.Width, FHeight); - - //Erase the entire image with the color key value, for the case not everything - //in the image is covered by the header image. - Canvas.Brush.Color := clBtnFace; - Canvas.FillRect(Rect(0, 0, Width, Height)); - - if Tree.UseRightToLeftAlignment then - RTLOffset := Tree.ComputeRTLOffset - else - RTLOffset := 0; - with DragColumn do - FColumns.PaintHeader(Canvas, Rect(Left, 0, Left + Width, Height), Point( - RTLOffset, 0), RTLOffset); - - if Tree.UseRightToLeftAlignment then - ImagePos := Tree.ClientToScreen(Point(DragColumn.Left + Tree.ComputeRTLOffset(True), 0)) - else - ImagePos := Tree.ClientToScreen(Point(DragColumn.Left, 0)); - //Column rectangles are given in local window coordinates not client coordinates. - Dec(ImagePos.Y, FHeight); - - if hoRestrictDrag in FOptions then - FDragImage.MoveRestriction := dmrHorizontalOnly - else - FDragImage.MoveRestriction := dmrNone; - FDragImage.PrepareDrag(Image, ImagePos, P, nil); - FDragImage.ShowDragImage; - finally - Image.Free; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTHeader.ReadColumns(Reader : TReader); - -begin - Include(FStates, hsLoading); - Columns.Clear; - Reader.ReadValue; - Reader.ReadCollection(Columns); - Exclude(FStates, hsLoading); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTHeader.RecalculateHeader; - -//Initiate a recalculation of the non-client area of the owner tree. - -begin - if Tree.HandleAllocated then - begin - Tree.UpdateHeaderRect; - SetWindowPos(Tree.Handle, 0, 0, 0, 0, 0, SWP_FRAMECHANGED or SWP_NOMOVE or SWP_NOACTIVATE or SWP_NOOWNERZORDER or SWP_NOSENDCHANGING or SWP_NOSIZE or SWP_NOZORDER); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTHeader.RescaleHeader; - -//Rescale the fixed elements (fixed columns, header itself) to FixedAreaConstraints. - -var - FixedWidth, MaxFixedWidth, MinFixedWidth : Integer; - - //--------------- local function -------------------------------------------- - - procedure ComputeConstraints; - - var - I : TColumnIndex; - - begin - with FColumns do - begin - I := GetFirstVisibleColumn; - while I > NoColumn do - begin - if (coFixed in FColumns[I].Options) and (FColumns[I].Width < FColumns[I].MinWidth) then - TVirtualTreeColumnCracker(FColumns[I]).InternalSetWidth(FColumns[I].MinWidth); //SetWidth has side effects and this bypasses them - I := GetNextVisibleColumn(I); - end; - FixedWidth := GetVisibleFixedWidth; - end; - - with FFixedAreaConstraints do - begin - MinFixedWidth := (Tree.ClientWidth * FMinWidthPercent) div 100; - MaxFixedWidth := (Tree.ClientWidth * FMaxWidthPercent) div 100; - end; - end; - -//----------- end local function -------------------------------------------- - -begin - if ([csLoading, csReading, csWriting, csDestroying] * Tree.ComponentState = []) and not (hsLoading in FStates) and Tree.HandleAllocated then - begin - Include(FStates, hsScaling); - - SetHeight(FHeight); - RecalculateHeader; - - with FFixedAreaConstraints do - if (FMaxWidthPercent > 0) or (FMinWidthPercent > 0) or (FMinHeightPercent > 0) or (FMaxHeightPercent > 0) then - begin - ComputeConstraints; - - with FColumns do - if (FMaxWidthPercent > 0) and (FixedWidth > MaxFixedWidth) then - ResizeColumns(MaxFixedWidth - FixedWidth, 0, Count - 1, [coVisible, coFixed]) - else if (FMinWidthPercent > 0) and (FixedWidth < MinFixedWidth) then - ResizeColumns(MinFixedWidth - FixedWidth, 0, Count - 1, [coVisible, coFixed]); - - TVirtualTreeColumnsCracker(FColumns).UpdatePositions; - end; - - Exclude(FStates, hsScaling); - Exclude(FStates, hsNeedScaling); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTHeader.UpdateMainColumn(); - -//Called once the load process of the owner tree is done. - -begin - if FMainColumn < 0 then - MainColumn := 0; - if FMainColumn > FColumns.Count - 1 then - MainColumn := FColumns.Count - 1; - if (FMainColumn >= 0) and not (coVisible in Self.Columns[FMainColumn].Options) then - begin - //Issue #946: Choose new MainColumn if current one ist not visible - MainColumn := Self.Columns.GetFirstVisibleColumn(); - end -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTHeader.UpdateSpringColumns; - -var - I : TColumnIndex; - SpringCount : Integer; - Sign : Integer; - ChangeBy : Single; - Difference : Single; - NewAccumulator : Single; - -begin - with Tree do - ChangeBy := HeaderRect.Right - HeaderRect.Left - FLastWidth; - if (hoAutoSpring in FOptions) and (FLastWidth <> 0) and (ChangeBy <> 0) then - begin - //Stay positive if downsizing the control. - if ChangeBy < 0 then - Sign := - 1 - else - Sign := 1; - ChangeBy := Abs(ChangeBy); - //Count how many columns have spring enabled. - SpringCount := 0; - for I := 0 to FColumns.Count - 1 do - if [coVisible, coAutoSpring] * FColumns[I].Options = [coVisible, coAutoSpring] then - Inc(SpringCount); - if SpringCount > 0 then - begin - //Calculate the size to add/sub to each columns. - Difference := ChangeBy / SpringCount; - //Adjust the column's size accumulators and resize if the result is >= 1. - for I := 0 to FColumns.Count - 1 do - if [coVisible, coAutoSpring] * FColumns[I].Options = [coVisible, coAutoSpring] then - begin - //Sum up rest changes from previous runs and the amount from this one and store it in the - //column. If there is at least one pixel difference then do a resize and reset the accumulator. - NewAccumulator := FColumns[I].SpringRest + Difference; - //Set new width if at least one pixel size difference is reached. - if NewAccumulator >= 1 then - TVirtualTreeColumnCracker(FColumns[I]).SetWidth(FColumns[I].Width + (Trunc(NewAccumulator) * Sign)); - FColumns[I].SpringRest := Frac(NewAccumulator); - - //Keep track of the size count. - ChangeBy := ChangeBy - Difference; - //Exit loop if resize count drops below freezing point. - if ChangeBy < 0 then - Break; - end; - end; - end; - with Tree do - FLastWidth := HeaderRect.Right - HeaderRect.Left; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -type - //--- HACK WARNING! - //This type cast is a partial rewrite of the private section of TWriter. The purpose is to have access to - //the FPropPath member, which is otherwise not accessible. The reason why this access is needed is that - //with nested components this member contains unneeded property path information. These information prevent - //successful load of the stored properties later. - //In System.Classes.pas you can see that FPropPath is reset several times to '' to prevent this case for certain properies. - //Unfortunately, there is no clean way for us here to do the same. -{$HINTS off} - TWriterHack = class(TFiler) - private - FRootAncestor : TComponent; - FPropPath : string; - end; -{$HINTS on} - - -procedure TVTHeader.WriteColumns(Writer : TWriter); - -//Write out the columns but take care for the case VT is a nested component. - -var - LastPropPath : string; - -begin - //Save last property path for restoration. - LastPropPath := TWriterHack(Writer).FPropPath; - try - //If VT is a nested component then this path contains the name of the parent component at this time - //(otherwise it is already empty). This path is then combined with the property name under which the tree - //is defined in the parent component. Unfortunately, the load code in System.Classes.pas does not consider this case - //is then unable to load this property. - TWriterHack(Writer).FPropPath := ''; - Writer.WriteCollection(Columns); - finally - TWriterHack(Writer).FPropPath := LastPropPath; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTHeader.AllowFocus(ColumnIndex : TColumnIndex) : Boolean; -begin - Result := False; - if not FColumns.IsValidColumn(ColumnIndex) then - Exit; //Just in case. - - Result := (coAllowFocus in FColumns[ColumnIndex].Options); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTHeader.Assign(Source : TPersistent); - -begin - if Source is TVTHeader then - begin - AutoSizeIndex := TVTHeader(Source).AutoSizeIndex; - Background := TVTHeader(Source).Background; - Columns := TVTHeader(Source).Columns; - Font := TVTHeader(Source).Font; - FixedAreaConstraints.Assign(TVTHeader(Source).FixedAreaConstraints); - Height := TVTHeader(Source).Height; - Images := TVTHeader(Source).Images; - MainColumn := TVTHeader(Source).MainColumn; - Options := TVTHeader(Source).Options; - ParentFont := TVTHeader(Source).ParentFont; - PopupMenu := TVTHeader(Source).PopupMenu; - SortColumn := TVTHeader(Source).SortColumn; - SortDirection := TVTHeader(Source).SortDirection; - Style := TVTHeader(Source).Style; - - RescaleHeader; - end - else - inherited; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTHeader.AutoFitColumns(); -begin - AutoFitColumns(not Tree.IsUpdating); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTHeader.AutoFitColumns(Animated : Boolean; SmartAutoFitType : TSmartAutoFitType = smaUseColumnOption; RangeStartCol : Integer = NoColumn; - RangeEndCol : Integer = NoColumn); - -//--------------- local functions ------------------------------------------- - - function GetUseSmartColumnWidth(ColumnIndex : TColumnIndex) : Boolean; - - begin - case SmartAutoFitType of - smaAllColumns : - Result := True; - smaUseColumnOption : - Result := coSmartResize in FColumns.Items[ColumnIndex].Options; - else - Result := False; - end; - end; - -//---------------------------------------------------------------------------- - - procedure DoAutoFitColumn(Column : TColumnIndex); - - begin - with TVirtualTreeColumnsCracker(FColumns) do - if ([coResizable, coVisible] * Items[PositionToIndex[Column]].Options = [coResizable, coVisible]) and DoBeforeAutoFitColumn(PositionToIndex[Column], SmartAutoFitType) and - not Tree.OperationCanceled then - begin - if Animated then - AnimatedResize(PositionToIndex[Column], Tree.GetMaxColumnWidth(PositionToIndex[Column], GetUseSmartColumnWidth(PositionToIndex[Column]))) - else - FColumns[PositionToIndex[Column]].Width := Tree.GetMaxColumnWidth(PositionToIndex[Column], GetUseSmartColumnWidth(PositionToIndex[Column])); - - DoAfterAutoFitColumn(PositionToIndex[Column]); - end; - end; - -//--------------- end local functions ---------------------------------------- - -var - I : Integer; - StartCol, EndCol : Integer; - -begin - StartCol := Max(NoColumn + 1, RangeStartCol); - - if RangeEndCol <= NoColumn then - EndCol := FColumns.Count - 1 - else - EndCol := Min(RangeEndCol, FColumns.Count - 1); - - if StartCol > EndCol then - Exit; //nothing to do - - Tree.StartOperation(okAutoFitColumns); - FDoingAutoFitColumns := True; - try - if Assigned(Tree.OnBeforeAutoFitColumns) then - Tree.OnBeforeAutoFitColumns(Self, SmartAutoFitType); - - for I := StartCol to EndCol do - DoAutoFitColumn(I); - - if Assigned(Tree.OnAfterAutoFitColumns) then - Tree.OnAfterAutoFitColumns(Self); - - finally - Tree.EndOperation(okAutoFitColumns); - Tree.Invalidate(); - FDoingAutoFitColumns := False; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTHeader.InHeader(P : TPoint) : Boolean; - -//Determines whether the given point (client coordinates!) is within the header rectangle (non-client coordinates). - -var - R, RW : TRect; - -begin - R := Tree.HeaderRect; - - //Current position of the owner in screen coordinates. - GetWindowRect(Tree.Handle, RW); - - //Convert to client coordinates. - MapWindowPoints(0, Tree.Handle, RW, 2); - - //Consider the header within this rectangle. - OffsetRect(R, RW.Left, RW.Top); - Result := PtInRect(R, P); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTHeader.InHeaderSplitterArea(P : TPoint) : Boolean; - -//Determines whether the given point (client coordinates!) hits the horizontal splitter area of the header. - -var - R, RW : TRect; - -begin - if (P.Y > 2) or (P.Y < - 2) or not (hoVisible in FOptions) then - Result := False - else - begin - R := Tree.HeaderRect; - Inc(R.Bottom, 2); - - //Current position of the owner in screen coordinates. - GetWindowRect(Tree.Handle, RW); - - //Convert to client coordinates. - MapWindowPoints(0, Tree.Handle, RW, 2); - - //Consider the header within this rectangle. - OffsetRect(R, RW.Left, RW.Top); - Result := PtInRect(R, P); - end; -end; - -procedure TVTHeader.InternalSetAutoSizeIndex(const Index : TColumnIndex); -begin - FAutoSizeIndex := index; -end; - -procedure TVTHeader.InternalSetMainColumn(const Index : TColumnIndex); -begin - FMainColumn := index; -end; - -procedure TVTHeader.InternalSetSortColumn(const Index : TColumnIndex); -begin - FSortColumn := index; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTHeader.Invalidate(Column : TVirtualTreeColumn; ExpandToBorder : Boolean = False; UpdateNowFlag : Boolean = False); - -//Because the header is in the non-client area of the tree it needs some special handling in order to initiate its -//repainting. -//If ExpandToBorder is True then not only the given column but everything or (depending on hoFullRepaintOnResize) just -//everything to its right (or left, in RTL mode) will be invalidated (useful for resizing). This makes only sense when -//a column is given. - -var - R, RW : TRect; - Flags : Cardinal; - -begin - if (hoVisible in FOptions) and Tree.HandleAllocated then - with Tree do - begin - if Column = nil then - R := HeaderRect - else - begin - R := Column.GetRect; - if not (coFixed in Column.Options) then - OffsetRect(R, - EffectiveOffsetX, 0); - if UseRightToLeftAlignment then - OffsetRect(R, ComputeRTLOffset, 0); - if ExpandToBorder then - begin - if (hoFullRepaintOnResize in Header.Options) then - begin - R.Left := HeaderRect.Left; - R.Right := HeaderRect.Right; - end - else - begin - if UseRightToLeftAlignment then - R.Left := HeaderRect.Left - else - R.Right := HeaderRect.Right; - end; - end; - end; - R.Bottom := Tree.ClientHeight; //We want to repaint the entire column to bottom, not just the header - - //Current position of the owner in screen coordinates. - GetWindowRect(Handle, RW); - - //Consider the header within this rectangle. - OffsetRect(R, RW.Left, RW.Top); - - //Expressed in client coordinates (because RedrawWindow wants them so, they will actually become negative). - MapWindowPoints(0, Handle, R, 2); - Flags := RDW_FRAME or RDW_INVALIDATE or RDW_VALIDATE or RDW_NOINTERNALPAINT or RDW_NOERASE or RDW_NOCHILDREN; - if UpdateNowFlag then - Flags := Flags or RDW_UPDATENOW; - RedrawWindow(Handle, @R, 0, Flags); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTHeader.LoadFromStream(const Stream : TStream); - -//restore the state of the header from the given stream - -var - Dummy, Version : Integer; - S : AnsiString; - OldOptions : TVTHeaderOptions; - -begin - Include(FStates, hsLoading); - with Stream do - try - //Switch off all options which could influence loading the columns (they will be later set again). - OldOptions := FOptions; - FOptions := []; - - //Determine whether the stream contains data without a version number. - ReadBuffer(Dummy, SizeOf(Dummy)); - if Dummy > - 1 then - begin - //Seek back to undo the read operation if this is an old stream format. - Seek( - SizeOf(Dummy), soFromCurrent); - Version := - 1; - end - else //Read version number if this is a "versionized" format. - ReadBuffer(Version, SizeOf(Version)); - Columns.LoadFromStream(Stream, Version); - - ReadBuffer(Dummy, SizeOf(Dummy)); - AutoSizeIndex := Dummy; - ReadBuffer(Dummy, SizeOf(Dummy)); - Background := Dummy; - ReadBuffer(Dummy, SizeOf(Dummy)); - Height := Dummy; - ReadBuffer(Dummy, SizeOf(Dummy)); - FOptions := OldOptions; - Options := TVTHeaderOptions(Dummy); - //PopupMenu is neither saved nor restored - ReadBuffer(Dummy, SizeOf(Dummy)); - Style := TVTHeaderStyle(Dummy); - //TFont has no own save routine so we do it manually - with Font do - begin - ReadBuffer(Dummy, SizeOf(Dummy)); - Color := Dummy; - ReadBuffer(Dummy, SizeOf(Dummy)); - Height := Dummy; - ReadBuffer(Dummy, SizeOf(Dummy)); - SetLength(S, Dummy); - ReadBuffer(PAnsiChar(S)^, Dummy); - Name := UTF8ToString(S); - ReadBuffer(Dummy, SizeOf(Dummy)); - Pitch := TFontPitch(Dummy); - ReadBuffer(Dummy, SizeOf(Dummy)); - Style := TFontStyles(Byte(Dummy)); - end; - - //Read data introduced by stream version 1+. - if Version > 0 then - begin - ReadBuffer(Dummy, SizeOf(Dummy)); - MainColumn := Dummy; - ReadBuffer(Dummy, SizeOf(Dummy)); - SortColumn := Dummy; - ReadBuffer(Dummy, SizeOf(Dummy)); - SortDirection := TSortDirection(Byte(Dummy)); - end; - - //Read data introduced by stream version 5+. - if Version > 4 then - begin - ReadBuffer(Dummy, SizeOf(Dummy)); - ParentFont := Boolean(Dummy); - ReadBuffer(Dummy, SizeOf(Dummy)); - FMaxHeight := Integer(Dummy); - ReadBuffer(Dummy, SizeOf(Dummy)); - FMinHeight := Integer(Dummy); - ReadBuffer(Dummy, SizeOf(Dummy)); - FDefaultHeight := Integer(Dummy); - with FFixedAreaConstraints do - begin - ReadBuffer(Dummy, SizeOf(Dummy)); - FMaxHeightPercent := TVTConstraintPercent(Dummy); - ReadBuffer(Dummy, SizeOf(Dummy)); - FMaxWidthPercent := TVTConstraintPercent(Dummy); - ReadBuffer(Dummy, SizeOf(Dummy)); - FMinHeightPercent := TVTConstraintPercent(Dummy); - ReadBuffer(Dummy, SizeOf(Dummy)); - FMinWidthPercent := TVTConstraintPercent(Dummy); - end; - end; - finally - Exclude(FStates, hsLoading); - RecalculateHeader(); - Tree.DoColumnResize(NoColumn); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTHeader.ResizeColumns(ChangeBy : Integer; RangeStartCol : TColumnIndex; RangeEndCol : TColumnIndex; Options : TVTColumnOptions = [coVisible]) : Integer; - -//Distribute the given width change to a range of columns. A 'fair' way is used to distribute ChangeBy to the columns, -//while ensuring that everything that can be distributed will be distributed. - -var - Start, I : TColumnIndex; - ColCount, ToGo, Sign, Rest, MaxDelta, Difference : Integer; - Constraints, Widths : array of Integer; - BonusPixel : Boolean; - - //--------------- local functions ------------------------------------------- - - function IsResizable(Column : TColumnIndex) : Boolean; - - begin - if BonusPixel then - Result := Widths[Column - RangeStartCol] < Constraints[Column - RangeStartCol] - else - Result := Widths[Column - RangeStartCol] > Constraints[Column - RangeStartCol]; - end; - -//--------------------------------------------------------------------------- - - procedure IncDelta(Column : TColumnIndex); - - begin - if BonusPixel then - Inc(MaxDelta, FColumns[Column].MaxWidth - Widths[Column - RangeStartCol]) - else - Inc(MaxDelta, Widths[Column - RangeStartCol] - Constraints[Column - RangeStartCol]); - end; - -//--------------------------------------------------------------------------- - - function ChangeWidth(Column : TColumnIndex; Delta : Integer) : Integer; - - begin - if Delta > 0 then - Delta := Min(Delta, Constraints[Column - RangeStartCol] - Widths[Column - RangeStartCol]) - else - Delta := Max(Delta, Constraints[Column - RangeStartCol] - Widths[Column - RangeStartCol]); - - Inc(Widths[Column - RangeStartCol], Delta); - Dec(ToGo, Abs(Delta)); - Result := Abs(Delta); - end; - -//--------------------------------------------------------------------------- - - function ReduceConstraints : Boolean; - - var - MaxWidth, MaxReserveCol, Column : TColumnIndex; - - begin - Result := True; - if not (hsScaling in FStates) or BonusPixel then - Exit; - - MaxWidth := 0; - MaxReserveCol := NoColumn; - for Column := RangeStartCol to RangeEndCol do - if (Options * FColumns[Column].Options = Options) and (FColumns[Column].Width > MaxWidth) then - begin - MaxWidth := Widths[Column - RangeStartCol]; - MaxReserveCol := Column; - end; - - if (MaxReserveCol <= NoColumn) or (Constraints[MaxReserveCol - RangeStartCol] <= 10) then - Result := False - else - Dec(Constraints[MaxReserveCol - RangeStartCol], Constraints[MaxReserveCol - RangeStartCol] div 10); - end; - -//----------- end local functions ------------------------------------------- - -begin - Result := 0; - if (ChangeBy <> 0) and (RangeEndCol >= 0) then // RangeEndCol == -1 means no columns, so nothing to do - begin - //Do some initialization here - BonusPixel := ChangeBy > 0; - Sign := IfThen(BonusPixel, 1, - 1); - Start := IfThen(BonusPixel, RangeStartCol, RangeEndCol); - ToGo := Abs(ChangeBy); - SetLength(Widths, RangeEndCol - RangeStartCol + 1); - SetLength(Constraints, RangeEndCol - RangeStartCol + 1); - for I := RangeStartCol to RangeEndCol do - begin - Widths[I - RangeStartCol] := FColumns[I].Width; - Constraints[I - RangeStartCol] := IfThen(BonusPixel, FColumns[I].MaxWidth, FColumns[I].MinWidth); - end; - - repeat - repeat - MaxDelta := 0; - ColCount := 0; - for I := RangeStartCol to RangeEndCol do - if (Options * FColumns[I].Options = Options) and IsResizable(I) then - begin - Inc(ColCount); - IncDelta(I); - end; - if MaxDelta < Abs(ChangeBy) then - if not ReduceConstraints then - Break; - until (MaxDelta >= Abs(ChangeBy)) or not (hsScaling in FStates); - - if ColCount = 0 then - Break; - - ToGo := Min(ToGo, MaxDelta); - Difference := ToGo div ColCount; - Rest := ToGo mod ColCount; - - if Difference > 0 then - for I := RangeStartCol to RangeEndCol do - if (Options * FColumns[I].Options = Options) and IsResizable(I) then - ChangeWidth(I, Difference * Sign); - - //Now distribute Rest. - I := Start; - while Rest > 0 do - begin - if (Options * FColumns[I].Options = Options) and IsResizable(I) then - if FColumns[I].BonusPixel <> BonusPixel then - begin - Dec(Rest, ChangeWidth(I, Sign)); - FColumns[I].BonusPixel := BonusPixel; - end; - Inc(I, Sign); - if (BonusPixel and (I > RangeEndCol)) or (not BonusPixel and (I < RangeStartCol)) then - begin - for I := RangeStartCol to RangeEndCol do - if Options * FColumns[I].Options = Options then - FColumns[I].BonusPixel := not FColumns[I].BonusPixel; - I := Start; - end; - end; - until ToGo <= 0; - - //Now set the computed widths. We also compute the result here. - Include(FStates, hsResizing); - for I := RangeStartCol to RangeEndCol do - if (Options * FColumns[I].Options = Options) then - begin - Inc(Result, Widths[I - RangeStartCol] - FColumns[I].Width); - TVirtualTreeColumnCracker(FColumns[I]).SetWidth(Widths[I - RangeStartCol]); - end; - Exclude(FStates, hsResizing); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTHeader.RestoreColumns; - -//Restores all columns to their width which they had before they have been auto fitted. - -var - I : TColumnIndex; - -begin - with TVirtualTreeColumnsCracker(FColumns) do - for I := Count - 1 downto 0 do - if [coResizable, coVisible] * Items[PositionToIndex[I]].Options = [coResizable, coVisible] then - Items[I].RestoreLastWidth; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTHeader.SaveToStream(const Stream : TStream); - -//Saves the complete state of the header into the provided stream. - -var - Dummy : Integer; - Tmp : AnsiString; - -begin - with Stream do - begin - //In previous version of VT was no header stream version defined. - //For feature enhancements it is necessary, however, to know which stream - //format we are trying to load. - //In order to distict from non-version streams an indicator is inserted. - Dummy := - 1; - WriteBuffer(Dummy, SizeOf(Dummy)); - //Write current stream version number, nothing more is required at the time being. - Dummy := VTHeaderStreamVersion; - WriteBuffer(Dummy, SizeOf(Dummy)); - - //Save columns in case they depend on certain options (like auto size). - Columns.SaveToStream(Stream); - - Dummy := FAutoSizeIndex; - WriteBuffer(Dummy, SizeOf(Dummy)); - Dummy := FBackgroundColor; - WriteBuffer(Dummy, SizeOf(Dummy)); - Dummy := FHeight; - WriteBuffer(Dummy, SizeOf(Dummy)); - Dummy := Integer(FOptions); - WriteBuffer(Dummy, SizeOf(Dummy)); - //PopupMenu is neither saved nor restored - Dummy := Ord(FStyle); - WriteBuffer(Dummy, SizeOf(Dummy)); - //TFont has no own save routine so we do it manually - with Font do - begin - Dummy := Color; - WriteBuffer(Dummy, SizeOf(Dummy)); - - //Need only to write one: size or height, I decided to write height. - Dummy := Height; - WriteBuffer(Dummy, SizeOf(Dummy)); - Tmp := UTF8Encode(Name); - Dummy := Length(Tmp); - WriteBuffer(Dummy, SizeOf(Dummy)); - WriteBuffer(PAnsiChar(Tmp)^, Dummy); - Dummy := Ord(Pitch); - WriteBuffer(Dummy, SizeOf(Dummy)); - Dummy := Byte(Style); - WriteBuffer(Dummy, SizeOf(Dummy)); - end; - - //Data introduced by stream version 1. - Dummy := FMainColumn; - WriteBuffer(Dummy, SizeOf(Dummy)); - Dummy := FSortColumn; - WriteBuffer(Dummy, SizeOf(Dummy)); - Dummy := Byte(FSortDirection); - WriteBuffer(Dummy, SizeOf(Dummy)); - - //Data introduced by stream version 5. - Dummy := Integer(ParentFont); - WriteBuffer(Dummy, SizeOf(Dummy)); - Dummy := Integer(FMaxHeight); - WriteBuffer(Dummy, SizeOf(Dummy)); - Dummy := Integer(FMinHeight); - WriteBuffer(Dummy, SizeOf(Dummy)); - Dummy := Integer(FDefaultHeight); - WriteBuffer(Dummy, SizeOf(Dummy)); - with FFixedAreaConstraints do - begin - Dummy := Integer(FMaxHeightPercent); - WriteBuffer(Dummy, SizeOf(Dummy)); - Dummy := Integer(FMaxWidthPercent); - WriteBuffer(Dummy, SizeOf(Dummy)); - Dummy := Integer(FMinHeightPercent); - WriteBuffer(Dummy, SizeOf(Dummy)); - Dummy := Integer(FMinWidthPercent); - WriteBuffer(Dummy, SizeOf(Dummy)); - end; - end; -end; - -{ TVTHeaderHelper } - -function TVTHeaderHelper.Tree : TBaseVirtualTreeCracker; -begin - Result := TBaseVirtualTreeCracker(Self.FOwner); -end; - - -//----------------- TVirtualTreeColumn --------------------------------------------------------------------------------- - -constructor TVirtualTreeColumn.Create(Collection : TCollection); - -begin - FMinWidth := 10; - FMaxWidth := 10000; - FImageIndex := - 1; - FMargin := 4; - FSpacing := cDefaultColumnSpacing; - FText := ''; - FOptions := DefaultColumnOptions; - FAlignment := taLeftJustify; - FBiDiMode := bdLeftToRight; - FColor := clWindow; - FLayout := blGlyphLeft; - FBonusPixel := False; - FCaptionAlignment := taLeftJustify; - FCheckType := ctCheckBox; - FCheckState := csUncheckedNormal; - FCheckBox := False; - FHasImage := False; - FDefaultSortDirection := sdAscending; - FEditNextColumn := - 1; - - inherited Create(Collection); - - if Assigned(Owner) then - begin - FWidth := Owner.DefaultWidth; - FLastWidth := Owner.DefaultWidth; - FPosition := Owner.Count - 1; - end; -end; - -procedure TVirtualTreeColumn.SetCollection(Value : TCollection); -begin - inherited; - // Read parent bidi mode and color values as default values. - ParentBiDiModeChanged; - ParentColorChanged; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -destructor TVirtualTreeColumn.Destroy; - -var - I : Integer; - ai : TColumnIndex; - sc : TColumnIndex; - - //--------------- local function --------------------------------------------- - - procedure AdjustColumnIndex(var ColumnIndex : TColumnIndex); - - begin - if Index = ColumnIndex then - ColumnIndex := NoColumn - else - if Index < ColumnIndex then - Dec(ColumnIndex); - end; - - //--------------- end local function ----------------------------------------- - -begin - // Check if this column is somehow referenced by its collection parent or the header. - with Owner do - begin - // If the columns collection object is currently deleting all columns - // then we don't need to check the various cached indices individually. - if not FClearing then - begin - TreeViewControl.CancelEditNode; - IndexChanged(Index, - 1); - - AdjustColumnIndex(FHoverIndex); - AdjustColumnIndex(FDownIndex); - AdjustColumnIndex(FTrackIndex); - AdjustColumnIndex(FClickIndex); - - with Header do - begin - ai := AutoSizeIndex; - AdjustColumnIndex(ai); - InternalSetAutoSizeIndex(ai); - if Index = MainColumn then - begin - // If the current main column is about to be destroyed then we have to find a new main column. - InternalSetMainColumn(NoColumn); //SetColumn has side effects we want to avoid here. - for I := 0 to Count - 1 do - if I <> Index then - begin - InternalSetMainColumn(I); - Break; - end; - end; - sc := SortColumn; - AdjustColumnIndex(sc); - InternalSetSortColumn(sc); - end; - end; - end; - - inherited; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVirtualTreeColumn.GetCaptionAlignment : TAlignment; - -begin - if coUseCaptionAlignment in FOptions then - Result := FCaptionAlignment - else - Result := FAlignment; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVirtualTreeColumn.GetCaptionWidth : TDimension; -var - Theme : HTHEME; - AdvancedOwnerDraw : Boolean; - PaintInfo : THeaderPaintInfo; - RequestedElements : THeaderPaintElements; - - TextSize : TSize; - HeaderGlyphSize : TPoint; - UseText : Boolean; - R : TRect; -begin - AdvancedOwnerDraw := (hoOwnerDraw in Header.Options) and Assigned(TreeViewControl.OnAdvancedHeaderDraw) and Assigned(TreeViewControl.OnHeaderDrawQueryElements) and - not (csDesigning in TreeViewControl.ComponentState); - - PaintInfo.Column := Self; - PaintInfo.TargetCanvas := Owner.HeaderBitmap.Canvas; - - with PaintInfo, Column do - begin - ShowHeaderGlyph := (hoShowImages in Header.Options) and ((Assigned(Header.Images) and (FImageIndex > - 1)) or FCheckBox); - ShowSortGlyph := ((Header.SortColumn > - 1) and (Self = Owner.Items[Header.SortColumn])) and (hoShowSortGlyphs in Header.Options); - - // This path for text columns or advanced owner draw. - // See if the application wants to draw part of the header itself. - RequestedElements := []; - if AdvancedOwnerDraw then - begin - PaintInfo.Column := Self; - TreeViewControl.DoHeaderDrawQueryElements(PaintInfo, RequestedElements); - end; - end; - - UseText := Length(FText) > 0; - // If nothing is to show then don't waste time with useless preparation. - if not (UseText or PaintInfo.ShowHeaderGlyph or PaintInfo.ShowSortGlyph) then - Exit(0); - - // Calculate sizes of the involved items. - with Header do - begin - if PaintInfo.ShowHeaderGlyph then - if not FCheckBox then - begin - if Assigned(Images) then - HeaderGlyphSize := Point(Images.Width, Images.Height); - end - else - with Self.TreeViewControl do - begin - if Assigned(CheckImages) then - HeaderGlyphSize := Point(CheckImages.Width, CheckImages.Height); - end - else - HeaderGlyphSize := Point(0, 0); - if PaintInfo.ShowSortGlyph then - begin - if tsUseExplorerTheme in Self.TreeViewControl.TreeStates then - begin - R := Rect(0, 0, 100, 100); - Theme := OpenThemeData(Self.TreeViewControl.Handle, 'HEADER'); - GetThemePartSize(Theme, PaintInfo.TargetCanvas.Handle, HP_HEADERSORTARROW, HSAS_SORTEDUP, @R, TS_TRUE, PaintInfo.SortGlyphSize); - CloseThemeData(Theme); - end - else - begin - PaintInfo.SortGlyphSize.cx := Self.TreeViewControl.ScaledPixels(16); - PaintInfo.SortGlyphSize.cy := Self.TreeViewControl.ScaledPixels(4); - end; - end - else - begin - PaintInfo.SortGlyphSize.cx := 0; - PaintInfo.SortGlyphSize.cy := 0; - end; - end; - - if UseText then - begin - GetTextExtentPoint32W(PaintInfo.TargetCanvas.Handle, PWideChar(FText), Length(FText), TextSize); - Inc(TextSize.cx, 2); - end - else - begin - TextSize.cx := 0; - TextSize.cy := 0; - end; - - // if CalculateTextRect then - Result := TextSize.cx; - if PaintInfo.ShowHeaderGlyph then - if Layout in [blGlyphLeft, blGlyphRight] then - Inc(Result, HeaderGlyphSize.X + FSpacing) - else // if Layout in [ blGlyphTop, blGlyphBottom] then - Result := Max(Result, HeaderGlyphSize.X); - if PaintInfo.ShowSortGlyph then - Inc(Result, PaintInfo.SortGlyphSize.cx + FSpacing + 2); // without this +2, there is a slight movement of the sort glyph when expanding the column - -end; -//---------------------------------------------------------------------------------------------------------------------- - -function TVirtualTreeColumn.GetLeft : Integer; - -begin - Result := FLeft; - if [coVisible, coFixed] * FOptions <> [coVisible, coFixed] then - Dec(Result, TreeViewControl.EffectiveOffsetX); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVirtualTreeColumn.IsBiDiModeStored : Boolean; - -begin - Result := not (coParentBidiMode in FOptions); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVirtualTreeColumn.IsCaptionAlignmentStored : Boolean; - -begin - Result := coUseCaptionAlignment in FOptions; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVirtualTreeColumn.IsColorStored : Boolean; - -begin - Result := not (coParentColor in FOptions); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumn.SetAlignment(const Value : TAlignment); - -begin - if FAlignment <> Value then - begin - FAlignment := Value; - Changed(False); - // Setting the alignment affects also the tree, hence invalidate it too. - TreeViewControl.Invalidate; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumn.SetBiDiMode(Value : TBiDiMode); - -begin - if Value <> FBiDiMode then - begin - FBiDiMode := Value; - Exclude(FOptions, coParentBidiMode); - Changed(False); - // Setting the alignment affects also the tree, hence invalidate it too. - TreeViewControl.Invalidate; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumn.SetCaptionAlignment(const Value : TAlignment); - -begin - if not (coUseCaptionAlignment in FOptions) or (FCaptionAlignment <> Value) then - begin - FCaptionAlignment := Value; - Include(FOptions, coUseCaptionAlignment); - // Setting the alignment affects also the tree, hence invalidate it too. - Header.Invalidate(Self); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumn.SetColor(const Value : TColor); - -begin - if FColor <> Value then - begin - FColor := Value; - Exclude(FOptions, coParentColor); - Exclude(FOptions, coStyleColor); // Issue #919 - Changed(False); - TreeViewControl.Invalidate; - end; -end; - -function TVirtualTreeColumn.GetEffectiveColor() : TColor; -// Returns the color that should effectively be used as background color for this -// column considering all flags in the TVirtualTreeColumn.Options property -begin - if (coParentColor in Options) or ((coStyleColor in Options) and TreeViewControl.VclStyleEnabled) then - Result := TreeViewControl.Colors.BackGroundColor - else - Result := Self.Color; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumn.SetCheckBox(Value : Boolean); - -begin - if Value <> FCheckBox then - begin - FCheckBox := Value; - if Value and (csDesigning in TreeViewControl.ComponentState) then - Header.Options := Header.Options + [hoShowImages]; - Changed(False); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumn.SetCheckState(Value : TCheckState); - -begin - if Value <> FCheckState then - begin - FCheckState := Value; - Changed(False); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumn.SetCheckType(Value : TCheckType); - -begin - if Value <> FCheckType then - begin - FCheckType := Value; - Changed(False); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumn.SetImageIndex(Value : TImageIndex); - -begin - if Value <> FImageIndex then - begin - FImageIndex := Value; - Changed(False); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumn.SetLayout(Value : TVTHeaderColumnLayout); - -begin - if FLayout <> Value then - begin - FLayout := Value; - Changed(False); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumn.SetMargin(Value : Integer); - -begin - // Compatibility setting for -1. - if Value < 0 then - Value := 4; - if FMargin <> Value then - begin - FMargin := Value; - Changed(False); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumn.SetMaxWidth(Value : Integer); - -begin - if Value < FMinWidth then - Value := FMinWidth; - FMaxWidth := Value; - SetWidth(FWidth); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumn.SetMinWidth(Value : Integer); - -begin - if Value < 0 then - Value := 0; - if Value > FMaxWidth then - Value := FMaxWidth; - FMinWidth := Value; - SetWidth(FWidth); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumn.SetOptions(Value : TVTColumnOptions); - -var - ToBeSet, - ToBeCleared : TVTColumnOptions; - VisibleChanged, - lParentColorSet : Boolean; -begin - if FOptions <> Value then - begin - ToBeCleared := FOptions - Value; - ToBeSet := Value - FOptions; - - FOptions := Value; - - VisibleChanged := coVisible in (ToBeSet + ToBeCleared); - lParentColorSet := coParentColor in ToBeSet; - - if coParentBidiMode in ToBeSet then - ParentBiDiModeChanged; - if lParentColorSet then - begin - Include(FOptions, coStyleColor); // Issue #919 - ParentColorChanged(); - end; - - if coAutoSpring in ToBeSet then - FSpringRest := 0; - - if coVisible in ToBeCleared then - Header.UpdateMainColumn(); // Fixes issue #946 - - if ((coFixed in ToBeSet) or (coFixed in ToBeCleared)) and (coVisible in FOptions) then - Header.RescaleHeader; - - Changed(False); - // Need to repaint and adjust the owner tree too. - if not (csLoading in TreeViewControl.ComponentState) and (VisibleChanged or lParentColorSet) and (Owner.UpdateCount = 0) and TreeViewControl.HandleAllocated then - begin - TreeViewControl.Invalidate(); - if VisibleChanged then - begin - TreeViewControl.DoColumnVisibilityChanged(Self.Index, coVisible in ToBeSet); - TreeViewControl.UpdateHorizontalScrollBar(False); - end; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumn.SetPosition(Value : TColumnPosition); - -var - Temp : TColumnIndex; - -begin - if (csLoading in TreeViewControl.ComponentState) or (Owner.UpdateCount > 0) then - // Only cache the position for final fixup when loading from DFM. - FPosition := Value - else - begin - if Value >= TColumnPosition(Collection.Count) then - Value := Collection.Count - 1; - if FPosition <> Value then - begin - with Owner do - begin - InitializePositionArray; - TreeViewControl.CancelEditNode; - AdjustPosition(Self, Value); - Self.Changed(False); - - // Need to repaint. - with Self.Header do - begin - if (UpdateCount = 0) and TreeViewControl.HandleAllocated then - begin - Invalidate(Self); - TreeViewControl.Invalidate; - end; - end; - end; - - // If the moved column is now within the fixed columns then we make it fixed as well. If it's not - // we clear the fixed state (in case that fixed column is moved outside fixed area). - if (coFixed in FOptions) and (FPosition > 0) then - Temp := Owner.ColumnFromPosition(FPosition - 1) - else - Temp := Owner.ColumnFromPosition(FPosition + 1); - - if Temp <> NoColumn then - begin - if coFixed in Owner[Temp].Options then - Options := Options + [coFixed] - else - Options := Options - [coFixed]; - end; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumn.SetSpacing(Value : Integer); - -begin - if FSpacing <> Value then - begin - FSpacing := Value; - Changed(False); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumn.SetStyle(Value : TVirtualTreeColumnStyle); - -begin - if FStyle <> Value then - begin - FStyle := Value; - Changed(False); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumn.SetText(const Value : string); - -begin - if FText <> Value then - begin - FText := Value; - FCaptionText := ''; - Changed(False); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumn.SetWidth(Value : Integer); - -var - EffectiveMaxWidth, - EffectiveMinWidth, - TotalFixedMaxWidth, - TotalFixedMinWidth : Integer; - I : TColumnIndex; - -begin - if not (hsScaling in Header.States) then - if ([coVisible, coFixed] * FOptions = [coVisible, coFixed]) then - begin - with Header, FixedAreaConstraints, TreeView do - begin - TotalFixedMinWidth := 0; - TotalFixedMaxWidth := 0; - for I := 0 to Columns.Count - 1 do - if ([coVisible, coFixed] * Columns[I].Options = [coVisible, coFixed]) then - begin - Inc(TotalFixedMaxWidth, Columns[I].MaxWidth); - Inc(TotalFixedMinWidth, Columns[I].MinWidth); - end; - - if HandleAllocated then // Prevent premature creation of window handle, see issue #1073 - begin - // The percentage values have precedence over the pixel values. - If MaxWidthPercent > 0 then - TotalFixedMinWidth := Min((ClientWidth * MaxWidthPercent) div 100, TotalFixedMinWidth); - If MinWidthPercent > 0 then - TotalFixedMaxWidth := Max((ClientWidth * MinWidthPercent) div 100, TotalFixedMaxWidth); - - EffectiveMaxWidth := Min(TotalFixedMaxWidth - (Columns.GetVisibleFixedWidth - Self.FWidth), FMaxWidth); - EffectiveMinWidth := Max(TotalFixedMinWidth - (Columns.GetVisibleFixedWidth - Self.FWidth), FMinWidth); - Value := Min(Max(Value, EffectiveMinWidth), EffectiveMaxWidth); - - if MinWidthPercent > 0 then - Value := Max((ClientWidth * MinWidthPercent) div 100 - Columns.GetVisibleFixedWidth + Self.FWidth, Value); - if MaxWidthPercent > 0 then - Value := Min((ClientWidth * MaxWidthPercent) div 100 - Columns.GetVisibleFixedWidth + Self.FWidth, Value); - end;// if HandleAllocated - end; - end - else - Value := Min(Max(Value, FMinWidth), FMaxWidth); - - if FWidth <> Value then - begin - FLastWidth := FWidth; - if not (hsResizing in Header.States) then - FBonusPixel := False; - if not (hoAutoResize in Header.Options) or (Index <> Header.AutoSizeIndex) then - begin - FWidth := Value; - Owner.UpdatePositions; - end; - if not (csLoading in TreeViewControl.ComponentState) and (Owner.UpdateCount = 0) then - begin - if hoAutoResize in Header.Options then - Owner.AdjustAutoSize(Index); - TreeViewControl.DoColumnResize(Index); - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumn.ChangeScale(M, D : TDimension; isDpiChange : Boolean); -begin - FMinWidth := MulDiv(FMinWidth, M, D); - FMaxWidth := MulDiv(FMaxWidth, M, D); - FSpacing := MulDiv(FSpacing, M, D); - Self.Width := MulDiv(Self.Width, M, D); -end; - -procedure TVirtualTreeColumn.ComputeHeaderLayout(var PaintInfo : THeaderPaintInfo; DrawFormat : Cardinal; CalculateTextRect : Boolean = False); - -// The layout of a column header is determined by a lot of factors. This method takes them all into account and -// determines all necessary positions and bounds: -// - for the header text -// - the header glyph -// - the sort glyph - -var - TextSize : TSize; - TextPos, - ClientSize, - HeaderGlyphSize : TPoint; - CurrentAlignment : TAlignment; - MinLeft, - MaxRight, - TextSpacing : Integer; - UseText : Boolean; - R : TRect; - Theme : HTHEME; - -begin - UseText := Length(FText) > 0; - // If nothing is to show then don't waste time with useless preparation. - if not (UseText or PaintInfo.ShowHeaderGlyph or PaintInfo.ShowSortGlyph) then - Exit; - - CurrentAlignment := CaptionAlignment; - if FBiDiMode <> bdLeftToRight then - ChangeBiDiModeAlignment(CurrentAlignment); - - // Calculate sizes of the involved items. - ClientSize := Point(PaintInfo.PaintRectangle.Right - PaintInfo.PaintRectangle.Left, PaintInfo.PaintRectangle.Bottom - PaintInfo.PaintRectangle.Top); - with Owner, Header do - begin - if PaintInfo.ShowHeaderGlyph then - if not FCheckBox then - HeaderGlyphSize := Point(Images.Width, Images.Height) - else - with Self.TreeViewControl do - begin - if Assigned(CheckImages) then - HeaderGlyphSize := Point(CheckImages.Width, CheckImages.Height); - end - else - HeaderGlyphSize := Point(0, 0); - if PaintInfo.ShowSortGlyph then - begin - if tsUseExplorerTheme in Self.TreeViewControl.TreeStates then - begin - R := Rect(0, 0, 100, 100); - Theme := OpenThemeData(TreeViewControl.Handle, 'HEADER'); - GetThemePartSize(Theme, PaintInfo.TargetCanvas.Handle, HP_HEADERSORTARROW, HSAS_SORTEDUP, @R, TS_TRUE, PaintInfo.SortGlyphSize); - CloseThemeData(Theme); - end - else - begin - PaintInfo.SortGlyphSize.cx := Self.TreeViewControl.ScaledPixels(16); - PaintInfo.SortGlyphSize.cy := Self.TreeViewControl.ScaledPixels(4); - end; - - // In any case, the sort glyph is vertically centered. - PaintInfo.SortGlyphPos.Y := (ClientSize.Y - PaintInfo.SortGlyphSize.cy) div 2; - end - else - begin - PaintInfo.SortGlyphSize.cx := 0; - PaintInfo.SortGlyphSize.cy := 0; - end; - end; - - if UseText then - begin - if not (coWrapCaption in FOptions) then - begin - FCaptionText := FText; - GetTextExtentPoint32W(PaintInfo.TargetCanvas.Handle, PWideChar(FText), Length(FText), TextSize); - Inc(TextSize.cx, 2); - PaintInfo.TextRectangle := Rect(0, 0, TextSize.cx, TextSize.cy); - end - else - begin - R := PaintInfo.PaintRectangle; - if FCaptionText = '' then - FCaptionText := WrapString(PaintInfo.TargetCanvas.Handle, FText, R, DT_RTLREADING and DrawFormat <> 0, DrawFormat); - - GetStringDrawRect(PaintInfo.TargetCanvas.Handle, FCaptionText, R, DrawFormat); - TextSize.cx := PaintInfo.PaintRectangle.Right - PaintInfo.PaintRectangle.Left; - TextSize.cy := R.Bottom - R.Top; - PaintInfo.TextRectangle := Rect(0, 0, TextSize.cx, TextSize.cy); - end; - TextSpacing := FSpacing; - end - else - begin - TextSpacing := 0; - TextSize.cx := 0; - TextSize.cy := 0; - end; - - // Check first for the special case where nothing is shown except the sort glyph. - if PaintInfo.ShowSortGlyph and not (UseText or PaintInfo.ShowHeaderGlyph) then - begin - // Center the sort glyph in the available area if nothing else is there. - PaintInfo.SortGlyphPos := Point((ClientSize.X - PaintInfo.SortGlyphSize.cx) div 2, (ClientSize.Y - PaintInfo.SortGlyphSize.cy) div 2); - end - else - begin - // Determine extents of text and glyph and calculate positions which are clear from the layout. - if (Layout in [blGlyphLeft, blGlyphRight]) or not PaintInfo.ShowHeaderGlyph then - begin - PaintInfo.GlyphPos.Y := (ClientSize.Y - HeaderGlyphSize.Y) div 2; - // If the text is taller than the given height, perform no vertical centration as this - // would make the text even less readable. - //Using Max() fixes badly positioned text if Extra Large fonts have been activated in the Windows display options - TextPos.Y := Max( - 5, (ClientSize.Y - TextSize.cy) div 2); - end - else - begin - if Layout = blGlyphTop then - begin - PaintInfo.GlyphPos.Y := (ClientSize.Y - HeaderGlyphSize.Y - TextSize.cy - TextSpacing) div 2; - TextPos.Y := PaintInfo.GlyphPos.Y + HeaderGlyphSize.Y + TextSpacing; - end - else - begin - TextPos.Y := (ClientSize.Y - HeaderGlyphSize.Y - TextSize.cy - TextSpacing) div 2; - PaintInfo.GlyphPos.Y := TextPos.Y + TextSize.cy + TextSpacing; - end; - end; - - // Each alignment needs special consideration. - case CurrentAlignment of - taLeftJustify : - begin - MinLeft := FMargin; - if PaintInfo.ShowSortGlyph and (FBiDiMode <> bdLeftToRight) then - begin - // In RTL context is the sort glyph placed on the left hand side. - PaintInfo.SortGlyphPos.X := MinLeft; - Inc(MinLeft, PaintInfo.SortGlyphSize.cx + FSpacing); - end; - if Layout in [blGlyphTop, blGlyphBottom] then - begin - // Header glyph is above or below text, so both must be considered when calculating - // the left positition of the sort glyph (if it is on the right hand side). - TextPos.X := MinLeft; - if PaintInfo.ShowHeaderGlyph then - begin - PaintInfo.GlyphPos.X := (ClientSize.X - HeaderGlyphSize.X) div 2; - if PaintInfo.GlyphPos.X < MinLeft then - PaintInfo.GlyphPos.X := MinLeft; - MinLeft := Max(TextPos.X + TextSize.cx + TextSpacing, PaintInfo.GlyphPos.X + HeaderGlyphSize.X + FSpacing); - end - else - MinLeft := TextPos.X + TextSize.cx + TextSpacing; - end - else - begin - // Everything is lined up. TextSpacing might be 0 if there is no text. - // This simplifies the calculation because no extra tests are necessary. - if PaintInfo.ShowHeaderGlyph and (Layout = blGlyphLeft) then - begin - PaintInfo.GlyphPos.X := MinLeft; - Inc(MinLeft, HeaderGlyphSize.X + FSpacing); - end; - TextPos.X := MinLeft; - Inc(MinLeft, TextSize.cx + TextSpacing); - if PaintInfo.ShowHeaderGlyph and (Layout = blGlyphRight) then - begin - PaintInfo.GlyphPos.X := MinLeft; - Inc(MinLeft, HeaderGlyphSize.X + FSpacing); - end; - end; - if PaintInfo.ShowSortGlyph and (FBiDiMode = bdLeftToRight) then - PaintInfo.SortGlyphPos.X := MinLeft; - end; - taCenter : - begin - if Layout in [blGlyphTop, blGlyphBottom] then - begin - PaintInfo.GlyphPos.X := (ClientSize.X - HeaderGlyphSize.X) div 2; - TextPos.X := (ClientSize.X - TextSize.cx) div 2; - if PaintInfo.ShowSortGlyph then - Dec(TextPos.X, PaintInfo.SortGlyphSize.cx div 2); - end - else - begin - MinLeft := (ClientSize.X - HeaderGlyphSize.X - TextSpacing - TextSize.cx) div 2; - if PaintInfo.ShowHeaderGlyph and (Layout = blGlyphLeft) then - begin - PaintInfo.GlyphPos.X := MinLeft; - Inc(MinLeft, HeaderGlyphSize.X + TextSpacing); - end; - TextPos.X := MinLeft; - Inc(MinLeft, TextSize.cx + TextSpacing); - if PaintInfo.ShowHeaderGlyph and (Layout = blGlyphRight) then - PaintInfo.GlyphPos.X := MinLeft; - end; - if PaintInfo.ShowHeaderGlyph then - begin - MinLeft := Min(PaintInfo.GlyphPos.X, TextPos.X); - MaxRight := Max(PaintInfo.GlyphPos.X + HeaderGlyphSize.X, TextPos.X + TextSize.cx); - end - else - begin - MinLeft := TextPos.X; - MaxRight := TextPos.X + TextSize.cx; - end; - // Place the sort glyph directly to the left or right of the larger item. - if PaintInfo.ShowSortGlyph then - if FBiDiMode = bdLeftToRight then - begin - // Sort glyph on the right hand side. - PaintInfo.SortGlyphPos.X := MaxRight + FSpacing; - end - else - begin - // Sort glyph on the left hand side. - PaintInfo.SortGlyphPos.X := MinLeft - FSpacing - PaintInfo.SortGlyphSize.cx; - end; - end; - else - // taRightJustify - MaxRight := ClientSize.X - FMargin; - if PaintInfo.ShowSortGlyph and (FBiDiMode = bdLeftToRight) then - begin - // In LTR context is the sort glyph placed on the right hand side. - Dec(MaxRight, PaintInfo.SortGlyphSize.cx); - PaintInfo.SortGlyphPos.X := MaxRight; - Dec(MaxRight, FSpacing); - end; - if Layout in [blGlyphTop, blGlyphBottom] then - begin - TextPos.X := MaxRight - TextSize.cx; - if PaintInfo.ShowHeaderGlyph then - begin - PaintInfo.GlyphPos.X := (ClientSize.X - HeaderGlyphSize.X) div 2; - if PaintInfo.GlyphPos.X + HeaderGlyphSize.X + FSpacing > MaxRight then - PaintInfo.GlyphPos.X := MaxRight - HeaderGlyphSize.X - FSpacing; - MaxRight := Min(TextPos.X - TextSpacing, PaintInfo.GlyphPos.X - FSpacing); - end - else - MaxRight := TextPos.X - TextSpacing; - end - else - begin - // Everything is lined up. TextSpacing might be 0 if there is no text. - // This simplifies the calculation because no extra tests are necessary. - if PaintInfo.ShowHeaderGlyph and (Layout = blGlyphRight) then - begin - PaintInfo.GlyphPos.X := MaxRight - HeaderGlyphSize.X; - MaxRight := PaintInfo.GlyphPos.X - FSpacing; - end; - TextPos.X := MaxRight - TextSize.cx; - MaxRight := TextPos.X - TextSpacing; - if PaintInfo.ShowHeaderGlyph and (Layout = blGlyphLeft) then - begin - PaintInfo.GlyphPos.X := MaxRight - HeaderGlyphSize.X; - MaxRight := PaintInfo.GlyphPos.X - FSpacing; - end; - end; - if PaintInfo.ShowSortGlyph and (FBiDiMode <> bdLeftToRight) then - PaintInfo.SortGlyphPos.X := MaxRight - PaintInfo.SortGlyphSize.cx; - end; - end; - - // Once the position of each element is determined there remains only one but important step. - // The horizontal positions of every element must be adjusted so that it always fits into the - // given header area. This is accomplished by shorten the text appropriately. - - // These are the maximum bounds. Nothing goes beyond them. - MinLeft := FMargin; - MaxRight := ClientSize.X - FMargin; - if PaintInfo.ShowSortGlyph then - begin - if FBiDiMode = bdLeftToRight then - begin - // Sort glyph on the right hand side. - if PaintInfo.SortGlyphPos.X + PaintInfo.SortGlyphSize.cx > MaxRight then - PaintInfo.SortGlyphPos.X := MaxRight - PaintInfo.SortGlyphSize.cx; - MaxRight := PaintInfo.SortGlyphPos.X - FSpacing; - end; - - // Consider also the left side of the sort glyph regardless of the bidi mode. - if PaintInfo.SortGlyphPos.X < MinLeft then - PaintInfo.SortGlyphPos.X := MinLeft; - // Left border needs only adjustment if the sort glyph marks the left border. - if FBiDiMode <> bdLeftToRight then - MinLeft := PaintInfo.SortGlyphPos.X + PaintInfo.SortGlyphSize.cx + FSpacing; - - // Finally transform sort glyph to its actual position. - Inc(PaintInfo.SortGlyphPos.X, PaintInfo.PaintRectangle.Left); - Inc(PaintInfo.SortGlyphPos.Y, PaintInfo.PaintRectangle.Top); - end; - if PaintInfo.ShowHeaderGlyph then - begin - if PaintInfo.GlyphPos.X + HeaderGlyphSize.X > MaxRight then - PaintInfo.GlyphPos.X := MaxRight - HeaderGlyphSize.X; - if Layout = blGlyphRight then - MaxRight := PaintInfo.GlyphPos.X - FSpacing; - if PaintInfo.GlyphPos.X < MinLeft then - PaintInfo.GlyphPos.X := MinLeft; - if Layout = blGlyphLeft then - MinLeft := PaintInfo.GlyphPos.X + HeaderGlyphSize.X + FSpacing; - if FCheckBox and (Header.MainColumn = Self.Index) then - Dec(PaintInfo.GlyphPos.X, 2) - else - if Header.MainColumn <> Self.Index then - Dec(PaintInfo.GlyphPos.X, 2); - - // Finally transform header glyph to its actual position. - Inc(PaintInfo.GlyphPos.X, PaintInfo.PaintRectangle.Left); - Inc(PaintInfo.GlyphPos.Y, PaintInfo.PaintRectangle.Top); - end; - if UseText then - begin - if TextPos.X < MinLeft then - TextPos.X := MinLeft; - OffsetRect(PaintInfo.TextRectangle, TextPos.X, TextPos.Y); - if PaintInfo.TextRectangle.Right > MaxRight then - PaintInfo.TextRectangle.Right := MaxRight; - OffsetRect(PaintInfo.TextRectangle, PaintInfo.PaintRectangle.Left, PaintInfo.PaintRectangle.Top); - - if coWrapCaption in FOptions then - begin - // Wrap the column caption if necessary. - R := PaintInfo.TextRectangle; - FCaptionText := WrapString(PaintInfo.TargetCanvas.Handle, FText, R, DT_RTLREADING and DrawFormat <> 0, DrawFormat); - GetStringDrawRect(PaintInfo.TargetCanvas.Handle, FCaptionText, R, DrawFormat); - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumn.DefineProperties(Filer : TFiler); - -begin - inherited; - - // These properites are remains from non-Unicode Delphi versions, readers remain for backward compatibility. - Filer.DefineProperty('WideText', ReadText, nil, False); - Filer.DefineProperty('WideHint', ReadHint, nil, False); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumn.GetAbsoluteBounds(var Left, Right : Integer); - -// Returns the column's left and right bounds in header coordinates, that is, independant of the scrolling position. - -begin - Left := FLeft; - Right := FLeft + FWidth; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVirtualTreeColumn.GetDisplayName : string; - -// Returns the column text if it only contains ANSI characters, otherwise the column id is returned because the IDE -// still cannot handle Unicode strings. - -var - I : Integer; - -begin - // Check if the text of the column contains characters > 255 - I := 1; - while I <= Length(FText) do - begin - if Ord(FText[I]) > 255 then - Break; - Inc(I); - end; - - if I > Length(FText) then - Result := FText // implicit conversion - else - Result := Format('Column %d', [Index]); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVirtualTreeColumn.GetOwner : TVirtualTreeColumns; - -begin - Result := Collection as TVirtualTreeColumns; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumn.InternalSetWidth(const Value : TDimension); -begin - FWidth := Value; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumn.ReadText(Reader : TReader); - -begin - case Reader.NextValue of - vaLString, vaString : - SetText(Reader.ReadString); - else - SetText(Reader.ReadString); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumn.ReadHint(Reader : TReader); - -begin - case Reader.NextValue of - vaLString, vaString : - FHint := Reader.ReadString; - else - FHint := Reader.ReadString; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumn.Assign(Source : TPersistent); - -var - OldOptions : TVTColumnOptions; - -begin - if Source is TVirtualTreeColumn then - begin - OldOptions := FOptions; - FOptions := []; - - BiDiMode := TVirtualTreeColumn(Source).BiDiMode; - ImageIndex := TVirtualTreeColumn(Source).ImageIndex; - Layout := TVirtualTreeColumn(Source).Layout; - Margin := TVirtualTreeColumn(Source).Margin; - MaxWidth := TVirtualTreeColumn(Source).MaxWidth; - MinWidth := TVirtualTreeColumn(Source).MinWidth; - Position := TVirtualTreeColumn(Source).Position; - Spacing := TVirtualTreeColumn(Source).Spacing; - Style := TVirtualTreeColumn(Source).Style; - Text := TVirtualTreeColumn(Source).Text; - Hint := TVirtualTreeColumn(Source).Hint; - Width := TVirtualTreeColumn(Source).Width; - Alignment := TVirtualTreeColumn(Source).Alignment; - CaptionAlignment := TVirtualTreeColumn(Source).CaptionAlignment; - Color := TVirtualTreeColumn(Source).Color; - Tag := TVirtualTreeColumn(Source).Tag; - EditOptions := TVirtualTreeColumn(Source).EditOptions; - EditNextColumn := TVirtualTreeColumn(Source).EditNextColumn; - - // Order is important. Assign options last. - FOptions := OldOptions; - Options := TVirtualTreeColumn(Source).Options; - - Changed(False); - end - else - inherited Assign(Source); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVirtualTreeColumn.Equals(OtherColumnObj : TObject) : Boolean; -var - OtherColumn : TVirtualTreeColumn; -begin - if OtherColumnObj is TVirtualTreeColumn then - begin - OtherColumn := TVirtualTreeColumn(OtherColumnObj); - Result := (BiDiMode = OtherColumn.BiDiMode) and - (ImageIndex = OtherColumn.ImageIndex) and - (Layout = OtherColumn.Layout) and - (Margin = OtherColumn.Margin) and - (MaxWidth = OtherColumn.MaxWidth) and - (MinWidth = OtherColumn.MinWidth) and - (Position = OtherColumn.Position) and - (Spacing = OtherColumn.Spacing) and - (Style = OtherColumn.Style) and - (Text = OtherColumn.Text) and - (Hint = OtherColumn.Hint) and - (Width = OtherColumn.Width) and - (Alignment = OtherColumn.Alignment) and - (CaptionAlignment = OtherColumn.CaptionAlignment) and - (Color = OtherColumn.Color) and - (Tag = OtherColumn.Tag) and - (Options = OtherColumn.Options); - end - else - Result := False; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVirtualTreeColumn.GetRect : TRect; - -// Returns the rectangle this column occupies in the header (relative to (0, 0) of the non-client area). - -begin - with TVirtualTreeColumns(GetOwner).FHeader do - Result := TreeViewControl.HeaderRect; - Inc(Result.Left, FLeft); - Result.Right := Result.Left + FWidth; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -// [IPK] -function TVirtualTreeColumn.GetText : string; - -begin - Result := FText; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumn.LoadFromStream(const Stream : TStream; Version : Integer); -var - Dummy : Integer; - S : string; - -begin - with Stream do - begin - ReadBuffer(Dummy, SizeOf(Dummy)); - SetLength(S, Dummy); - ReadBuffer(PWideChar(S)^, 2 * Dummy); - Text := S; - ReadBuffer(Dummy, SizeOf(Dummy)); - SetLength(FHint, Dummy); - ReadBuffer(PWideChar(FHint)^, 2 * Dummy); - ReadBuffer(Dummy, SizeOf(Dummy)); - Width := Dummy; - ReadBuffer(Dummy, SizeOf(Dummy)); - MinWidth := Dummy; - ReadBuffer(Dummy, SizeOf(Dummy)); - MaxWidth := Dummy; - ReadBuffer(Dummy, SizeOf(Dummy)); - Style := TVirtualTreeColumnStyle(Dummy); - ReadBuffer(Dummy, SizeOf(Dummy)); - ImageIndex := Dummy; - ReadBuffer(Dummy, SizeOf(Dummy)); - Layout := TVTHeaderColumnLayout(Dummy); - ReadBuffer(Dummy, SizeOf(Dummy)); - Margin := Dummy; - ReadBuffer(Dummy, SizeOf(Dummy)); - Spacing := Dummy; - ReadBuffer(Dummy, SizeOf(Dummy)); - BiDiMode := TBiDiMode(Dummy); - - ReadBuffer(Dummy, SizeOf(Dummy)); - if Version >= 3 then - Options := TVTColumnOptions(Dummy); - - if Version > 0 then - begin - // Parts which have been introduced/changed with header stream version 1+. - ReadBuffer(Dummy, SizeOf(Dummy)); - Tag := Dummy; - ReadBuffer(Dummy, SizeOf(Dummy)); - Alignment := TAlignment(Dummy); - - if Version > 1 then - begin - ReadBuffer(Dummy, SizeOf(Dummy)); - Color := TColor(Dummy); - end; - - if Version > 5 then - begin - if coUseCaptionAlignment in FOptions then - begin - ReadBuffer(Dummy, SizeOf(Dummy)); - CaptionAlignment := TAlignment(Dummy); - end; - end; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumn.ParentBiDiModeChanged; - -var - Columns : TVirtualTreeColumns; - -begin - if coParentBidiMode in FOptions then - begin - Columns := GetOwner as TVirtualTreeColumns; - if Assigned(Columns) and (FBiDiMode <> TreeViewControl.BiDiMode) then - begin - FBiDiMode := TreeViewControl.BiDiMode; - Changed(False); - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumn.ParentColorChanged; - -var - Columns : TVirtualTreeColumns; - -begin - if coParentColor in FOptions then - begin - Columns := GetOwner as TVirtualTreeColumns; - if Assigned(Columns) and (FColor <> TreeViewControl.Color) then - begin - FColor := TreeViewControl.Color; - Changed(False); - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumn.RestoreLastWidth; - -begin - TVirtualTreeColumns(GetOwner).AnimatedResize(Index, FLastWidth); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumn.SaveToStream(const Stream : TStream); - -var - Dummy : Integer; - -begin - with Stream do - begin - Dummy := Length(FText); - WriteBuffer(Dummy, SizeOf(Dummy)); - WriteBuffer(PWideChar(FText)^, 2 * Dummy); - Dummy := Length(FHint); - WriteBuffer(Dummy, SizeOf(Dummy)); - WriteBuffer(PWideChar(FHint)^, 2 * Dummy); - WriteBuffer(FWidth, SizeOf(FWidth)); - WriteBuffer(FMinWidth, SizeOf(FMinWidth)); - WriteBuffer(FMaxWidth, SizeOf(FMaxWidth)); - Dummy := Ord(FStyle); - WriteBuffer(Dummy, SizeOf(Dummy)); - Dummy := FImageIndex; - WriteBuffer(Dummy, SizeOf(Dummy)); - Dummy := Ord(FLayout); - WriteBuffer(Dummy, SizeOf(Dummy)); - WriteBuffer(FMargin, SizeOf(FMargin)); - WriteBuffer(FSpacing, SizeOf(FSpacing)); - Dummy := Ord(FBiDiMode); - WriteBuffer(Dummy, SizeOf(Dummy)); - Dummy := Integer(FOptions); - WriteBuffer(Dummy, SizeOf(Dummy)); - - // parts introduced with stream version 1 - WriteBuffer(FTag, SizeOf(Dummy)); - Dummy := Cardinal(FAlignment); - WriteBuffer(Dummy, SizeOf(Dummy)); - - // parts introduced with stream version 2 - Dummy := Integer(FColor); - WriteBuffer(Dummy, SizeOf(Dummy)); - - // parts introduced with stream version 6 - if coUseCaptionAlignment in FOptions then - begin - Dummy := Cardinal(FCaptionAlignment); - WriteBuffer(Dummy, SizeOf(Dummy)); - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVirtualTreeColumn.UseRightToLeftReading : Boolean; - -begin - Result := FBiDiMode <> bdLeftToRight; -end; - -//----------------- TVirtualTreeColumns -------------------------------------------------------------------------------- - -constructor TVirtualTreeColumns.Create(AOwner : TVTHeader); - -var - ColumnClass : TVirtualTreeColumnClass; - -begin - FHeader := AOwner; - - // Determine column class to be used in the header. - ColumnClass := Self.TreeViewControl.GetColumnClass; - // The owner tree always returns the default tree column class if not changed by application/descendants. - inherited Create(ColumnClass); - - FHeaderBitmap := TBitmap.Create; - FHeaderBitmap.PixelFormat := pf32Bit; - - FHoverIndex := NoColumn; - FDownIndex := NoColumn; - FClickIndex := NoColumn; - FDropTarget := NoColumn; - FTrackIndex := NoColumn; - FDefaultWidth := 50; - Self.FColumnPopupMenu := nil; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -destructor TVirtualTreeColumns.Destroy; - -begin - FreeAndNil(FColumnPopupMenu); - FreeAndNil(FHeaderBitmap); - inherited; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVirtualTreeColumns.GetCount : Integer; - -begin - Result := inherited Count; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVirtualTreeColumns.GetItem(Index : TColumnIndex) : TVirtualTreeColumn; - -begin - Result := TVirtualTreeColumn(inherited GetItem(Index)); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVirtualTreeColumns.GetNewIndex(P : TPoint; var OldIndex : TColumnIndex) : Boolean; - -var - NewIndex : Integer; - -begin - Result := False; - // convert to local coordinates - Inc(P.Y, Header.Height); - NewIndex := ColumnFromPosition(P); - if NewIndex <> OldIndex then - begin - if OldIndex > NoColumn then - Header.Invalidate(Items[OldIndex], False, True); - OldIndex := NewIndex; - if OldIndex > NoColumn then - Header.Invalidate(Items[OldIndex], False, True); - Result := True; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumns.SetDefaultWidth(Value : Integer); - -begin - FDefaultWidth := Value; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumns.SetItem(Index : TColumnIndex; Value : TVirtualTreeColumn); - -begin - inherited SetItem(Index, Value); -end; - -function TVirtualTreeColumns.StyleServices(AControl : TControl) : TCustomStyleServices; -begin - if AControl = nil then - AControl := TreeView; - Result := VTStyleServices(AControl); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumns.AdjustAutoSize(CurrentIndex : TColumnIndex; Force : Boolean = False); - -// Called only if the header is in auto-size mode which means a column needs to be so large -// that it fills all the horizontal space not occupied by the other columns. -// CurrentIndex (if not InvalidColumn) describes which column has just been resized. - -var - NewValue, - AutoIndex, - Index, - RestWidth : Integer; - WasUpdating : Boolean; -begin - if Count > 0 then - begin - // Determine index to be used for auto resizing. This is usually given by the owner's AutoSizeIndex, but - // could be different if the column whose resize caused the invokation here is either the auto column itself - // or visually to the right of the auto size column. - AutoIndex := Header.AutoSizeIndex; - if (AutoIndex < 0) or (AutoIndex >= Count) then - AutoIndex := Count - 1; - - if AutoIndex >= 0 then - begin - with TreeView do - begin - if HandleAllocated then - RestWidth := ClientWidth - else - RestWidth := Width; - end; - - // Go through all columns and calculate the rest space remaining. - for Index := 0 to Count - 1 do - if (Index <> AutoIndex) and (coVisible in Items[Index].Options) then - Dec(RestWidth, Items[Index].Width); - - with Items[AutoIndex] do - begin - NewValue := Max(MinWidth, Min(MaxWidth, RestWidth)); - if Force or (FWidth <> NewValue) then - begin - FWidth := NewValue; - UpdatePositions; - WasUpdating := csUpdating in TreeViewControl.ComponentState; - if not WasUpdating then - TreeViewControl.Updating(); // Fixes #398 - try - TreeViewControl.DoColumnResize(AutoIndex); - finally - if not WasUpdating then - TreeViewControl.Updated(); - end; - end; - end; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVirtualTreeColumns.AdjustDownColumn(P : TPoint) : TColumnIndex; - -// Determines the column from the given position and returns it. If this column is allowed to be clicked then -// it is also kept for later use. - -begin - // Convert to local coordinates. - Inc(P.Y, Header.Height); - Result := ColumnFromPosition(P); - if (Result > NoColumn) and (Result <> FDownIndex) and (coAllowClick in Items[Result].Options) and - (coEnabled in Items[Result].Options) then - begin - if FDownIndex > NoColumn then - Header.Invalidate(Items[FDownIndex]); - FDownIndex := Result; - FCheckBoxHit := Items[Result].HasImage and PtInRect(Items[Result].ImageRect, P) and Items[Result].CheckBox; - Header.Invalidate(Items[FDownIndex]); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVirtualTreeColumns.AdjustHoverColumn(P : TPoint) : Boolean; - -// Determines the new hover column index and returns True if the index actually changed else False. - -begin - Result := GetNewIndex(P, FHoverIndex); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumns.AdjustPosition(Column : TVirtualTreeColumn; Position : Cardinal); - -// Reorders the column position array so that the given column gets the given position. - -var - OldPosition : Cardinal; - -begin - OldPosition := Column.Position; - if OldPosition <> Position then - begin - if OldPosition < Position then - begin - // column will be moved up so move down other entries - Move(FPositionToIndex[OldPosition + 1], FPositionToIndex[OldPosition], (Position - OldPosition) * SizeOf(Cardinal)); - end - else - begin - // column will be moved down so move up other entries - Move(FPositionToIndex[Position], FPositionToIndex[Position + 1], (OldPosition - Position) * SizeOf(Cardinal)); - end; - FPositionToIndex[Position] := Column.Index; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVirtualTreeColumns.CanSplitterResize(P : TPoint; Column : TColumnIndex) : Boolean; - -begin - Result := (Column > NoColumn) and ([coResizable, coVisible] * Items[Column].Options = [coResizable, coVisible]); - DoCanSplitterResize(P, Column, Result); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumns.DoCanSplitterResize(P : TPoint; Column : TColumnIndex; var Allowed : Boolean); - -begin - if Assigned(TreeViewControl.OnCanSplitterResizeColumn) then - TreeViewControl.OnCanSplitterResizeColumn(Header, P, Column, Allowed); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumns.DrawButtonText(DC : HDC; Caption : string; Bounds : TRect; Enabled, Hot : Boolean; - DrawFormat : Cardinal; WrapCaption : Boolean); - -var - TextSpace : Integer; - Size : TSize; - -begin - if not WrapCaption then - begin - // Do we need to shorten the caption due to limited space? - GetTextExtentPoint32W(DC, PWideChar(Caption), Length(Caption), Size); - TextSpace := Bounds.Right - Bounds.Left; - if TextSpace < Size.cx then - Caption := ShortenString(DC, Caption, TextSpace); - end; - - SetBkMode(DC, TRANSPARENT); - if not Enabled then - if TreeViewControl.VclStyleEnabled then - begin - SetTextColor(DC, ColorToRGB(TreeViewControl.Colors.HeaderFontColor)); - WinApi.Windows.DrawTextW(DC, PWideChar(Caption), Length(Caption), Bounds, DrawFormat); - end - else - begin - OffsetRect(Bounds, 1, 1); - SetTextColor(DC, ColorToRGB(clBtnHighlight)); - WinApi.Windows.DrawTextW(DC, PWideChar(Caption), Length(Caption), Bounds, DrawFormat); - OffsetRect(Bounds, - 1, - 1); - SetTextColor(DC, ColorToRGB(clBtnShadow)); - WinApi.Windows.DrawTextW(DC, PWideChar(Caption), Length(Caption), Bounds, DrawFormat); - end - else - begin - if Hot then - SetTextColor(DC, ColorToRGB(TreeViewControl.Colors.HeaderHotColor)) - else - SetTextColor(DC, ColorToRGB(TreeViewControl.Colors.HeaderFontColor)); - WinApi.Windows.DrawTextW(DC, PWideChar(Caption), Length(Caption), Bounds, DrawFormat); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumns.FixPositions; - -// Fixes column positions after loading from DFM or Bidi mode change. - -var - I : Integer; - -begin - for I := 0 to Count - 1 do - FPositionToIndex[Items[I].Position] := I; - - FNeedPositionsFix := False; - UpdatePositions(True); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVirtualTreeColumns.GetColumnAndBounds(P : TPoint; var ColumnLeft, ColumnRight : Integer; - Relative : Boolean = True) : Integer; - -// Returns the column where the mouse is currently in as well as the left and right bound of -// this column (Left and Right are undetermined if no column is involved). - -var - I : Integer; - -begin - Result := InvalidColumn; - if Relative and (P.X >= Header.Columns.GetVisibleFixedWidth) then - ColumnLeft := - TreeViewControl.EffectiveOffsetX - else - ColumnLeft := 0; - - if TreeViewControl.UseRightToLeftAlignment then - Inc(ColumnLeft, TreeViewControl.ComputeRTLOffset(True)); - - for I := 0 to Count - 1 do - with Items[FPositionToIndex[I]] do - if coVisible in FOptions then - begin - ColumnRight := ColumnLeft + FWidth; - - //fix: in right to left alignment, X can be in the - //area on the left of first column which is OUT. - if (P.X < ColumnLeft) and (I = 0) then - begin - Result := InvalidColumn; - Exit; - end; - if P.X < ColumnRight then - begin - Result := FPositionToIndex[I]; - Exit; - end; - ColumnLeft := ColumnRight; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVirtualTreeColumns.GetOwner : TPersistent; - -begin - Result := FHeader; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVirtualTreeColumns.HandleClick(P : TPoint; Button : TMouseButton; Force, DblClick : Boolean) : Boolean; - -// Generates a click event if the mouse button has been released over the same column it was pressed first. -// Alternatively, Force might be set to True to indicate that the down index does not matter (right, middle and -// double click). -// Returns true if the click was handled, False otherwise. - -var - HitInfo : TVTHeaderHitInfo; - NewClickIndex : Integer; - Menu : TPopupMenu; -begin - Result := False; - if (csDesigning in TreeViewControl.ComponentState) then - Exit; - // Convert vertical position to local coordinates. - Inc(P.Y, Header.Height); - NewClickIndex := ColumnFromPosition(P); - with HitInfo do - begin - X := P.X; - Y := P.Y; - Shift := Header.GetShiftState; - if DblClick then - Shift := Shift + [ssDouble]; - end; - HitInfo.Button := Button; - - if (NewClickIndex > NoColumn) and (coAllowClick in Items[NewClickIndex].Options) and - ((NewClickIndex = FDownIndex) or Force) then - begin - FClickIndex := NewClickIndex; - HitInfo.Column := NewClickIndex; - HitInfo.HitPosition := [hhiOnColumn]; - - if Items[NewClickIndex].HasImage and PtInRect(Items[NewClickIndex].ImageRect, P) then - begin - Include(HitInfo.HitPosition, hhiOnIcon); - if Items[NewClickIndex].CheckBox then - begin - if Button = mbLeft then - TreeViewControl.UpdateColumnCheckState(Items[NewClickIndex]); - Include(HitInfo.HitPosition, hhiOnCheckbox); - end; - end; - end - else - begin - FClickIndex := NoColumn; - HitInfo.Column := NoColumn; - HitInfo.HitPosition := [hhiNoWhere]; - end; - - if DblClick then - TreeViewControl.DoHeaderDblClick(HitInfo) - else - begin - if (hoHeaderClickAutoSort in Header.Options) and (HitInfo.Button = mbLeft) and not (hhiOnCheckbox in HitInfo.HitPosition) and (HitInfo.Column >= 0) then - begin - // handle automatic setting of SortColumn and toggling of the sort order - if HitInfo.Column <> Header.SortColumn then - begin - // set sort column - Header.DoSetSortColumn(HitInfo.Column, Self[HitInfo.Column].DefaultSortDirection); - end//if - else - begin - // toggle sort direction - if Header.SortDirection = sdDescending then - Header.SortDirection := sdAscending - else - Header.SortDirection := sdDescending; - end; //else - Result := True; - end; //if - - if (Button = mbRight) then - begin - Dec(P.Y, Header.Height); // popup menus at actual clicked point - FreeAndNil(FColumnPopupMenu); // Attention: Do not free the TVTHeaderPopupMenu at the end of this method, otherwise the clikc events of the menu item will not be fired. - Self.FDownIndex := NoColumn; - Self.FTrackIndex := NoColumn; - Self.FCheckBoxHit := False; - Menu := Header.DoGetPopupMenu(Self.ColumnFromPosition(Point(P.X, P.Y + Integer(TreeViewControl.Height))), P); - if Assigned(Menu) then - begin - TreeViewControl.StopTimer(ScrollTimer); - TreeViewControl.StopTimer(HeaderTimer); - Header.Columns.SetHoverIndex(NoColumn); - TreeViewControl.DoStateChange([], [tsScrollPending, tsScrolling]); - - Menu.PopupComponent := TreeView; - With TreeViewControl.ClientToScreen(P) do - Menu.Popup(X, Y); - Result := True; - end - else if (hoAutoColumnPopupMenu in Header.Options) then - begin - FColumnPopupMenu := TVTHeaderPopupMenu.Create(TreeView); - TVTHeaderPopupMenu(FColumnPopupMenu).OnAddHeaderPopupItem := HeaderPopupMenuAddHeaderPopupItem; - FColumnPopupMenu.PopupComponent := TreeView; - if (hoDblClickResize in Header.Options) and ((TreeViewControl.ChildCount[nil] > 0) or (hoAutoResizeInclCaption in Header.Options)) then - TVTHeaderPopupMenu(FColumnPopupMenu).Options := TVTHeaderPopupMenu(FColumnPopupMenu).Options + [poResizeToFitItem] - else - TVTHeaderPopupMenu(FColumnPopupMenu).Options := TVTHeaderPopupMenu(FColumnPopupMenu).Options - [poResizeToFitItem]; - With TreeViewControl.ClientToScreen(P) do - FColumnPopupMenu.Popup(X, Y); - Result := True; - end; // if hoAutoColumnPopupMenu - end; //if mbRight - TreeViewControl.DoHeaderClick(HitInfo); - end; //else (not DblClick) - - if not (hhiNoWhere in HitInfo.HitPosition) then - Header.Invalidate(Items[NewClickIndex]); - if (FClickIndex > NoColumn) and (FClickIndex <> NewClickIndex) then - Header.Invalidate(Items[FClickIndex]); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumns.HeaderPopupMenuAddHeaderPopupItem(const Sender : TObject; const Column : TColumnIndex; var Cmd : TAddPopupItemType); -begin - TBaseVirtualTreeCracker(Sender).DoHeaderAddPopupItem(Column, Cmd); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumns.IndexChanged(OldIndex, NewIndex : Integer); - -// Called by a column when its index in the collection changes. If NewIndex is -1 then the column is -// about to be removed, otherwise it is moved to a new index. -// The method will then update the position array to reflect the change. - -var - I : Integer; - Increment : Integer; - Lower, - Upper : Integer; - -begin - if NewIndex = - 1 then - begin - // Find position in the array with the old index. - Upper := High(FPositionToIndex); - for I := 0 to Upper do - begin - if FPositionToIndex[I] = OldIndex then - begin - // Index found. Move all higher entries one step down and remove the last entry. - if I < Upper then - Move(FPositionToIndex[I + 1], FPositionToIndex[I], (Upper - I) * SizeOf(TColumnIndex)); - end; - // Decrease all indices, which are greater than the index to be deleted. - if FPositionToIndex[I] > OldIndex then - Dec(FPositionToIndex[I]); - end; - SetLength(FPositionToIndex, High(FPositionToIndex)); - end - else - begin - if OldIndex < NewIndex then - Increment := - 1 - else - Increment := 1; - - Lower := Min(OldIndex, NewIndex); - Upper := Max(OldIndex, NewIndex); - for I := 0 to High(FPositionToIndex) do - begin - if (FPositionToIndex[I] >= Lower) and (FPositionToIndex[I] < Upper) then - Inc(FPositionToIndex[I], Increment) - else - if FPositionToIndex[I] = OldIndex then - FPositionToIndex[I] := NewIndex; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumns.InitializePositionArray; - -// Ensures that the column position array contains as many entries as columns are defined. -// The array is resized and initialized with default values if needed. - -var - I, OldSize : Integer; - Changed : Boolean; - -begin - if Count <> Length(FPositionToIndex) then - begin - OldSize := Length(FPositionToIndex); - SetLength(FPositionToIndex, Count); - if Count > OldSize then - begin - // New items have been added, just set their position to the same as their index. - for I := OldSize to Count - 1 do - FPositionToIndex[I] := I; - end - else - begin - // Items have been deleted, so reindex remaining entries by decrementing values larger than the highest - // possible index until no entry is higher than this limit. - repeat - Changed := False; - for I := 0 to Count - 1 do - if FPositionToIndex[I] >= Count then - begin - Dec(FPositionToIndex[I]); - Changed := True; - end; - until not Changed; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumns.Notify(Item : TCollectionItem; Action : System.Classes.TCollectionNotification); -var - I : Integer; - lRemovedPosition: TColumnPosition; -begin - if Action in [cnDeleting] then - begin - lRemovedPosition := TVirtualTreeColumn(Item).Position; - // Adjust all positions larger than the deleted column's position. Fixes #959, #1049 - for I := Count - 1 downto 0 do - begin - if Items[I].Position > lRemovedPosition then - Items[I].Position := Items[I].Position - 1; - end; //for I - - with TreeViewControl do - if not (csLoading in ComponentState) and (FocusedColumn = Item.Index) then - InternalSetFocusedColumn(NoColumn); //bypass side effects in SetFocusedColumn - end; // if cnDeleting -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumns.ReorderColumns(RTL : Boolean); - -var - I : Integer; - -begin - if RTL then - begin - for I := 0 to Count - 1 do - FPositionToIndex[I] := Count - I - 1; - end - else - begin - for I := 0 to Count - 1 do - FPositionToIndex[I] := I; - end; - - UpdatePositions(True); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumns.SetHoverIndex(Index : TColumnIndex); -begin - FHoverIndex := index; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumns.EndUpdate; -begin - InitializePositionArray(); - FixPositions(); // Accept the cuurent order. See issue #753 - inherited; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumns.Update(Item : TCollectionItem); - -begin - // This is the only place which gets notified when a new column has been added or removed - // and we need this event to adjust the column position array. - InitializePositionArray; - if csLoading in TreeViewControl.ComponentState then - FNeedPositionsFix := True - else - UpdatePositions; - - // The first column which is created is by definition also the main column. - if (Count > 0) and (Header.MainColumn < 0) then - Header.MainColumn := 0; - - if not (csLoading in TreeViewControl.ComponentState) and not (hsLoading in Header.States) then - begin - with Header do - begin - if hoAutoResize in Options then - AdjustAutoSize(InvalidColumn); - if Assigned(Item) then - Invalidate(Item as TVirtualTreeColumn) - else - if Self.TreeViewControl.HandleAllocated then - begin - Self.TreeViewControl.UpdateHorizontalScrollBar(False); - Invalidate(nil); - TreeViewControl.Invalidate; - end; - - if not (Self.TreeViewControl.IsUpdating) then - // This is mainly to let the designer know when a change occurs at design time which - // doesn't involve the object inspector (like column resizing with the mouse). - // This does NOT include design time code as the communication is done via an interface. - Self.TreeViewControl.UpdateDesigner; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumns.UpdatePositions(Force : Boolean = False); - -// Recalculates the left border of every column and updates their position property according to the -// PostionToIndex array which primarily determines where each column is placed visually. - -var - I, RunningPos : Integer; - -begin - if not (csDestroying in TreeViewControl.ComponentState) and not FNeedPositionsFix and (Force or (UpdateCount = 0)) then - begin - RunningPos := 0; - for I := 0 to High(FPositionToIndex) do - with Items[FPositionToIndex[I]] do - begin - FPosition := I; - FLeft := RunningPos; - if coVisible in FOptions then - Inc(RunningPos, FWidth); - end; - TreeViewControl.UpdateHorizontalScrollBar(False); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVirtualTreeColumns.Add : TVirtualTreeColumn; - -begin - Assert(GetCurrentThreadId = MainThreadId, 'UI controls may only be changed in UI thread.'); - Result := TVirtualTreeColumn(inherited Add); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumns.AnimatedResize(Column : TColumnIndex; NewWidth : Integer); - -// Resizes the given column animated by scrolling the window DC. - -var - OldWidth : Integer; - DC : HDC; - I, - Steps, - DX : Integer; - HeaderScrollRect, - ScrollRect, - R : TRect; - - NewBrush, - LastBrush : HBRUSH; - -begin - if not IsValidColumn(Column) then - Exit; // Just in case. - - // Make sure the width constrains are considered. - if NewWidth < Items[Column].MinWidth then - NewWidth := Items[Column].MinWidth; - if NewWidth > Items[Column].MaxWidth then - NewWidth := Items[Column].MaxWidth; - - OldWidth := Items[Column].Width; - // Nothing to do if the width is the same. - if OldWidth <> NewWidth then - begin - if not ((hoDisableAnimatedResize in Header.Options) or - (coDisableAnimatedResize in Items[Column].Options)) then - begin - DC := GetWindowDC(TreeViewControl.Handle); - with TreeViewControl do - try - Steps := 32; - DX := (NewWidth - OldWidth) div Steps; - - // Determination of the scroll rectangle is a bit complicated since we neither want - // to scroll the scrollbars nor the border of the treeview window. - HeaderScrollRect := HeaderRect; - ScrollRect := HeaderScrollRect; - // Exclude the header itself from scrolling. - ScrollRect.Top := ScrollRect.Bottom; - ScrollRect.Bottom := ScrollRect.Top + ClientHeight; - ScrollRect.Right := ScrollRect.Left + ClientWidth; - with Items[Column] do - Inc(ScrollRect.Left, FLeft + FWidth); - HeaderScrollRect.Left := ScrollRect.Left; - HeaderScrollRect.Right := ScrollRect.Right; - - // When the new width is larger then avoid artefacts on the left hand side - // by deleting a small stripe - if NewWidth > OldWidth then - begin - R := ScrollRect; - NewBrush := CreateSolidBrush(ColorToRGB(Color)); - LastBrush := SelectObject(DC, NewBrush); - R.Right := R.Left + DX; - FillRect(DC, R, NewBrush); - SelectObject(DC, LastBrush); - DeleteObject(NewBrush); - end - else - begin - Inc(HeaderScrollRect.Left, DX); - Inc(ScrollRect.Left, DX); - end; - - for I := 0 to Steps - 1 do - begin - ScrollDC(DC, DX, 0, HeaderScrollRect, HeaderScrollRect, 0, nil); - Inc(HeaderScrollRect.Left, DX); - ScrollDC(DC, DX, 0, ScrollRect, ScrollRect, 0, nil); - Inc(ScrollRect.Left, DX); - Sleep(1); - end; - finally - ReleaseDC(Handle, DC); - end; - end; - Items[Column].Width := NewWidth; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumns.Assign(Source : TPersistent); - -begin - // Let the collection class assign the items. - inherited; - - if Source is TVirtualTreeColumns then - begin - // Copying the position array is the only needed task here. - FPositionToIndex := Copy(TVirtualTreeColumns(Source).FPositionToIndex, 0, MaxInt); - - // Make sure the left edges are correct after assignment. - FNeedPositionsFix := False; - UpdatePositions(True); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumns.Clear; - -begin - FClearing := True; - try - TreeViewControl.CancelEditNode; - - // Since we're freeing all columns, the following have to be true when we're done. - FHoverIndex := NoColumn; - FDownIndex := NoColumn; - FTrackIndex := NoColumn; - FClickIndex := NoColumn; - FCheckBoxHit := False; - - with Header do - if not (hsLoading in States) then - begin - InternalSetAutoSizeIndex(NoColumn); //bypass side effects in SetAutoSizeColumn - MainColumn := NoColumn; - InternalSetSortColumn(NoColumn); //bypass side effects in SetSortColumn - end; - - with TreeViewControl do - if not (csLoading in ComponentState) then - InternalSetFocusedColumn(NoColumn); //bypass side effects in SetFocusedColumn - - inherited Clear; - finally - FClearing := False; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVirtualTreeColumns.ColumnFromPosition(P : TPoint; Relative : Boolean = True) : TColumnIndex; - -// Determines the current column based on the position passed in P. - -var - I, Sum : Integer; - -begin - Result := InvalidColumn; - - // The position must be within the header area, but we extend the vertical bounds to the entire treeview area. - if (P.X >= 0) and (P.Y >= 0) and (P.Y <= TreeViewControl.Height) then - with FHeader, TreeViewControl do - begin - if Relative and (P.X >= GetVisibleFixedWidth) then - Sum := - EffectiveOffsetX - else - Sum := 0; - - if UseRightToLeftAlignment then - Inc(Sum, ComputeRTLOffset(True)); - - for I := 0 to Count - 1 do - if coVisible in Items[FPositionToIndex[I]].Options then - begin - Inc(Sum, Items[FPositionToIndex[I]].Width); - if P.X < Sum then - begin - Result := FPositionToIndex[I]; - Break; - end; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVirtualTreeColumns.ColumnFromPosition(PositionIndex : TColumnPosition) : TColumnIndex; - -// Returns the index of the column at the given position. - -begin - if Integer(PositionIndex) < Length(FPositionToIndex) then - Result := FPositionToIndex[PositionIndex] - else - Result := NoColumn; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVirtualTreeColumns.Equals(OtherColumnsObj : TObject) : Boolean; - -// Compares itself with the given set of columns and returns True if all published properties are the same -// (including column order), otherwise False is returned. - -var - I : Integer; - OtherColumns : TVirtualTreeColumns; - -begin - if not (OtherColumnsObj is TVirtualTreeColumns) then - begin - Result := False; - Exit; - end; - - OtherColumns := TVirtualTreeColumns(OtherColumnsObj); - - // Same number of columns? - Result := OtherColumns.Count = Count; - if Result then - begin - // Same order of columns? - Result := CompareMem(Pointer(FPositionToIndex), Pointer(OtherColumns.FPositionToIndex), - Length(FPositionToIndex) * SizeOf(TColumnIndex)); - if Result then - begin - for I := 0 to Count - 1 do - if not Items[I].Equals(OtherColumns[I]) then - begin - Result := False; - Break; - end; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumns.GetColumnBounds(Column : TColumnIndex; var Left, Right : Integer); - -// Returns the left and right bound of the given column. If Column is NoColumn then the entire client width is returned. - -begin - if Column <= NoColumn then - begin - Left := 0; - Right := TreeViewControl.ClientWidth; - end - else - begin - Left := Items[Column].Left; - Right := Left + Items[Column].Width; - if TreeViewControl.UseRightToLeftAlignment then - begin - Inc(Left, TreeViewControl.ComputeRTLOffset(True)); - Inc(Right, TreeViewControl.ComputeRTLOffset(True)); - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVirtualTreeColumns.GetScrollWidth : Integer; - -// Returns the average width of all visible, non-fixed columns. If there is no such column the indent is returned. - -var - I : Integer; - ScrollColumnCount : Integer; - -begin - - Result := 0; - - ScrollColumnCount := 0; - for I := 0 to Header.Columns.Count - 1 do - begin - if ([coVisible, coFixed] * Header.Columns[I].Options = [coVisible]) then - begin - Inc(Result, Header.Columns[I].Width); - Inc(ScrollColumnCount); - end; - end; - - if ScrollColumnCount > 0 then // use average width - Result := Round(Result / ScrollColumnCount) - else // use indent - Result := Integer(TreeViewControl.Indent); - -end; - -function TVirtualTreeColumns.GetTreeView: TCustomControl; -begin - Result := TBaseVirtualTreeCracker(Header.GetOwner); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVirtualTreeColumns.GetFirstVisibleColumn(ConsiderAllowFocus : Boolean = False) : TColumnIndex; - -// Returns the index of the first visible column or "InvalidColumn" if either no columns are defined or -// all columns are hidden. -// If ConsiderAllowFocus is True then the column has not only to be visible but also focus has to be allowed. - -var - I : Integer; - -begin - Result := InvalidColumn; - if (UpdateCount > 0) or (csLoading in TreeViewControl.ComponentState) then - Exit; // See issue #760 - for I := 0 to Count - 1 do - if (coVisible in Items[FPositionToIndex[I]].Options) and - ((not ConsiderAllowFocus) or - (coAllowFocus in Items[FPositionToIndex[I]].Options) - ) then - begin - Result := FPositionToIndex[I]; - Break; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVirtualTreeColumns.GetLastVisibleColumn(ConsiderAllowFocus : Boolean = False) : TColumnIndex; - -// Returns the index of the last visible column or "InvalidColumn" if either no columns are defined or -// all columns are hidden. -// If ConsiderAllowFocus is True then the column has not only to be visible but also focus has to be allowed. - -var - I : Integer; - -begin - Result := InvalidColumn; - if (UpdateCount > 0) or (csLoading in TreeViewControl.ComponentState) then - Exit; // See issue #760 - for I := Count - 1 downto 0 do - if (coVisible in Items[FPositionToIndex[I]].Options) and - ((not ConsiderAllowFocus) or - (coAllowFocus in Items[FPositionToIndex[I]].Options) - ) then - begin - Result := FPositionToIndex[I]; - Break; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVirtualTreeColumns.GetFirstColumn : TColumnIndex; - -// Returns the first column in display order. - -begin - if Count = 0 then - Result := InvalidColumn - else - Result := FPositionToIndex[0]; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVirtualTreeColumns.GetNextColumn(Column : TColumnIndex) : TColumnIndex; - -// Returns the next column in display order. Column is the index of an item in the collection (a column). - -var - Position : Integer; - -begin - if Column < 0 then - Result := InvalidColumn - else - begin - Position := Items[Column].Position; - if Position < Count - 1 then - Result := FPositionToIndex[Position + 1] - else - Result := InvalidColumn; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVirtualTreeColumns.GetNextVisibleColumn(Column : TColumnIndex; ConsiderAllowFocus : Boolean = False) : TColumnIndex; - -// Returns the next visible column in display order, Column is an index into the columns list. -// If ConsiderAllowFocus is True then the column has not only to be visible but also focus has to be allowed. - -begin - Result := Column; - repeat - Result := GetNextColumn(Result); - until (Result = InvalidColumn) or - ((coVisible in Items[Result].Options) and - ((not ConsiderAllowFocus) or - (coAllowFocus in Items[Result].Options) - ) - ); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVirtualTreeColumns.GetPreviousColumn(Column : TColumnIndex) : TColumnIndex; - -// Returns the previous column in display order, Column is an index into the columns list. - -var - Position : Integer; - -begin - if Column < 0 then - Result := InvalidColumn - else - begin - Position := Items[Column].Position; - if Position > 0 then - Result := FPositionToIndex[Position - 1] - else - Result := InvalidColumn; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVirtualTreeColumns.GetPreviousVisibleColumn(Column : TColumnIndex; ConsiderAllowFocus : Boolean = False) : TColumnIndex; - -// Returns the previous visible column in display order, Column is an index into the columns list. -// If ConsiderAllowFocus is True then the column has not only to be visible but also focus has to be allowed. - -begin - Result := Column; - repeat - Result := GetPreviousColumn(Result); - until (Result = InvalidColumn) or - ((coVisible in Items[Result].Options) and - ((not ConsiderAllowFocus) or - (coAllowFocus in Items[Result].Options) - ) - ); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVirtualTreeColumns.GetVisibleColumns : TColumnsArray; - -// Returns a list of all currently visible columns in actual order. - -var - I, Counter : Integer; - -begin - SetLength(Result, Count); - Counter := 0; - - for I := 0 to Count - 1 do - if coVisible in Items[FPositionToIndex[I]].Options then - begin - Result[Counter] := Items[FPositionToIndex[I]]; - Inc(Counter); - end; - // Set result length to actual visible count. - SetLength(Result, Counter); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVirtualTreeColumns.GetVisibleFixedWidth : Integer; - -// Determines the horizontal space all visible and fixed columns occupy. - -var - I : Integer; - -begin - Result := 0; - for I := 0 to Count - 1 do - begin - if Items[I].Options * [coVisible, coFixed] = [coVisible, coFixed] then - Inc(Result, Items[I].Width); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVirtualTreeColumns.IsValidColumn(Column : TColumnIndex) : Boolean; - -// Determines whether the given column is valid or not, that is, whether it is one of the current columns. - -begin - Result := (Column > NoColumn) and (Column < Count); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumns.LoadFromStream(const Stream : TStream; Version : Integer); - -var - I, - ItemCount : Integer; - -begin - Clear; - Stream.ReadBuffer(ItemCount, SizeOf(ItemCount)); - // number of columns - if ItemCount > 0 then - begin - BeginUpdate; - try - for I := 0 to ItemCount - 1 do - Add.LoadFromStream(Stream, Version); - SetLength(FPositionToIndex, ItemCount); - Stream.ReadBuffer(FPositionToIndex[0], ItemCount * SizeOf(TColumnIndex)); - UpdatePositions(True); - finally - EndUpdate; - end; - end; - - // Data introduced with header stream version 5 - if Version > 4 then - Stream.ReadBuffer(FDefaultWidth, SizeOf(FDefaultWidth)); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumns.PaintHeader(DC : HDC; R : TRect; HOffset : Integer); - -// Backward compatible header paint method. This method takes care of visually moving floating columns - -var - VisibleFixedWidth : Integer; - RTLOffset : Integer; - - procedure PaintFixedArea; - - begin - if VisibleFixedWidth > 0 then - PaintHeader(FHeaderBitmap.Canvas, - Rect(0, 0, Min(R.Right, VisibleFixedWidth), R.Bottom - R.Top), - Point(R.Left, R.Top), RTLOffset); - end; - -begin - // Adjust size of the header bitmap - FHeaderBitmap.SetSize(Max(TreeViewControl.HeaderRect.Right, R.Right - R.Left), TreeViewControl.HeaderRect.Bottom); - - VisibleFixedWidth := GetVisibleFixedWidth; - - // Consider right-to-left directionality. - if TreeViewControl.UseRightToLeftAlignment then - RTLOffset := TreeViewControl.ComputeRTLOffset - else - RTLOffset := 0; - - if RTLOffset = 0 then - PaintFixedArea; - - // Paint the floating part of the header. - PaintHeader(FHeaderBitmap.Canvas, - Rect(VisibleFixedWidth - HOffset, 0, R.Right + VisibleFixedWidth - HOffset, R.Bottom - R.Top), - Point(R.Left + VisibleFixedWidth, R.Top), RTLOffset); - - // In case of right-to-left directionality we paint the fixed part last. - if RTLOffset <> 0 then - PaintFixedArea; - - // Blit the result to target. - BitBlt(DC, R.Left, R.Top, R.Right - R.Left, R.Bottom - R.Top, FHeaderBitmap.Canvas.Handle, R.Left, R.Top, SRCCOPY); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumns.PaintHeader(TargetCanvas : TCanvas; R : TRect; const Target : TPoint; - RTLOffset : Integer = 0); - -// Main paint method to draw the header. -// This procedure will paint the a slice (given in R) out of HeaderRect into TargetCanvas starting at position Target. -// This function does not offer the option to visually move floating columns due to scrolling. To accomplish this you -// need to call this method twice. - -var - Run : TColumnIndex; - RightBorderFlag, - NormalButtonStyle, - NormalButtonFlags, - PressedButtonStyle, - PressedButtonFlags, - RaisedButtonStyle, - RaisedButtonFlags : Cardinal; - Images : TCustomImageList; - OwnerDraw, - AdvancedOwnerDraw : Boolean; - PaintInfo : THeaderPaintInfo; - RequestedElements, - ActualElements : THeaderPaintElements; - - //--------------- local functions ------------------------------------------- - - procedure PrepareButtonStyles; - - // Prepare the button styles and flags for later usage. - - begin - RaisedButtonStyle := 0; - RaisedButtonFlags := 0; - case Header.Style of - hsThickButtons : - begin - NormalButtonStyle := BDR_RAISEDINNER or BDR_RAISEDOUTER; - NormalButtonFlags := BF_LEFT or BF_TOP or BF_BOTTOM or BF_MIDDLE or BF_SOFT or BF_ADJUST; - PressedButtonStyle := BDR_RAISEDINNER or BDR_RAISEDOUTER; - PressedButtonFlags := NormalButtonFlags or BF_RIGHT or BF_FLAT or BF_ADJUST; - end; - hsFlatButtons : - begin - NormalButtonStyle := BDR_RAISEDINNER; - NormalButtonFlags := BF_LEFT or BF_TOP or BF_BOTTOM or BF_MIDDLE or BF_ADJUST; - PressedButtonStyle := BDR_SUNKENOUTER; - PressedButtonFlags := BF_RECT or BF_MIDDLE or BF_ADJUST; - end; - else - // hsPlates or hsXPStyle, values are not used in the latter case - begin - NormalButtonStyle := BDR_RAISEDINNER; - NormalButtonFlags := BF_RECT or BF_MIDDLE or BF_SOFT or BF_ADJUST; - PressedButtonStyle := BDR_SUNKENOUTER; - PressedButtonFlags := BF_RECT or BF_MIDDLE or BF_ADJUST; - RaisedButtonStyle := BDR_RAISEDINNER; - RaisedButtonFlags := BF_LEFT or BF_TOP or BF_BOTTOM or BF_MIDDLE or BF_ADJUST; - end; - end; - end; - - //--------------------------------------------------------------------------- - - procedure DrawBackground; - - // Draw the header background. - - var - BackgroundRect : TRect; - Details : TThemedElementDetails; - Theme : HTHEME; - begin - BackgroundRect := Rect(Target.X, Target.Y, Target.X + R.Right - R.Left, Target.Y + Header.Height); - - with TargetCanvas do - begin - if hpeBackground in RequestedElements then - begin - PaintInfo.PaintRectangle := BackgroundRect; - TreeViewControl.DoAdvancedHeaderDraw(PaintInfo, [hpeBackground]); - end - else - begin - if (TreeViewControl.VclStyleEnabled and (seClient in TreeViewControl.StyleElements)) then - begin - Details := StyleServices.GetElementDetails(thHeaderItemRightNormal); - StyleServices.DrawElement(Handle, Details, BackgroundRect, @BackgroundRect {$IF CompilerVersion >= 34}, TreeViewControl.FCurrentPPI{$IFEND}); - end - else - if tsUseThemes in TreeViewControl.TreeStates then - begin - Theme := OpenThemeData(TreeViewControl.Handle, 'HEADER'); - DrawThemeBackground(Theme, Handle, HP_HEADERITEM, HIS_NORMAL, BackgroundRect, nil); - CloseThemeData(Theme); - end - else - begin - Brush.Color := Header.Background; - FillRect(BackgroundRect); - end; - end; - end; - end; - - //--------------------------------------------------------------------------- - - procedure PaintColumnHeader(AColumn : TColumnIndex; ATargetRect : TRect); - - // Draw a single column to TargetRect. The clipping rect needs to be set before - // this procedure is called. - - var - SavedDC : Integer; - ColCaptionText : string; - ColImageInfo : TVTImageInfo; - Glyph : TThemedHeader; - Details : TThemedElementDetails; - WrapCaption : Boolean; - DrawFormat : Cardinal; - Pos : TRect; - DrawHot : Boolean; - ImageWidth : Integer; - Theme : HTHEME; - IdState : Integer; - begin - ColImageInfo.Ghosted := False; - PaintInfo.Column := Items[AColumn]; - with PaintInfo, Column do - begin - IsHoverIndex := (AColumn = FHoverIndex) and (hoHotTrack in Header.Options) and (coEnabled in Options); - IsDownIndex := (AColumn = FDownIndex) and not FCheckBoxHit; - - if (coShowDropMark in FOptions) and (AColumn = FDropTarget) and (AColumn <> FDragIndex) then - begin - if FDropBefore then - DropMark := dmmLeft - else - DropMark := dmmRight; - end - else - DropMark := dmmNone; - - //Fix for issue 643 - //Do not show the left drop mark if the position to drop is just preceding the target which means - //the dragged column will stay where it is - if (DropMark = dmmLeft) and (Items[FDragIndex].Position = TColumnPosition(Max(Integer(Items[FDropTarget].Position) - 1, 0))) - then - DropMark := dmmNone - else - //Do not show the right drop mark if the position to drop is just following the target which means - //the dragged column will stay where it is - if (DropMark = dmmRight) and (Items[FDragIndex].Position = Items[FDropTarget].Position + 1) - then - DropMark := dmmNone; - - IsEnabled := (coEnabled in FOptions) and (TreeViewControl.Enabled); - ShowHeaderGlyph := (hoShowImages in Header.Options) and ((Assigned(Images) and (FImageIndex > - 1)) or FCheckBox); - ShowSortGlyph := (AColumn = Header.SortColumn) and (hoShowSortGlyphs in Header.Options); - WrapCaption := coWrapCaption in FOptions; - - PaintRectangle := ATargetRect; - - // This path for text columns or advanced owner draw. - if (Style = vsText) or not OwnerDraw or AdvancedOwnerDraw then - begin - // See if the application wants to draw part of the header itself. - RequestedElements := []; - if AdvancedOwnerDraw then - begin - PaintInfo.Column := Items[AColumn]; - TreeViewControl.DoHeaderDrawQueryElements(PaintInfo, RequestedElements); - end; - - if ShowRightBorder or (AColumn < Count - 1) then - RightBorderFlag := BF_RIGHT - else - RightBorderFlag := 0; - - if hpeBackground in RequestedElements then - TreeViewControl.DoAdvancedHeaderDraw(PaintInfo, [hpeBackground]) - else - begin - if TreeViewControl.VclStyleEnabled and (seClient in TreeViewControl.StyleElements) then - begin - if IsDownIndex then - Details := StyleServices.GetElementDetails(thHeaderItemPressed) - else - if IsHoverIndex then - Details := StyleServices.GetElementDetails(thHeaderItemHot) - else - Details := StyleServices.GetElementDetails(thHeaderItemNormal); - StyleServices.DrawElement(TargetCanvas.Handle, Details, PaintRectangle, @PaintRectangle{$IF CompilerVersion >= 34}, TreeViewControl.CurrentPPI{$IFEND}); - end - else - begin - if tsUseThemes in TreeViewControl.TreeStates then - begin - Theme := OpenThemeData(TreeViewControl.Handle, 'HEADER'); - if IsDownIndex then - IdState := HIS_PRESSED - else - if IsHoverIndex then - IdState := HIS_HOT - else - IdState := HIS_NORMAL; - DrawThemeBackground(Theme, TargetCanvas.Handle, HP_HEADERITEM, IdState, PaintRectangle, nil); - CloseThemeData(Theme); - end - else - if IsDownIndex then - DrawEdge(TargetCanvas.Handle, PaintRectangle, PressedButtonStyle, PressedButtonFlags) - else - // Plates have the special case of raising on mouse over. - if (Header.Style = hsPlates) and IsHoverIndex and - (coAllowClick in FOptions) and (coEnabled in FOptions) then - DrawEdge(TargetCanvas.Handle, PaintRectangle, RaisedButtonStyle, - RaisedButtonFlags or RightBorderFlag) - else - DrawEdge(TargetCanvas.Handle, PaintRectangle, NormalButtonStyle, - NormalButtonFlags or RightBorderFlag); - end; - end; - - PaintRectangle := ATargetRect; - - // calculate text and glyph position - InflateRect(PaintRectangle, - 2, - 2); - DrawFormat := DT_TOP or DT_NOPREFIX; - case CaptionAlignment of - taLeftJustify : - DrawFormat := DrawFormat or DT_LEFT; - taRightJustify : - DrawFormat := DrawFormat or DT_RIGHT; - taCenter : - DrawFormat := DrawFormat or DT_CENTER; - end; - if UseRightToLeftReading then - DrawFormat := DrawFormat + DT_RTLREADING; - ComputeHeaderLayout(PaintInfo, DrawFormat); - - // Move glyph and text one pixel to the right and down to simulate a pressed button. - if IsDownIndex then - begin - OffsetRect(TextRectangle, 1, 1); - Inc(GlyphPos.X); - Inc(GlyphPos.Y); - Inc(SortGlyphPos.X); - Inc(SortGlyphPos.Y); - end; - - // Advanced owner draw allows to paint elements, which would normally not be painted (because of space - // limitations, empty captions etc.). - ActualElements := RequestedElements * [hpeHeaderGlyph, hpeSortGlyph, hpeDropMark, hpeText, hpeOverlay]; - - // main glyph - FHasImage := False; - if Assigned(Images) then - ImageWidth := Images.Width - else - ImageWidth := 0; - - if not (hpeHeaderGlyph in ActualElements) and ShowHeaderGlyph and - (not ShowSortGlyph or (FBiDiMode <> bdLeftToRight) or (GlyphPos.X + ImageWidth <= SortGlyphPos.X)) then - begin - if not FCheckBox then - begin - ColImageInfo.Images := Images; - Images.Draw(TargetCanvas, GlyphPos.X, GlyphPos.Y, FImageIndex, IsEnabled); - end - else - begin - with TreeViewControl do - begin - ColImageInfo.Images := CheckImages; - ColImageInfo.Index := GetCheckImage(nil, FCheckType, FCheckState, IsEnabled); - ColImageInfo.XPos := GlyphPos.X; - ColImageInfo.YPos := GlyphPos.Y; - PaintCheckImage(TargetCanvas, ColImageInfo, False); - end; - end; - - FHasImage := True; - FImageRect.Left := GlyphPos.X; - FImageRect.Top := GlyphPos.Y; - FImageRect.Right := FImageRect.Left + ColImageInfo.Images.Width; - FImageRect.Bottom := FImageRect.Top + ColImageInfo.Images.Height; - end; - - // caption - if WrapCaption then - ColCaptionText := FCaptionText - else - ColCaptionText := Text; - if IsHoverIndex and TreeViewControl.VclStyleEnabled then - DrawHot := True - else - DrawHot := (IsHoverIndex and (hoHotTrack in Header.Options) and not (tsUseThemes in TreeViewControl.TreeStates)); - if not (hpeText in ActualElements) and (Length(Text) > 0) then - DrawButtonText(TargetCanvas.Handle, ColCaptionText, TextRectangle, IsEnabled, DrawHot, DrawFormat, WrapCaption); - - // sort glyph - if not (hpeSortGlyph in ActualElements) and ShowSortGlyph then - begin - if tsUseExplorerTheme in TreeViewControl.TreeStates then - begin - Pos.TopLeft := SortGlyphPos; - Pos.Right := Pos.Left + SortGlyphSize.cx; - Pos.Bottom := Pos.Top + SortGlyphSize.cy; - if Header.SortDirection = sdAscending then - Glyph := thHeaderSortArrowSortedUp - else - Glyph := thHeaderSortArrowSortedDown; - Details := StyleServices.GetElementDetails(Glyph); - if not StyleServices.DrawElement(TargetCanvas.Handle, Details, Pos, @Pos {$IF CompilerVersion >= 34}, TreeViewControl.CurrentPPI {$IFEND}) then - PaintInfo.DrawSortArrow(Header.SortDirection); - end - else - begin - PaintInfo.DrawSortArrow(Header.SortDirection); - end; - end; - - // Show an indication if this column is the current drop target in a header drag operation. - if not (hpeDropMark in ActualElements) and (DropMark <> dmmNone) then - begin - PaintInfo.DrawDropMark(); - end; - - if ActualElements <> [] then - begin - SavedDC := SaveDC(TargetCanvas.Handle); - TreeViewControl.DoAdvancedHeaderDraw(PaintInfo, ActualElements); - RestoreDC(TargetCanvas.Handle, SavedDC); - end; - end - else // Let application draw the header. - TreeViewControl.DoHeaderDraw(TargetCanvas, Items[AColumn], PaintRectangle, IsHoverIndex, IsDownIndex, - DropMark); - end; - end; - - //--------------- end local functions --------------------------------------- - -var - TargetRect : TRect; - MaxX : Integer; - -begin - if IsRectEmpty(R) then - Exit; - - // If both draw posibillities are specified then prefer the advanced way. - AdvancedOwnerDraw := (hoOwnerDraw in Header.Options) and Assigned(TreeViewControl.OnAdvancedHeaderDraw) and - Assigned(TreeViewControl.OnHeaderDrawQueryElements) and not (csDesigning in TreeViewControl.ComponentState); - OwnerDraw := (hoOwnerDraw in Header.Options) and Assigned(TreeViewControl.OnHeaderDraw) and - not (csDesigning in TreeViewControl.ComponentState) and not AdvancedOwnerDraw; - - ZeroMemory(@PaintInfo, SizeOf(PaintInfo)); - PaintInfo.TargetCanvas := TargetCanvas; - - with PaintInfo, TargetCanvas do - begin - // Use shortcuts for the images and the font. - Images := Header.Images; - Font := Header.Font; - - PrepareButtonStyles; - - // At first, query the application which parts of the header it wants to draw on its own. - RequestedElements := []; - if AdvancedOwnerDraw then - begin - PaintRectangle := R; - Column := nil; - TreeViewControl.DoHeaderDrawQueryElements(PaintInfo, RequestedElements); - end; - - // Draw the background. - DrawBackground; - - // Now that we have drawn the background, we apply the header's dimensions to R. - R := Rect(Max(R.Left, 0), Max(R.Top, 0), Min(R.Right, TotalWidth), Min(R.Bottom, Header.Height)); - - // Determine where to stop. - MaxX := Target.X + R.Right - R.Left - //Fixes issues #544, #427 -- MaxX should also shift on BidiMode bdRightToLeft - + RTLOffset; //added for fix - - // Determine the start column. - Run := ColumnFromPosition(Point(R.Left + RTLOffset, 0), False); - if Run <= NoColumn then - Exit; - - TargetRect.Top := Target.Y; - TargetRect.Bottom := Target.Y + R.Bottom - R.Top; - TargetRect.Left := Target.X - R.Left + Items[Run].FLeft + RTLOffset; - // TargetRect.Right will be set in the loop - - ShowRightBorder := (Header.Style = hsThickButtons) or not (hoAutoResize in Header.Options) or (TreeViewControl.BevelKind = bkNone); - - // Now go for each button. - while (Run > NoColumn) and (TargetRect.Left < MaxX) do - begin - TargetRect.Right := TargetRect.Left + Items[Run].Width; - - // create a clipping rect to limit painting to button area - ClipCanvas(TargetCanvas, Rect(Max(TargetRect.Left, Target.X), Target.Y + R.Top, - Min(TargetRect.Right, MaxX), TargetRect.Bottom)); - - PaintColumnHeader(Run, TargetRect); - - SelectClipRgn(Handle, 0); - - TargetRect.Left := TargetRect.Right; - Run := GetNextVisibleColumn(Run); - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumns.SaveToStream(const Stream : TStream); - -var - I : Integer; - -begin - I := Count; - Stream.WriteBuffer(I, SizeOf(I)); - if I > 0 then - begin - for I := 0 to Count - 1 do - TVirtualTreeColumn(Items[I]).SaveToStream(Stream); - - Stream.WriteBuffer(FPositionToIndex[0], Count * SizeOf(TColumnIndex)); - end; - - // Data introduced with header stream version 5. - Stream.WriteBuffer(DefaultWidth, SizeOf(DefaultWidth)); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVirtualTreeColumns.TotalWidth : Integer; - -var - LastColumn : TColumnIndex; - -begin - Result := 0; - if (Count > 0) and (Length(FPositionToIndex) > 0) then - begin - LastColumn := FPositionToIndex[Count - 1]; - if not (coVisible in Items[LastColumn].Options) then - LastColumn := GetPreviousVisibleColumn(LastColumn); - if LastColumn > NoColumn then - with Items[LastColumn] do - Result := FLeft + FWidth; - end; -end; - -{ THeaderPaintInfo } - -procedure THeaderPaintInfo.DrawDropMark(); -var - Y : Integer; - lArrowWidth : Integer; -begin - lArrowWidth := TBaseVirtualTreeCracker(Self.Column.TreeViewControl).ScaledPixels(5); - Y := (PaintRectangle.Top + PaintRectangle.Bottom - 3 * lArrowWidth) div 2; - if DropMark = dmmLeft then - DrawArrow(TargetCanvas, TScrollDirection.sdLeft, Point(PaintRectangle.Left, Y), lArrowWidth) - else - DrawArrow(TargetCanvas, TScrollDirection.sdRight, Point(PaintRectangle.Right - lArrowWidth - (lArrowWidth div 2) {spacing}, Y), lArrowWidth); -end; - -procedure THeaderPaintInfo.DrawSortArrow(pDirection : TSortDirection); -const - cDirection : array [TSortDirection] of TScrollDirection = (TScrollDirection.sdUp, TScrollDirection.sdDown); -var - lOldColor : TColor; -begin - lOldColor := TargetCanvas.Pen.Color; - TargetCanvas.Pen.Color := clDkGray; - DrawArrow(TargetCanvas, cDirection[pDirection], Point(SortGlyphPos.X, SortGlyphPos.Y), SortGlyphSize.cy); - TargetCanvas.Pen.Color := lOldColor; -end; - -{ TVirtualTreeColumnHelper } - -function TVirtualTreeColumnHelper.Header : TVTHeader; -begin - Result := Owner.Header; -end; - -function TVirtualTreeColumnHelper.TreeViewControl : TBaseVirtualTreeCracker; -begin - Result := TBaseVirtualTreeCracker(Owner.Header.GetOwner); -end; - -{ TVirtualTreeColumnsHelper } - -function TVirtualTreeColumnsHelper.TreeViewControl : TBaseVirtualTreeCracker; -begin - Result := TBaseVirtualTreeCracker(Header.GetOwner); -end; - - -end. diff --git a/components/virtualtreeview/Source/VirtualTrees.HeaderPopup.dtx b/components/virtualtreeview/Source/VirtualTrees.HeaderPopup.dtx index b198cb9a..edadce6d 100644 --- a/components/virtualtreeview/Source/VirtualTrees.HeaderPopup.dtx +++ b/components/virtualtreeview/Source/VirtualTrees.HeaderPopup.dtx @@ -1,54 +1,54 @@ - -@@TVirtualTreeCast -Necessary to make the header accessible. - - -@@TVTHeaderPopupOption.poAllowHideAll -Allows to hide all columns, including the last one. - -@@TVTHeaderPopupOption.poOriginalOrder -Show menu items in original column order as they were added to the tree. - -@@VTHeaderPopup.pas -The contents of this file are subject to the Mozilla Public License -Version 1.1 (the "License"); you may not use this file except in -compliance with the License. You may obtain a copy of the License at -http://www.mozilla.org/MPL/ - -Alternatively, you may redistribute this library, use and/or modify it under the terms of the -GNU Lesser General Public License as published by the Free Software Foundation; -either version 2.1 of the License, or (at your option) any later version. -You may obtain a copy of the LGPL at http://www.gnu.org/copyleft/. - -Software distributed under the License is distributed on an "AS IS" -basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the -License for the specific language governing rights and limitations -under the License. - -The Original Code is VTHeaderPopup.pas. - -The Initial Developer of the Original Code is Ralf Junker . All Rights Reserved. - -Modified 14 Sep 2003 by Mike Lischke . - - Renamed event type name to be consistent with other event types (e.g. used in VT). - - Added event for hiding/showing columns. - - DoXXX method are now virtual. - - Conditional code rearrangement to get back Ctrl+Shift+Up/Down navigation back. -Modified 31 Mar 2003 by Mike Lischke . - Added a check for the PopupComponent property before casting it hardly to a Virtual Treeview. People might - (accidentally) misuse the header popup. - -Modified 20 Oct 2002 by Borut Maricic . - Added the possibility to use Troy Wolbrink's Unicode aware popup menu. Define the compiler symbol TNT to enable it. - You can get Troy's Unicode controls collection from http://home.ccci.org/wolbrink/tnt/delphi_unicode_controls.htm). - -Modified 24 Feb 2002 by Ralf Junker . - Fixed a bug where the OnAddHeaderPopupItem would interfere with poAllowHideAll options. - All column indexes now consistently use TColumnIndex (instead of Integer). - -Modified 23 Feb 2002 by Ralf Junker . - Added option to show menu items in the same order as the columns or in original order. - Added option to prevent the user to hide all columns. - -Modified 17 Feb 2002 by Jim Kueneman . - Added the event to filter the items as they are added to the menu. + +@@TVirtualTreeCast +Necessary to make the header accessible. + + +@@TVTHeaderPopupOption.poAllowHideAll +Allows to hide all columns, including the last one. + +@@TVTHeaderPopupOption.poOriginalOrder +Show menu items in original column order as they were added to the tree. + +@@VTHeaderPopup.pas +The contents of this file are subject to the Mozilla Public License +Version 1.1 (the "License"); you may not use this file except in +compliance with the License. You may obtain a copy of the License at +http://www.mozilla.org/MPL/ + +Alternatively, you may redistribute this library, use and/or modify it under the terms of the +GNU Lesser General Public License as published by the Free Software Foundation; +either version 2.1 of the License, or (at your option) any later version. +You may obtain a copy of the LGPL at http://www.gnu.org/copyleft/. + +Software distributed under the License is distributed on an "AS IS" +basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the +License for the specific language governing rights and limitations +under the License. + +The Original Code is VTHeaderPopup.pas. + +The Initial Developer of the Original Code is Ralf Junker . All Rights Reserved. + +Modified 14 Sep 2003 by Mike Lischke . + - Renamed event type name to be consistent with other event types (e.g. used in VT). + - Added event for hiding/showing columns. + - DoXXX method are now virtual. + - Conditional code rearrangement to get back Ctrl+Shift+Up/Down navigation back. +Modified 31 Mar 2003 by Mike Lischke . + Added a check for the PopupComponent property before casting it hardly to a Virtual Treeview. People might + (accidentally) misuse the header popup. + +Modified 20 Oct 2002 by Borut Maricic . + Added the possibility to use Troy Wolbrink's Unicode aware popup menu. Define the compiler symbol TNT to enable it. + You can get Troy's Unicode controls collection from http://home.ccci.org/wolbrink/tnt/delphi_unicode_controls.htm). + +Modified 24 Feb 2002 by Ralf Junker . + Fixed a bug where the OnAddHeaderPopupItem would interfere with poAllowHideAll options. + All column indexes now consistently use TColumnIndex (instead of Integer). + +Modified 23 Feb 2002 by Ralf Junker . + Added option to show menu items in the same order as the columns or in original order. + Added option to prevent the user to hide all columns. + +Modified 17 Feb 2002 by Jim Kueneman . + Added the event to filter the items as they are added to the menu. diff --git a/components/virtualtreeview/Source/VirtualTrees.HeaderPopup.pas b/components/virtualtreeview/Source/VirtualTrees.HeaderPopup.pas index 0e589816..6d003bca 100644 --- a/components/virtualtreeview/Source/VirtualTrees.HeaderPopup.pas +++ b/components/virtualtreeview/Source/VirtualTrees.HeaderPopup.pas @@ -68,8 +68,7 @@ interface uses System.Classes, Vcl.Menus, - VirtualTrees, - VirtualTrees.Types; + VirtualTrees; type TVTHeaderPopupOption = ( @@ -79,7 +78,7 @@ type ); TVTHeaderPopupOptions = set of TVTHeaderPopupOption; - TColumnChangeEvent = procedure(const Sender: TObject; const Column: TColumnIndex; Visible: Boolean) of object; + TColumnChangeEvent = procedure(const Sender: TBaseVirtualTree; const Column: TColumnIndex; Visible: Boolean) of object; TVTHeaderPopupMenu = class(TPopupMenu) strict private @@ -92,7 +91,7 @@ type strict protected procedure DoAddHeaderPopupItem(const Column: TColumnIndex; out Cmd: TAddPopupItemType); virtual; procedure DoColumnChange(Column: TColumnIndex; Visible: Boolean); virtual; - procedure OnMenuItemClick(Sender: TObject); virtual; + procedure OnMenuItemClick(Sender: TObject); public constructor Create(AOwner: TComponent); override; procedure Popup(x, y: Integer); override; @@ -108,8 +107,7 @@ type implementation uses - Winapi.Windows, System.Types, - VirtualTrees.Header; + Winapi.Windows, System.Types; resourcestring sResizeColumnToFit = 'Size &Column to Fit'; diff --git a/components/virtualtreeview/Source/VirtualTrees.StyleHooks.pas b/components/virtualtreeview/Source/VirtualTrees.StyleHooks.pas index 58d55060..b27dae37 100644 --- a/components/virtualtreeview/Source/VirtualTrees.StyleHooks.pas +++ b/components/virtualtreeview/Source/VirtualTrees.StyleHooks.pas @@ -118,31 +118,13 @@ var VTStyleServicesFunc: TVTStyleServicesFunc = nil; -/// Wrapper function for styles services that handles differences between RAD Studio 10.4 and older versions, -/// as well as the case if these controls are used inside the IDE. -function VTStyleServices(AControl: TControl = nil): TCustomStyleServices; - - implementation uses System.SysUtils, System.Math, System.Types, - VirtualTrees, - VirtualTrees.Header, - VirtualTrees.DrawTree; - -function VTStyleServices(AControl: TControl = nil): TCustomStyleServices; -begin - if Assigned(VTStyleServicesFunc) then - Result := VTStyleServicesFunc(AControl) - else - Result := Vcl.Themes.StyleServices{$if CompilerVersion >= 34}(AControl){$ifend}; -end; - -//---------------------------------------------------------------------------------------------------------------------- - + VirtualTrees; type TBaseVirtualTreeCracker = class(TBaseVirtualTree) @@ -516,10 +498,7 @@ end; procedure TVclStyleScrollBarsHook.WMHScroll(var Msg: TWMHScroll); begin CallDefaultProc(TMessage(Msg)); - if not (Msg.ScrollCode in [SB_THUMBTRACK, SB_THUMBPOSITION]) then - UpdateScroll - else - PaintScroll; + PaintScroll; Handled := True; end; @@ -532,7 +511,7 @@ end; procedure TVclStyleScrollBarsHook.WMKeyDown(var Msg: TMessage); begin CallDefaultProc(TMessage(Msg)); - UpdateScroll; + PaintScroll; Handled := True; end; @@ -948,10 +927,7 @@ end; procedure TVclStyleScrollBarsHook.WMVScroll(var Msg: TWMVScroll); begin CallDefaultProc(TMessage(Msg)); - if not (Msg.ScrollCode in [SB_THUMBTRACK, SB_THUMBPOSITION]) then - UpdateScroll - else - PaintScroll; + PaintScroll; Handled := True; end; diff --git a/components/virtualtreeview/Source/VirtualTrees.Types.pas b/components/virtualtreeview/Source/VirtualTrees.Types.pas index d44e918b..72e9834f 100644 --- a/components/virtualtreeview/Source/VirtualTrees.Types.pas +++ b/components/virtualtreeview/Source/VirtualTrees.Types.pas @@ -1,917 +1,8 @@ -unit VirtualTrees.Types; +unit VirtualTrees.Types; +// Dummy unit to make migeration between V7 and V8 easier. interface -uses - WinApi.ActiveX, - System.Types, - System.Classes, - System.UITypes, - System.SysUtils, - Vcl.Controls, - Vcl.GraphUtil, - Vcl.Themes; - -{$MINENUMSIZE 1, make enumerations as small as possible} - -const - VTTreeStreamVersion = 3; - VTHeaderStreamVersion = 6; // The header needs an own stream version to indicate changes only relevant to the header. - - CacheThreshold = 2000; // Number of nodes a tree must at least have to start caching and at the same - // time the maximum number of nodes between two cache entries. - FadeAnimationStepCount = 255; // Number of animation steps for hint fading (0..255). - ShadowSize = 5; // Size in pixels of the hint shadow. This value has no influence on Win2K and XP systems - // as those OSes have native shadow support. - cDefaultTextMargin = 4; // The default margin of text - - // Special identifiers for columns. - NoColumn = - 1; - InvalidColumn = - 2; - - // Indices for check state images used for checking. - ckEmpty = 0; // an empty image used as place holder - // radio buttons - ckRadioUncheckedNormal = 1; - ckRadioUncheckedHot = 2; - ckRadioUncheckedPressed = 3; - ckRadioUncheckedDisabled = 4; - ckRadioCheckedNormal = 5; - ckRadioCheckedHot = 6; - ckRadioCheckedPressed = 7; - ckRadioCheckedDisabled = 8; - // check boxes - ckCheckUncheckedNormal = 9; - ckCheckUncheckedHot = 10; - ckCheckUncheckedPressed = 11; - ckCheckUncheckedDisabled = 12; - ckCheckCheckedNormal = 13; - ckCheckCheckedHot = 14; - ckCheckCheckedPressed = 15; - ckCheckCheckedDisabled = 16; - ckCheckMixedNormal = 17; - ckCheckMixedHot = 18; - ckCheckMixedPressed = 19; - ckCheckMixedDisabled = 20; - // simple button - ckButtonNormal = 21; - ckButtonHot = 22; - ckButtonPressed = 23; - ckButtonDisabled = 24; - - // Instead using a TTimer class for each of the various events I use Windows timers with messages - // as this is more economical. - ExpandTimer = 1; - EditTimer = 2; - HeaderTimer = 3; - ScrollTimer = 4; - ChangeTimer = 5; - StructureChangeTimer = 6; - SearchTimer = 7; - ThemeChangedTimer = 8; - - ThemeChangedTimerDelay = 500; - - // Virtual Treeview does not need to be subclassed by an eventual Theme Manager instance as it handles - // Windows XP theme painting itself. Hence the special message is used to prevent subclassing. - CM_DENYSUBCLASSING = CM_BASE + 2000; - - // Decoupling message for auto-adjusting the internal edit window. - CM_AUTOADJUST = CM_BASE + 2005; - - // Drag image helpers for Windows 2000 and up. - IID_IDropTargetHelper : TGUID = (D1 : $4657278B; D2 : $411B; D3 : $11D2; D4 : ($83, $9A, $00, $C0, $4F, $D9, $18, $D0)); - IID_IDragSourceHelper : TGUID = (D1 : $DE5BF786; D2 : $477A; D3 : $11D2; D4 : ($83, $9D, $00, $C0, $4F, $D9, $18, $D0)); - IID_IDropTarget : TGUID = (D1 : $00000122; D2 : $0000; D3 : $0000; D4 : ($C0, $00, $00, $00, $00, $00, $00, $46)); - - // VT's own clipboard formats, - // Note: The reference format is used internally to allow to link to a tree reference - // to implement optimized moves and other back references. - CFSTR_VIRTUALTREE = 'Virtual Tree Data'; - CFSTR_VTREFERENCE = 'Virtual Tree Reference'; - CFSTR_HTML = 'HTML Format'; - CFSTR_RTF = 'Rich Text Format'; - CFSTR_RTFNOOBJS = 'Rich Text Format Without Objects'; - CFSTR_CSV = 'CSV'; - - // Help identifiers for exceptions. Application developers are responsible to link them with actual help topics. - hcTFEditLinkIsNil = 2000; - hcTFWrongMoveError = 2001; - hcTFWrongStreamFormat = 2002; - hcTFWrongStreamVersion = 2003; - hcTFStreamTooSmall = 2004; - hcTFCorruptStream1 = 2005; - hcTFCorruptStream2 = 2006; - hcTFClipboardFailed = 2007; - hcTFCannotSetUserData = 2008; - - // Header standard split cursor. - crHeaderSplit = crHSplit deprecated 'Use vrHSplit instead'; - - // Height changing cursor. - crVertSplit = crVSplit deprecated 'Use vrVSplit instead'; - - -type -{$IFDEF VT_FMX} - TDimension = Single; -{$ELSE} - TDimension = Integer; // For Firemonkey support, see #841 -{$ENDIF} - TColumnIndex = type Integer; - TColumnPosition = type Cardinal; - PCardinal = ^Cardinal; - - // The exception used by the trees. - EVirtualTreeError = class(Exception); - - // Limits the speed interval which can be used for auto scrolling (milliseconds). - TAutoScrollInterval = 1 .. 1000; - - TVTScrollIncrement = 1 .. 10000; - - // OLE drag'n drop support - TFormatEtcArray = array of TFormatEtc; - TFormatArray = array of Word; - - TSmartAutoFitType = (smaAllColumns, //consider nodes in view only for all columns - smaNoColumn, //consider nodes in view only for no column - smaUseColumnOption //use coSmartResize of the corresponding column - ); //describes the used column resize behaviour for AutoFitColumns - - - TAddPopupItemType = (apNormal, apDisabled, apHidden); - - TCheckType = ( - ctNone, - ctTriStateCheckBox, - ctCheckBox, - ctRadioButton, - ctButton - ); - - // The check states include both, transient and fluent (temporary) states. The only temporary state defined so - // far is the pressed state. - TCheckState = ( - csUncheckedNormal, // unchecked and not pressed - csUncheckedPressed, // unchecked and pressed - csCheckedNormal, // checked and not pressed - csCheckedPressed, // checked and pressed - csMixedNormal, // 3-state check box and not pressed - csMixedPressed, // 3-state check box and pressed - csUncheckedDisabled, // disabled checkbox, not checkable - csCheckedDisabled, // disabled checkbox, not uncheckable - csMixedDisabled // disabled 3-state checkbox - ); - - /// Adds some convenience methods to type TCheckState - TCheckStateHelper = record helper for TCheckState - strict private - const - // Lookup to quickly convert a specific check state into its pressed counterpart and vice versa. - cPressedState : array [TCheckState] of TCheckState = ( - csUncheckedPressed, csUncheckedPressed, csCheckedPressed, csCheckedPressed, csMixedPressed, csMixedPressed, csUncheckedDisabled, csCheckedDisabled, csMixedDisabled); - cUnpressedState : array [TCheckState] of TCheckState = ( - csUncheckedNormal, csUncheckedNormal, csCheckedNormal, csCheckedNormal, csMixedNormal, csMixedNormal, csUncheckedDisabled, csCheckedDisabled, csMixedDisabled); - cEnabledState : array [TCheckState] of TCheckState = ( - csUncheckedNormal, csUncheckedPressed, csCheckedNormal, csCheckedPressed, csMixedNormal, csMixedPressed, csUncheckedNormal, csCheckedNormal, csMixedNormal); - cToggledState : array [TCheckState] of TCheckState = ( - csCheckedNormal, csCheckedPressed, csUncheckedNormal, csUncheckedPressed, csCheckedNormal, csCheckedPressed, csUncheckedDisabled, csCheckedDisabled, csMixedDisabled); - public - function GetPressed() : TCheckState; inline; - function GetUnpressed() : TCheckState; inline; - function GetEnabled() : TCheckState; inline; - function GetToggled() : TCheckState; inline; - function IsDisabled() : Boolean; inline; - function IsChecked() : Boolean; inline; - function IsUnChecked() : Boolean; inline; - function IsMixed() : Boolean; inline; - end; - -type - // Options per column. - TVTColumnOption = ( - coAllowClick, // Column can be clicked (must be enabled too). - coDraggable, // Column can be dragged. - coEnabled, // Column is enabled. - coParentBidiMode, // Column uses the parent's bidi mode. - coParentColor, // Column uses the parent's background color. - coResizable, // Column can be resized. - coShowDropMark, // Column shows the drop mark if it is currently the drop target. - coVisible, // Column is shown. - coAutoSpring, // Column takes part in the auto spring feature of the header (must be resizable too). - coFixed, // Column is fixed and can not be selected or scrolled etc. - coSmartResize, // Column is resized to its largest entry which is in view (instead of its largest - // visible entry). - coAllowFocus, // Column can be focused. - coDisableAnimatedResize, // Column resizing is not animated. - coWrapCaption, // Caption could be wrapped across several header lines to fit columns width. - coUseCaptionAlignment, // Column's caption has its own aligment. - coEditable, // Column can be edited - coStyleColor // Prefer background color of VCL style over TVirtualTreeColumn.Color - ); - TVTColumnOptions = set of TVTColumnOption; - - TVirtualTreeColumnStyle = ( - vsText, - vsOwnerDraw - ); - - TVTHeaderColumnLayout = ( - blGlyphLeft, - blGlyphRight, - blGlyphTop, - blGlyphBottom - ); - - TSortDirection = ( - sdAscending, - sdDescending - ); - - TSortDirectionHelper = record helper for VirtualTrees.Types.TSortDirection - strict private - const - cSortDirectionToInt : Array [TSortDirection] of Integer = (1, - 1); - public - /// Returns +1 for ascending and -1 for descending sort order. - function ToInt() : Integer; inline; - end; - - -// Used during owner draw of the header to indicate which drop mark for the column must be drawn. - TVTDropMarkMode = ( - dmmNone, - dmmLeft, - dmmRight - ); - - // auto scroll directions - TScrollDirections = set of TScrollDirection; -// sdLeft, -// sdUp, -// sdRight, -// sdDown -// ); - - - - // There is a heap of switchable behavior in the tree. Since published properties may never exceed 4 bytes, - // which limits sets to at most 32 members, and because for better overview tree options are splitted - // in various sub-options and are held in a commom options class. - // - // Options to customize tree appearance: - TVTPaintOption = ( - toHideFocusRect, // Avoid drawing the dotted rectangle around the currently focused node. - toHideSelection, // Selected nodes are drawn as unselected nodes if the tree is unfocused. - toHotTrack, // Track which node is under the mouse cursor. - toPopupMode, // Paint tree as would it always have the focus (useful for tree combo boxes etc.) - toShowBackground, // Use the background image if there's one. - toShowButtons, // Display collapse/expand buttons left to a node. - toShowDropmark, // Show the dropmark during drag'n drop operations. - toShowHorzGridLines, // Display horizontal lines to simulate a grid. - toShowRoot, // Show lines also at top level (does not show the hidden/internal root node). - toShowTreeLines, // Display tree lines to show hierarchy of nodes. - toShowVertGridLines, // Display vertical lines (depending on columns) to simulate a grid. - toThemeAware, // Draw UI elements (header, tree buttons etc.) according to the current theme if enabled (Windows XP+ only, application must be themed). - toUseBlendedImages, // Enable alpha blending for ghosted nodes or those which are being cut/copied. - toGhostedIfUnfocused, // Ghosted images are still shown as ghosted if unfocused (otherwise the become non-ghosted images). - toFullVertGridLines, // Display vertical lines over the full client area, not only the space occupied by nodes. - // This option only has an effect if toShowVertGridLines is enabled too. - toAlwaysHideSelection, // Do not draw node selection, regardless of focused state. - toUseBlendedSelection, // Enable alpha blending for node selections. - toStaticBackground, // Show simple static background instead of a tiled one. - toChildrenAbove, // Display child nodes above their parent. - toFixedIndent, // Draw the tree with a fixed indent. - toUseExplorerTheme, // Use the explorer theme if run under Windows Vista (or above). - toHideTreeLinesIfThemed, // Do not show tree lines if theming is used. - toShowFilteredNodes // Draw nodes even if they are filtered out. - ); - TVTPaintOptions = set of TVTPaintOption; - - { Options to toggle animation support: - **Do not use toAnimatedToggle when a background image is used for the tree. - The animation does not look good as the image splits and moves with it. - } - TVTAnimationOption = (toAnimatedToggle, // Expanding and collapsing a node is animated (quick window scroll). - // **See note above. - toAdvancedAnimatedToggle // Do some advanced animation effects when toggling a node. - ); - TVTAnimationOptions = set of TVTAnimationOption; - - // Options which toggle automatic handling of certain situations: - TVTAutoOption = (toAutoDropExpand, // Expand node if it is the drop target for more than a certain time. - toAutoExpand, // Nodes are expanded (collapsed) when getting (losing) the focus. - toAutoScroll, // Scroll if mouse is near the border while dragging or selecting. - toAutoScrollOnExpand, // Scroll as many child nodes in view as possible after expanding a node. - toAutoSort, // Sort tree when Header.SortColumn or Header.SortDirection change or sort node if - // child nodes are added. Sorting will take place also if SortColum is NoColumn (-1). - - toAutoSpanColumns, // Large entries continue into next column(s) if there's no text in them (no clipping). - toAutoTristateTracking, // Checkstates are automatically propagated for tri state check boxes. - toAutoHideButtons, // Node buttons are hidden when there are child nodes, but all are invisible. - toAutoDeleteMovedNodes, // Delete nodes which where moved in a drag operation (if not directed otherwise). - toDisableAutoscrollOnFocus, // Disable scrolling a node or column into view if it gets focused. - toAutoChangeScale, // Change default node height automatically if the system's font scale is set to big fonts. - toAutoFreeOnCollapse, // Frees any child node after a node has been collapsed (HasChildren flag stays there). - toDisableAutoscrollOnEdit, // Do not center a node horizontally when it is edited. - toAutoBidiColumnOrdering // When set then columns (if any exist) will be reordered from lowest index to highest index - // and vice versa when the tree's bidi mode is changed. - ); - TVTAutoOptions = set of TVTAutoOption; - - // Options which determine the tree's behavior when selecting nodes: - TVTSelectionOption = (toDisableDrawSelection, // Prevent user from selecting with the selection rectangle in multiselect mode. - toExtendedFocus, // Entries other than in the main column can be selected, edited etc. - toFullRowSelect, // Hit test as well as selection highlight are not constrained to the text of a node. - toLevelSelectConstraint, // Constrain selection to the same level as the selection anchor. - toMiddleClickSelect, // Allow selection, dragging etc. with the middle mouse button. This and toWheelPanning - // are mutual exclusive. - toMultiSelect, // Allow more than one node to be selected. - toRightClickSelect, // Allow selection, dragging etc. with the right mouse button. - toSiblingSelectConstraint, // Constrain selection to nodes with same parent. - toCenterScrollIntoView, // Center nodes vertically in the client area when scrolling into view. - toSimpleDrawSelection, // Simplifies draw selection, so a node's caption does not need to intersect with the - // selection rectangle. - toAlwaysSelectNode, // If this flag is set to true, the tree view tries to always have a node selected. - // This behavior is closer to the Windows TreeView and useful in Windows Explorer style applications. - toRestoreSelection, // Set to true if upon refill the previously selected nodes should be selected again. - // The nodes will be identified by its caption (text in MainColumn) - // You may use TVTHeader.RestoreSelectiuonColumnIndex to define an other column that should be used for indentification. - toSyncCheckboxesWithSelection // If checkboxes are shown, they follow the change in selections. When checkboxes are - // changed, the selections follow them and vice-versa. - // **Only supported for ctCheckBox type checkboxes. - ); - TVTSelectionOptions = set of TVTSelectionOption; - - TVTEditOptions = (toDefaultEdit, // Standard behaviour for end of editing (after VK_RETURN stay on edited cell). - toVerticalEdit, // After VK_RETURN switch to next column. - toHorizontalEdit // After VK_RETURN switch to next row. - ); - - // Options which do not fit into any of the other groups: - TVTMiscOption = (toAcceptOLEDrop, // Register tree as OLE accepting drop target - toCheckSupport, // Show checkboxes/radio buttons. - toEditable, // Node captions can be edited. - toFullRepaintOnResize, // Fully invalidate the tree when its window is resized (CS_HREDRAW/CS_VREDRAW). - toGridExtensions, // Use some special enhancements to simulate and support grid behavior. - toInitOnSave, // Initialize nodes when saving a tree to a stream. - toReportMode, // Tree behaves like TListView in report mode. - toToggleOnDblClick, // Toggle node expansion state when it is double clicked. - toWheelPanning, // Support for mouse panning (wheel mice only). This option and toMiddleClickSelect are - // mutal exclusive, where panning has precedence. - toReadOnly, // The tree does not allow to be modified in any way. No action is executed and - // node editing is not possible. - toVariableNodeHeight, // When set then GetNodeHeight will trigger OnMeasureItem to allow variable node heights. - toFullRowDrag, // Start node dragging by clicking anywhere in it instead only on the caption or image. - // Must be used together with toDisableDrawSelection. - toNodeHeightResize, // Allows changing a node's height via mouse. - toNodeHeightDblClickResize, // Allows to reset a node's height to FDefaultNodeHeight via a double click. - toEditOnClick, // Editing mode can be entered with a single click - toEditOnDblClick, // Editing mode can be entered with a double click - toReverseFullExpandHotKey // Used to define Ctrl+'+' instead of Ctrl+Shift+'+' for full expand (and similar for collapsing) - ); - TVTMiscOptions = set of TVTMiscOption; - - // Options to control data export - TVTExportMode = (emAll, // export all records (regardless checked state) - emChecked, // export checked records only - emUnchecked, // export unchecked records only - emVisibleDueToExpansion, // Do not export nodes that are not visible because their parent is not expanded - emSelected // export selected nodes only - ); - - // Options regarding strings (useful only for the string tree and descendants): - TVTStringOption = (toSaveCaptions, // If set then the caption is automatically saved with the tree node, regardless of what is - // saved in the user data. - toShowStaticText, // Show static text in a caption which can be differently formatted than the caption - // but cannot be edited. - toAutoAcceptEditChange // Automatically accept changes during edit if the user finishes editing other then - // VK_RETURN or ESC. If not set then changes are cancelled. - ); - TVTStringOptions = set of TVTStringOption; - -const - DefaultPaintOptions = [toShowButtons, toShowDropmark, toShowTreeLines, toShowRoot, toThemeAware, toUseBlendedImages]; - DefaultAnimationOptions = []; - DefaultAutoOptions = [toAutoDropExpand, toAutoTristateTracking, toAutoScrollOnExpand, toAutoDeleteMovedNodes, toAutoChangeScale, toAutoSort, toAutoHideButtons]; - DefaultSelectionOptions = []; - DefaultMiscOptions = [toAcceptOLEDrop, toFullRepaintOnResize, toInitOnSave, toToggleOnDblClick, toWheelPanning, toEditOnClick]; - - DefaultStringOptions = [toSaveCaptions, toAutoAcceptEditChange]; - -type - TCustomVirtualTreeOptions = class(TPersistent) - private - FOwner : TCustomControl; - FPaintOptions : TVTPaintOptions; - FAnimationOptions : TVTAnimationOptions; - FAutoOptions : TVTAutoOptions; - FSelectionOptions : TVTSelectionOptions; - FMiscOptions : TVTMiscOptions; - FExportMode : TVTExportMode; - FEditOptions : TVTEditOptions; - procedure SetAnimationOptions(const Value : TVTAnimationOptions); - procedure SetAutoOptions(const Value : TVTAutoOptions); - procedure SetMiscOptions(const Value : TVTMiscOptions); - procedure SetPaintOptions(const Value : TVTPaintOptions); - procedure SetSelectionOptions(const Value : TVTSelectionOptions); - protected - // 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(AControl : TControl = nil) : TCustomStyleServices; - public - constructor Create(AOwner : TCustomControl); virtual; - //these bypass the side effects in the regular setters. - procedure InternalSetMiscOptions(const Value : TVTMiscOptions); - - procedure AssignTo(Dest : TPersistent); override; - property AnimationOptions : TVTAnimationOptions read FAnimationOptions write SetAnimationOptions default DefaultAnimationOptions; - property AutoOptions : TVTAutoOptions read FAutoOptions write SetAutoOptions default DefaultAutoOptions; - property ExportMode : TVTExportMode read FExportMode write FExportMode default emAll; - property MiscOptions : TVTMiscOptions read FMiscOptions write SetMiscOptions default DefaultMiscOptions; - property PaintOptions : TVTPaintOptions read FPaintOptions write SetPaintOptions default DefaultPaintOptions; - property SelectionOptions : TVTSelectionOptions read FSelectionOptions write SetSelectionOptions default DefaultSelectionOptions; - property EditOptions : TVTEditOptions read FEditOptions write FEditOptions default toDefaultEdit; - - property Owner: TCustomControl read FOwner; - end; - - TTreeOptionsClass = class of TCustomVirtualTreeOptions; - - TVirtualTreeOptions = class(TCustomVirtualTreeOptions) - published - property AnimationOptions; - property AutoOptions; - property ExportMode; - property MiscOptions; - property PaintOptions; - property SelectionOptions; - end; - - TCustomStringTreeOptions = class(TCustomVirtualTreeOptions) - private - FStringOptions : TVTStringOptions; - procedure SetStringOptions(const Value : TVTStringOptions); - protected - public - constructor Create(AOwner : TCustomControl); override; - procedure AssignTo(Dest : TPersistent); override; - property StringOptions : TVTStringOptions read FStringOptions write SetStringOptions default DefaultStringOptions; - end; - - TStringTreeOptions = class(TCustomStringTreeOptions) - published - property AnimationOptions; - property AutoOptions; - property ExportMode; - property MiscOptions; - property PaintOptions; - property SelectionOptions; - property StringOptions; - property EditOptions; - end; - - TScrollBarStyle = (sbmRegular, sbm3D); - - // A class to manage scroll bar aspects. - TScrollBarOptions = class(TPersistent) - private - FAlwaysVisible : Boolean; - FOwner : TCustomControl; - FScrollBars : TScrollStyle; // used to hide or show vertical and/or horizontal scrollbar - FScrollBarStyle : TScrollBarStyle; // kind of scrollbars to use - FIncrementX, FIncrementY : TVTScrollIncrement; // number of pixels to scroll in one step (when auto scrolling) - procedure SetAlwaysVisible(Value : Boolean); - procedure SetScrollBars(Value : TScrollStyle); - procedure SetScrollBarStyle(Value : TScrollBarStyle); - protected - function GetOwner : TPersistent; override; - public - constructor Create(AOwner : TCustomControl); - - procedure Assign(Source : TPersistent); override; - published - property AlwaysVisible : Boolean read FAlwaysVisible write SetAlwaysVisible default False; - property HorizontalIncrement : TVTScrollIncrement read FIncrementX write FIncrementX default 20; - property ScrollBars : TScrollStyle read FScrollBars write SetScrollBars default TScrollStyle.ssBoth; - property ScrollBarStyle : TScrollBarStyle read FScrollBarStyle write SetScrollBarStyle default sbmRegular; - property VerticalIncrement : TVTScrollIncrement read FIncrementY write FIncrementY default 20; - end; - implementation -uses - VirtualTrees, - VirtualTrees.StyleHooks, - WinApi.Windows; - -type - TVTCracker = class(TBaseVirtualTree); - - //----------------- TCustomVirtualTreeOptions -------------------------------------------------------------------------- - -constructor TCustomVirtualTreeOptions.Create(AOwner : TCustomControl); -begin - FOwner := AOwner; - - FPaintOptions := DefaultPaintOptions; - FAnimationOptions := DefaultAnimationOptions; - FAutoOptions := DefaultAutoOptions; - FSelectionOptions := DefaultSelectionOptions; - FMiscOptions := DefaultMiscOptions; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TCustomVirtualTreeOptions.SetAnimationOptions(const Value : TVTAnimationOptions); -begin - FAnimationOptions := Value; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TCustomVirtualTreeOptions.SetAutoOptions(const Value : TVTAutoOptions); -var - ChangedOptions : TVTAutoOptions; -begin - if FAutoOptions <> Value then - begin - // Exclusive ORing to get all entries wich are in either set but not in both. - ChangedOptions := FAutoOptions + Value - (FAutoOptions * Value); - FAutoOptions := Value; - with FOwner do - if (toAutoSpanColumns in ChangedOptions) and not (csLoading in ComponentState) and HandleAllocated then - Invalidate; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TCustomVirtualTreeOptions.InternalSetMiscOptions(const Value : TVTMiscOptions); -begin - FMiscOptions := Value; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TCustomVirtualTreeOptions.SetMiscOptions(const Value : TVTMiscOptions); -var - ToBeSet, ToBeCleared : TVTMiscOptions; -begin - if FMiscOptions <> Value then - begin - ToBeSet := Value - FMiscOptions; - ToBeCleared := FMiscOptions - Value; - FMiscOptions := Value; - - with TVTCracker(FOwner) do - if not (csLoading in ComponentState) and HandleAllocated then - begin - if toCheckSupport in ToBeSet + ToBeCleared then - Invalidate; - if toEditOnDblClick in ToBeSet then - FMiscOptions := FMiscOptions - [toToggleOnDblClick]; - // In order for toEditOnDblClick to take effect, we need to remove toToggleOnDblClick which is handled with priority. See issue #747 - - if not (csDesigning in ComponentState) then - begin - if toAcceptOLEDrop in ToBeCleared then - RevokeDragDrop(Handle); - if toFullRepaintOnResize in ToBeSet + ToBeCleared then - RecreateWnd; - if toAcceptOLEDrop in ToBeSet then - RegisterDragDrop(Handle, DragManager as IDropTarget); - if toVariableNodeHeight in ToBeSet then - begin - BeginUpdate(); - try - ReInitNode(nil, True); - finally - EndUpdate(); - end; //try..finally - end; //if toVariableNodeHeight - end; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TCustomVirtualTreeOptions.SetPaintOptions(const Value : TVTPaintOptions); -var - ToBeSet, ToBeCleared : TVTPaintOptions; - Run : PVirtualNode; - HandleWasAllocated : Boolean; -begin - if FPaintOptions <> Value then - begin - ToBeSet := Value - FPaintOptions; - ToBeCleared := FPaintOptions - Value; - FPaintOptions := Value; - if (toFixedIndent in ToBeSet) then - begin - // Fixes issue #388 - Include(FPaintOptions, toShowRoot); - Include(ToBeSet, toShowRoot); - end; //if - with TVTCracker(FOwner) do - begin - HandleWasAllocated := HandleAllocated; - - if not (csLoading in ComponentState) and (toShowFilteredNodes in ToBeSet + ToBeCleared) then - begin - if HandleWasAllocated then - BeginUpdate; - InterruptValidation; - Run := GetFirstNoInit; - while Assigned(Run) do - begin - if (vsFiltered in Run.States) then - begin - if FullyVisible[Run] then - begin - if toShowFilteredNodes in ToBeSet then - IncVisibleCount - else - DecVisibleCount; - end; - if toShowFilteredNodes in ToBeSet then - AdjustTotalHeight(Run, Run.NodeHeight, True) - else - AdjustTotalHeight(Run, - Run.NodeHeight, True); - end; - Run := GetNextNoInit(Run); - end; - if HandleWasAllocated then - EndUpdate; - end; - - if HandleAllocated then - begin - if IsWinVistaOrAbove and ((tsUseThemes in TreeStates) or ((toThemeAware in ToBeSet) and StyleServices.Enabled)) and (toUseExplorerTheme in (ToBeSet + ToBeCleared)) and - not VclStyleEnabled then - begin - if (toUseExplorerTheme in ToBeSet) then - begin - SetWindowTheme('explorer'); - DoStateChange([tsUseExplorerTheme]); - end - else if toUseExplorerTheme in ToBeCleared then - begin - SetWindowTheme(''); - DoStateChange([], [tsUseExplorerTheme]); - end; - end; - - if not (csLoading in ComponentState) then - begin - if ((toThemeAware in ToBeSet + ToBeCleared) or (toUseExplorerTheme in ToBeSet + ToBeCleared) or VclStyleEnabled) then - begin - if ((toThemeAware in ToBeSet) and StyleServices.Enabled) then - DoStateChange([tsUseThemes]) - else if (toThemeAware in ToBeCleared) then - DoStateChange([], [tsUseThemes]); - - PrepareBitmaps(True, False); - RedrawWindow(Handle, nil, 0, RDW_INVALIDATE or RDW_VALIDATE or RDW_FRAME); - end; - - if toChildrenAbove in ToBeSet + ToBeCleared then - begin - InvalidateCache; - if UpdateCount = 0 then - begin - ValidateCache; - Invalidate; - end; - end; - - Invalidate; - end; - end; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TCustomVirtualTreeOptions.SetSelectionOptions(const Value : TVTSelectionOptions); -var - ToBeSet, ToBeCleared : TVTSelectionOptions; -begin - if FSelectionOptions <> Value then - begin - ToBeSet := Value - FSelectionOptions; - ToBeCleared := FSelectionOptions - Value; - FSelectionOptions := Value; - - with TVTCracker(FOwner) do - begin - if (toMultiSelect in (ToBeCleared + ToBeSet)) or ([toLevelSelectConstraint, toSiblingSelectConstraint] * ToBeSet <> []) then - ClearSelection; - - if (toExtendedFocus in ToBeCleared) and (FocusedColumn > 0) and HandleAllocated then - begin - FocusedColumn := Header.MainColumn; - Invalidate; - end; - - if not (toExtendedFocus in FSelectionOptions) then - FocusedColumn := Header.MainColumn; - end; - end; -end; - -function TCustomVirtualTreeOptions.StyleServices(AControl : TControl) : TCustomStyleServices; -begin - Result := VTStyleServices(FOwner); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TCustomVirtualTreeOptions.AssignTo(Dest : TPersistent); -begin - if Dest is TCustomVirtualTreeOptions then - begin - with Dest as TCustomVirtualTreeOptions do - begin - PaintOptions := Self.PaintOptions; - AnimationOptions := Self.AnimationOptions; - AutoOptions := Self.AutoOptions; - SelectionOptions := Self.SelectionOptions; - MiscOptions := Self.MiscOptions; - end; - end - else - inherited; -end; - -//----------------- TCustomStringTreeOptions --------------------------------------------------------------------------- - -constructor TCustomStringTreeOptions.Create(AOwner : TCustomControl); -begin - inherited; - FStringOptions := DefaultStringOptions; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TCustomStringTreeOptions.SetStringOptions(const Value : TVTStringOptions); -var - ChangedOptions : TVTStringOptions; -begin - if FStringOptions <> Value then - begin - // Exclusive ORing to get all entries wich are in either set but not in both. - ChangedOptions := FStringOptions + Value - (FStringOptions * Value); - FStringOptions := Value; - with FOwner do - if (toShowStaticText in ChangedOptions) and not (csLoading in ComponentState) and HandleAllocated then - Invalidate; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TCustomStringTreeOptions.AssignTo(Dest : TPersistent); -begin - if Dest is TCustomStringTreeOptions then - begin - with Dest as TCustomStringTreeOptions do - begin - StringOptions := Self.StringOptions; - EditOptions := Self.EditOptions; - end; - end; - - // Let ancestors assign their options to the destination class. - inherited; -end; - -//----------------- TScrollBarOptions ---------------------------------------------------------------------------------- - -constructor TScrollBarOptions.Create(AOwner : TCustomControl); -begin - inherited Create; - - FOwner := AOwner; - FAlwaysVisible := False; - FScrollBarStyle := sbmRegular; - FScrollBars := TScrollStyle.ssBoth; - FIncrementX := 20; - FIncrementY := 20; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TScrollBarOptions.SetAlwaysVisible(Value : Boolean); -begin - if FAlwaysVisible <> Value then - begin - FAlwaysVisible := Value; - if not (csLoading in FOwner.ComponentState) and FOwner.HandleAllocated then - TVTCracker(FOwner).RecreateWnd; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TScrollBarOptions.SetScrollBars(Value : TScrollStyle); -begin - if FScrollBars <> Value then - begin - FScrollBars := Value; - if not (csLoading in FOwner.ComponentState) and FOwner.HandleAllocated then - TVTCracker(FOwner).RecreateWnd; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TScrollBarOptions.SetScrollBarStyle(Value : TScrollBarStyle); - -begin - if FScrollBarStyle <> Value then - begin - FScrollBarStyle := Value; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TScrollBarOptions.GetOwner : TPersistent; - -begin - Result := FOwner; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TScrollBarOptions.Assign(Source : TPersistent); - -begin - if Source is TScrollBarOptions then - begin - AlwaysVisible := TScrollBarOptions(Source).AlwaysVisible; - HorizontalIncrement := TScrollBarOptions(Source).HorizontalIncrement; - ScrollBars := TScrollBarOptions(Source).ScrollBars; - ScrollBarStyle := TScrollBarOptions(Source).ScrollBarStyle; - VerticalIncrement := TScrollBarOptions(Source).VerticalIncrement; - end - else - inherited; -end; - - - -{ TCheckStateHelper } - -function TCheckStateHelper.IsDisabled : Boolean; -begin - Result := Self >= TCheckState.csUncheckedDisabled; -end; - -function TCheckStateHelper.IsChecked : Boolean; -begin - Result := Self in [csCheckedNormal, csCheckedPressed, csCheckedDisabled]; -end; - -function TCheckStateHelper.IsUnChecked : Boolean; -begin - Result := Self in [csUncheckedNormal, csUncheckedPressed, csUncheckedDisabled]; -end; - -function TCheckStateHelper.IsMixed : Boolean; -begin - Result := Self in [csMixedNormal, csMixedPressed, csMixedDisabled]; -end; - -function TCheckStateHelper.GetEnabled : TCheckState; -begin - Result := cEnabledState[Self]; -end; - -function TCheckStateHelper.GetPressed() : TCheckState; -begin - Result := cPressedState[Self]; -end; - -function TCheckStateHelper.GetUnpressed() : TCheckState; -begin - Result := cUnpressedState[Self]; -end; - -function TCheckStateHelper.GetToggled() : TCheckState; -begin - Result := cToggledState[Self]; -end; - -{ TSortDirectionHelper } - -function TSortDirectionHelper.ToInt() : Integer; -begin - Result := cSortDirectionToInt[Self]; -end; - - -end. +end. \ No newline at end of file diff --git a/components/virtualtreeview/Source/VirtualTrees.Utils.pas b/components/virtualtreeview/Source/VirtualTrees.Utils.pas index 0d5b1b02..14bc9cae 100644 --- a/components/virtualtreeview/Source/VirtualTrees.Utils.pas +++ b/components/virtualtreeview/Source/VirtualTrees.Utils.pas @@ -1282,10 +1282,7 @@ procedure DrawImage(ImageList: TCustomImageList; Index: Integer; Canvas: TCanvas begin if Enabled then - // HeidiSQL fix for #1045, required until Embarcadero fixes TVirtualImageList.DoDraw: - //TCustomImageListCast(ImageList).DoDraw(Index, Canvas, X, Y, Style, Enabled) - ImageList_DrawEx(ImageList.Handle, Index, Canvas.Handle, X, Y, 0, 0, - GetRGBColor(ImageList.BkColor), GetRGBColor(ImageList.BlendColor), Style) + TCustomImageListCast(ImageList).DoDraw(Index, Canvas, X, Y, Style, Enabled) else DrawDisabledImage(ImageList, Canvas, X, Y, Index); end; diff --git a/components/virtualtreeview/Source/VirtualTrees.pas b/components/virtualtreeview/Source/VirtualTrees.pas index 2b6adb27..7037607d 100644 --- a/components/virtualtreeview/Source/VirtualTrees.pas +++ b/components/virtualtreeview/Source/VirtualTrees.pas @@ -30,7 +30,7 @@ // Anthony Mills, Alexander Egorushkin (BCB), Mathias Torell (BCB), Frank van den Bergh, Vadim Sedulin, Peter Evans, // Milan Vandrovec (BCB), Steve Moss, Joe White, David Clark, Anders Thomsen, Igor Afanasyev, Eugene Programmer, // Corbin Dunn, Richard Pringle, Uli Gerhardt, Azza, Igor Savkic, Daniel Bauten, Timo Tegtmeier, Dmitry Zegebart, -// Andreas Hausladen, Joachim Marder, Roman Kassebaum, Vincent Parrett, Dietmar Roesler, Sanjay Kanade, +// Andreas Hausladen, Joachim Marder, Roman Kassebaum, Vincent Parret, Dietmar Roesler, Sanjay Kanade, // and everyone that sent pull requests: https://github.com/Virtual-TreeView/Virtual-TreeView/pulls?q= // Beta testers: // Freddy Ertl, Hans-Juergen Schnorrenberg, Werner Lehmann, Jim Kueneman, Vadim Sedulin, Moritz Franckenstein, @@ -78,111 +78,142 @@ uses Winapi.Windows, Winapi.oleacc, Winapi.Messages, System.SysUtils, Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.ImgList, Winapi.ActiveX, Vcl.StdCtrls, System.Classes, Vcl.Menus, Vcl.Printers, System.Types, Winapi.CommCtrl, Vcl.Themes, Winapi.UxTheme, - Winapi.ShlObj, System.UITypes, System.Generics.Collections, - VirtualTrees.Types, - VirtualTrees.Colors, - VirtualTrees.DragImage, - VirtualTrees.Header; + Winapi.ShlObj, System.UITypes, System.Generics.Collections, VirtualTrees.Types; +type +{$IFDEF VT_FMX} + TDimension = Single; +{$ELSE} + TDimension = Integer; // For Firemonkey support, see #841 +{$ENDIF} const - //Aliases - NoColumn = VirtualTrees.Types.NoColumn; - InvalidColumn = VirtualTrees.Types.InvalidColumn; - sdAscending = VirtualTrees.Types.TSortDirection.sdAscending; - sdDescending = VirtualTrees.Types.TSortDirection.sdDescending; + VTVersion = '7.6.2' deprecated 'This const is going to be removed in a future version'; - ctNone = VirtualTrees.Types.TCheckType.ctNone; - ctTriStateCheckBox = VirtualTrees.Types.TCheckType.ctTriStateCheckBox; - ctCheckBox = VirtualTrees.Types.TCheckType.ctCheckBox; - ctRadioButton = VirtualTrees.Types.TCheckType.ctRadioButton; - ctButton = VirtualTrees.Types.TCheckType.ctButton; +const + VTTreeStreamVersion = 3; + VTHeaderStreamVersion = 6; // The header needs an own stream version to indicate changes only relevant to the header. - csUncheckedNormal = VirtualTrees.Types.TCheckState.csUncheckedNormal; - csUncheckedPressed = VirtualTrees.Types.TCheckState.csUncheckedPressed; - csCheckedNormal = VirtualTrees.Types.TCheckState.csCheckedNormal; - csCheckedPressed = VirtualTrees.Types.TCheckState.csCheckedPressed; - csMixedNormal = VirtualTrees.Types.TCheckState.csMixedNormal; - csMixedPressed = VirtualTrees.Types.TCheckState.csMixedPressed; - csUncheckedDisabled = VirtualTrees.Types.TCheckState.csUncheckedDisabled; - csCheckedDisabled = VirtualTrees.Types.TCheckState.csCheckedDisabled; - csMixedDisable = VirtualTrees.Types.TCheckState.csMixedDisabled; + CacheThreshold = 2000; // Number of nodes a tree must at least have to start caching and at the same + // time the maximum number of nodes between two cache entries. + FadeAnimationStepCount = 255; // Number of animation steps for hint fading (0..255). + ShadowSize = 5; // Size in pixels of the hint shadow. This value has no influence on Win2K and XP systems + // as those OSes have native shadow support. + cDefaultTextMargin = 4; // The default margin of text + // Special identifiers for columns. + NoColumn = -1; + InvalidColumn = -2; + // Indices for check state images used for checking. + ckEmpty = 0; // an empty image used as place holder + // radio buttons + ckRadioUncheckedNormal = 1; + ckRadioUncheckedHot = 2; + ckRadioUncheckedPressed = 3; + ckRadioUncheckedDisabled = 4; + ckRadioCheckedNormal = 5; + ckRadioCheckedHot = 6; + ckRadioCheckedPressed = 7; + ckRadioCheckedDisabled = 8; + // check boxes + ckCheckUncheckedNormal = 9; + ckCheckUncheckedHot = 10; + ckCheckUncheckedPressed = 11; + ckCheckUncheckedDisabled = 12; + ckCheckCheckedNormal = 13; + ckCheckCheckedHot = 14; + ckCheckCheckedPressed = 15; + ckCheckCheckedDisabled = 16; + ckCheckMixedNormal = 17; + ckCheckMixedHot = 18; + ckCheckMixedPressed = 19; + ckCheckMixedDisabled = 20; + // simple button + ckButtonNormal = 21; + ckButtonHot = 22; + ckButtonPressed = 23; + ckButtonDisabled = 24; + + // Instead using a TTimer class for each of the various events I use Windows timers with messages + // as this is more economical. + ExpandTimer = 1; + EditTimer = 2; + HeaderTimer = 3; + ScrollTimer = 4; + ChangeTimer = 5; + StructureChangeTimer = 6; + SearchTimer = 7; + ThemeChangedTimer = 8; + + ThemeChangedTimerDelay = 500; + + // Virtual Treeview does not need to be subclassed by an eventual Theme Manager instance as it handles + // Windows XP theme painting itself. Hence the special message is used to prevent subclassing. + CM_DENYSUBCLASSING = CM_BASE + 2000; + + // Decoupling message for auto-adjusting the internal edit window. + CM_AUTOADJUST = CM_BASE + 2005; + + // VT's own clipboard formats, + // Note: The reference format is used internally to allow to link to a tree reference + // to implement optimized moves and other back references. + CFSTR_VIRTUALTREE = 'Virtual Tree Data'; + CFSTR_VTREFERENCE = 'Virtual Tree Reference'; + CFSTR_HTML = 'HTML Format'; + CFSTR_RTF = 'Rich Text Format'; + CFSTR_RTFNOOBJS = 'Rich Text Format Without Objects'; + CFSTR_CSV = 'CSV'; + + // Drag image helpers for Windows 2000 and up. + IID_IDropTargetHelper: TGUID = (D1: $4657278B; D2: $411B; D3: $11D2; D4: ($83, $9A, $00, $C0, $4F, $D9, $18, $D0)); + IID_IDragSourceHelper: TGUID = (D1: $DE5BF786; D2: $477A; D3: $11D2; D4: ($83, $9D, $00, $C0, $4F, $D9, $18, $D0)); + IID_IDropTarget: TGUID = (D1: $00000122; D2: $0000; D3: $0000; D4: ($C0, $00, $00, $00, $00, $00, $00, $46)); + + // Help identifiers for exceptions. Application developers are responsible to link them with actual help topics. + hcTFEditLinkIsNil = 2000; + hcTFWrongMoveError = 2001; + hcTFWrongStreamFormat = 2002; + hcTFWrongStreamVersion = 2003; + hcTFStreamTooSmall = 2004; + hcTFCorruptStream1 = 2005; + hcTFCorruptStream2 = 2006; + hcTFClipboardFailed = 2007; + hcTFCannotSetUserData = 2008; + + // Header standard split cursor. + crHeaderSplit = TCursor(63); + + // Height changing cursor. + crVertSplit = TCursor(62); + +var // Clipboard format IDs used in OLE drag'n drop and clipboard transfers. + CF_VIRTUALTREE, + CF_VTREFERENCE, + CF_VRTF, + CF_VRTFNOOBJS, // Unfortunately CF_RTF* is already defined as being + // registration strings so I have to use different identifiers. + CF_HTML, + CF_CSV: Word; -var IsWinVistaOrAbove: Boolean; {$MinEnumSize 1, make enumerations as small as possible} + + type // Alias defintions for convenience TImageIndex = System.UITypes.TImageIndex; TCanvas = Vcl.Graphics.TCanvas; - //these were moved, aliases are for backwards compatibility. - //some may be removed once we sort out excactly what is needed. - TDimension = VirtualTrees.Types.TDimension; - TColumnIndex = VirtualTrees.Types.TColumnIndex; - TColumnPosition = VirtualTrees.Types.TColumnPosition; - EVirtualTreeError = VirtualTrees.Types.EVirtualTreeError; - TAutoScrollInterval = VirtualTrees.Types.TAutoScrollInterval; - TVTScrollIncrement = VirtualTrees.Types.TVTScrollIncrement; - TFormatArray = VirtualTrees.Types.TFormatArray; - TFormatEtcArray = VirtualTrees.Types.TFormatEtcArray; - TVTPaintOption = VirtualTrees.Types.TVTPaintOption; - TVTPaintOptions = VirtualTrees.Types.TVTPaintOptions; - TVTAnimateOption = VirtualTrees.Types.TVTAnimationOption; - TVTAnimateOptions = VirtualTrees.Types.TVTAnimationOptions; - TVTAutoOption = VirtualTrees.Types.TVTAutoOption; - TVTAutoOptions = VirtualTrees.Types.TVTAutoOptions; - TVTSelectionOption = VirtualTrees.Types.TVTSelectionOption; - TVTSelectionOptions = VirtualTrees.Types.TVTSelectionOptions; - TVTEditOptions = VirtualTrees.Types.TVTEditOptions; - TVTMiscOption = VirtualTrees.Types.TVTMiscOption; - TVTMiscOptions = VirtualTrees.Types.TVTMiscOptions; - TVTExportMode = VirtualTrees.Types.TVTExportMode; - TVTStringOption = VirtualTrees.Types.TVTStringOption; - TVTStringOptions = VirtualTrees.Types.TVTStringOptions; - TCustomVirtualTreeOptions = VirtualTrees.Types.TCustomVirtualTreeOptions; - TVirtualTreeOptions = VirtualTrees.Types.TVirtualTreeOptions; - TTreeOptionsClass = VirtualTrees.Types.TTreeOptionsClass; - TCustomStringTreeOptions = VirtualTrees.Types.TCustomStringTreeOptions; - TStringTreeOptions = VirtualTrees.Types.TStringTreeOptions; + // The exception used by the trees. + EVirtualTreeError = class(Exception); - TScrollBarStyle = VirtualTrees.Types.TScrollBarStyle; - TScrollBarOptions = VirtualTrees.Types.TScrollBarOptions; + PCardinal = ^Cardinal; - TVTColumnOption = VirtualTrees.Types.TVTColumnOption; - TVTColumnOptions = VirtualTrees.Types.TVTColumnOptions; - TVirtualTreeColumnStyle = VirtualTrees.Types.TVirtualTreeColumnStyle; - TSortDirection = VirtualTrees.Types.TSortDirection; - TCheckType = VirtualTrees.Types.TCheckType; - TCheckState = VirtualTrees.Types.TCheckState; - TVTDropMarkMode = VirtualTrees.Types.TVTDropMarkMode; - TScrollDirections = VirtualTrees.Types.TScrollDirections; - TVirtualTreeColumn = VirtualTrees.Header.TVirtualTreeColumn; - TVirtualTreeColumns = VirtualTrees.Header.TVirtualTreeColumns; - TVirtualTreeColumnClass = VirtualTrees.Header.TVirtualTreeColumnClass; - TColumnsArray = VirtualTrees.Header.TColumnsArray; - TCardinalArray = VirtualTrees.Header.TCardinalArray; - TIndexArray = VirtualTrees.Header.TIndexArray; - - TVTHeader = VirtualTrees.Header.TVTHeader; - TVTHeaderClass = VirtualTrees.Header.TVTHeaderClass; - TVTHeaderOption = VirtualTrees.Header.TVTHeaderOption; - TVTHeaderOptions = VirtualTrees.Header.TVTHeaderOptions; - THeaderPaintInfo = VirtualTrees.Header.THeaderPaintInfo; - TVTHeaderColumnLayout = VirtualTrees.Types.TVTHeaderColumnLayout; - TVTConstraintPercent = VirtualTrees.Header.TVTConstraintPercent; - TSmartAutoFitType = VirtualTrees.Types.TSmartAutoFitType; - TVTFixedAreaConstraints = VirtualTrees.Header.TVTFixedAreaConstraints; - TVTHeaderStyle = VirtualTrees.Header.TVTHeaderStyle; - THeaderState = VirtualTrees.Header.THeaderState; - THeaderStates = VirtualTrees.Header.THeaderStates; - - TVTColors = VirtualTrees.Colors.TVTColors; - // + // Limits the speed interval which can be used for auto scrolling (milliseconds). + TAutoScrollInterval = 1..1000; // Be careful when adding new states as this might change the size of the type which in turn // changes the alignment in the node record as well as the stream chunks. @@ -221,7 +252,33 @@ type ); TVirtualNodeInitStates = set of TVirtualNodeInitState; + TScrollBarStyle = ( + sbmRegular, + sbm3D + ); + // Options per column. + TVTColumnOption = ( + coAllowClick, // Column can be clicked (must be enabled too). + coDraggable, // Column can be dragged. + coEnabled, // Column is enabled. + coParentBidiMode, // Column uses the parent's bidi mode. + coParentColor, // Column uses the parent's background color. + coResizable, // Column can be resized. + coShowDropMark, // Column shows the drop mark if it is currently the drop target. + coVisible, // Column is shown. + coAutoSpring, // Column takes part in the auto spring feature of the header (must be resizable too). + coFixed, // Column is fixed and can not be selected or scrolled etc. + coSmartResize, // Column is resized to its largest entry which is in view (instead of its largest + // visible entry). + coAllowFocus, // Column can be focused. + coDisableAnimatedResize, // Column resizing is not animated. + coWrapCaption, // Caption could be wrapped across several header lines to fit columns width. + coUseCaptionAlignment, // Column's caption has its own aligment. + coEditable, // Column can be edited + coStyleColor // Prefer background color of VCL style over TVirtualTreeColumn.Color + ); + TVTColumnOptions = set of TVTColumnOption; // These flags are used to indicate where a click in the header happened. TVTHeaderHitPosition = ( @@ -254,6 +311,51 @@ type ); THitPositions = set of THitPosition; + TCheckType = ( + ctNone, + ctTriStateCheckBox, + ctCheckBox, + ctRadioButton, + ctButton + ); + + // The check states include both, transient and fluent (temporary) states. The only temporary state defined so + // far is the pressed state. + TCheckState = ( + csUncheckedNormal, // unchecked and not pressed + csUncheckedPressed, // unchecked and pressed + csCheckedNormal, // checked and not pressed + csCheckedPressed, // checked and pressed + csMixedNormal, // 3-state check box and not pressed + csMixedPressed, // 3-state check box and pressed + csUncheckedDisabled,// disabled checkbox, not checkable + csCheckedDisabled, // disabled checkbox, not uncheckable + csMixedDisabled // disabled 3-state checkbox + ); + + /// Adds some convenience methods to type TCheckState + TCheckStateHelper = record helper for TCheckState + strict private + const + // Lookup to quickly convert a specific check state into its pressed counterpart and vice versa. + cPressedState: array[TCheckState] of TCheckState = ( + csUncheckedPressed, csUncheckedPressed, csCheckedPressed, csCheckedPressed, csMixedPressed, csMixedPressed, csUncheckedDisabled, csCheckedDisabled, csMixedDisabled); + cUnpressedState: array[TCheckState] of TCheckState = ( + csUncheckedNormal, csUncheckedNormal, csCheckedNormal, csCheckedNormal, csMixedNormal, csMixedNormal, csUncheckedDisabled, csCheckedDisabled, csMixedDisabled); + cEnabledState: array[TCheckState] of TCheckState = ( + csUncheckedNormal, csUncheckedPressed, csCheckedNormal, csCheckedPressed, csMixedNormal, csMixedPressed, csUncheckedNormal, csCheckedNormal, csMixedNormal); + cToggledState: array[TCheckState] of TCheckState = ( + csCheckedNormal, csCheckedPressed, csUnCheckedNormal, csUnCheckedPressed, csCheckedNormal, csCheckedPressed, csUncheckedDisabled, csCheckedDisabled, csMixedDisabled); + public + function GetPressed(): TCheckState; inline; + function GetUnpressed(): TCheckState; inline; + function GetEnabled(): TCheckState; inline; + function GetToggled(): TCheckState; inline; + function IsDisabled(): Boolean; inline; + function IsChecked(): Boolean; inline; + function IsUnChecked(): Boolean; inline; + function IsMixed(): Boolean; inline; + end; TCheckImageKind = ( ckCustom, // application defined check images @@ -327,6 +429,138 @@ type ); + // There is a heap of switchable behavior in the tree. Since published properties may never exceed 4 bytes, + // which limits sets to at most 32 members, and because for better overview tree options are splitted + // in various sub-options and are held in a commom options class. + // + // Options to customize tree appearance: + TVTPaintOption = ( + toHideFocusRect, // Avoid drawing the dotted rectangle around the currently focused node. + toHideSelection, // Selected nodes are drawn as unselected nodes if the tree is unfocused. + toHotTrack, // Track which node is under the mouse cursor. + toPopupMode, // Paint tree as would it always have the focus (useful for tree combo boxes etc.) + toShowBackground, // Use the background image if there's one. + toShowButtons, // Display collapse/expand buttons left to a node. + toShowDropmark, // Show the dropmark during drag'n drop operations. + toShowHorzGridLines, // Display horizontal lines to simulate a grid. + toShowRoot, // Show lines also at top level (does not show the hidden/internal root node). + toShowTreeLines, // Display tree lines to show hierarchy of nodes. + toShowVertGridLines, // Display vertical lines (depending on columns) to simulate a grid. + toThemeAware, // Draw UI elements (header, tree buttons etc.) according to the current theme if + // enabled (Windows XP+ only, application must be themed). + toUseBlendedImages, // Enable alpha blending for ghosted nodes or those which are being cut/copied. + toGhostedIfUnfocused, // Ghosted images are still shown as ghosted if unfocused (otherwise the become non-ghosted + // images). + toFullVertGridLines, // Display vertical lines over the full client area, not only the space occupied by nodes. + // This option only has an effect if toShowVertGridLines is enabled too. + toAlwaysHideSelection, // Do not draw node selection, regardless of focused state. + toUseBlendedSelection, // Enable alpha blending for node selections. + toStaticBackground, // Show simple static background instead of a tiled one. + toChildrenAbove, // Display child nodes above their parent. + toFixedIndent, // Draw the tree with a fixed indent. + toUseExplorerTheme, // Use the explorer theme if run under Windows Vista (or above). + toHideTreeLinesIfThemed, // Do not show tree lines if theming is used. + toShowFilteredNodes // Draw nodes even if they are filtered out. + ); + TVTPaintOptions = set of TVTPaintOption; + + { Options to toggle animation support: + **Do not use toAnimatedToggle when a background image is used for the tree. + The animation does not look good as the image splits and moves with it. + } + TVTAnimationOption = ( + toAnimatedToggle, // Expanding and collapsing a node is animated (quick window scroll). + // **See note above. + toAdvancedAnimatedToggle // Do some advanced animation effects when toggling a node. + ); + TVTAnimationOptions = set of TVTAnimationOption; + + // Options which toggle automatic handling of certain situations: + TVTAutoOption = ( + toAutoDropExpand, // Expand node if it is the drop target for more than a certain time. + toAutoExpand, // Nodes are expanded (collapsed) when getting (losing) the focus. + toAutoScroll, // Scroll if mouse is near the border while dragging or selecting. + toAutoScrollOnExpand, // Scroll as many child nodes in view as possible after expanding a node. + toAutoSort, // Sort tree when Header.SortColumn or Header.SortDirection change or sort node if + // child nodes are added. Sorting will take place also if SortColum is NoColumn (-1). + toAutoSpanColumns, // Large entries continue into next column(s) if there's no text in them (no clipping). + toAutoTristateTracking, // Checkstates are automatically propagated for tri state check boxes. + toAutoHideButtons, // Node buttons are hidden when there are child nodes, but all are invisible. + toAutoDeleteMovedNodes, // Delete nodes which where moved in a drag operation (if not directed otherwise). + toDisableAutoscrollOnFocus, // Disable scrolling a node or column into view if it gets focused. + toAutoChangeScale, // Change default node height automatically if the system's font scale is set to big fonts. + toAutoFreeOnCollapse, // Frees any child node after a node has been collapsed (HasChildren flag stays there). + toDisableAutoscrollOnEdit, // Do not center a node horizontally when it is edited. + toAutoBidiColumnOrdering // When set then columns (if any exist) will be reordered from lowest index to highest index + // and vice versa when the tree's bidi mode is changed. + ); + TVTAutoOptions = set of TVTAutoOption; + + // Options which determine the tree's behavior when selecting nodes: + TVTSelectionOption = ( + toDisableDrawSelection, // Prevent user from selecting with the selection rectangle in multiselect mode. + toExtendedFocus, // Entries other than in the main column can be selected, edited etc. + toFullRowSelect, // Hit test as well as selection highlight are not constrained to the text of a node. + toLevelSelectConstraint, // Constrain selection to the same level as the selection anchor. + toMiddleClickSelect, // Allow selection, dragging etc. with the middle mouse button. This and toWheelPanning + // are mutual exclusive. + toMultiSelect, // Allow more than one node to be selected. + toRightClickSelect, // Allow selection, dragging etc. with the right mouse button. + toSiblingSelectConstraint, // Constrain selection to nodes with same parent. + toCenterScrollIntoView, // Center nodes vertically in the client area when scrolling into view. + toSimpleDrawSelection, // Simplifies draw selection, so a node's caption does not need to intersect with the + // selection rectangle. + toAlwaysSelectNode, // If this flag is set to true, the tree view tries to always have a node selected. + // This behavior is closer to the Windows TreeView and useful in Windows Explorer style applications. + toRestoreSelection, // Set to true if upon refill the previously selected nodes should be selected again. + // The nodes will be identified by its caption (text in MainColumn) + // You may use TVTHeader.RestoreSelectiuonColumnIndex to define an other column that should be used for indentification. + toSyncCheckboxesWithSelection // If checkboxes are shown, they follow the change in selections. When checkboxes are + // changed, the selections follow them and vice-versa. + // **Only supported for ctCheckBox type checkboxes. + ); + TVTSelectionOptions = set of TVTSelectionOption; + + TVTEditOptions = ( + toDefaultEdit, // Standard behaviour for end of editing (after VK_RETURN stay on edited cell). + toVerticalEdit, // After VK_RETURN switch to next column. + toHorizontalEdit // After VK_RETURN switch to next row. + ); + + // Options which do not fit into any of the other groups: + TVTMiscOption = ( + toAcceptOLEDrop, // Register tree as OLE accepting drop target + toCheckSupport, // Show checkboxes/radio buttons. + toEditable, // Node captions can be edited. + toFullRepaintOnResize, // Fully invalidate the tree when its window is resized (CS_HREDRAW/CS_VREDRAW). + toGridExtensions, // Use some special enhancements to simulate and support grid behavior. + toInitOnSave, // Initialize nodes when saving a tree to a stream. + toReportMode, // Tree behaves like TListView in report mode. + toToggleOnDblClick, // Toggle node expansion state when it is double clicked. + toWheelPanning, // Support for mouse panning (wheel mice only). This option and toMiddleClickSelect are + // mutal exclusive, where panning has precedence. + toReadOnly, // The tree does not allow to be modified in any way. No action is executed and + // node editing is not possible. + toVariableNodeHeight, // When set then GetNodeHeight will trigger OnMeasureItem to allow variable node heights. + toFullRowDrag, // Start node dragging by clicking anywhere in it instead only on the caption or image. + // Must be used together with toDisableDrawSelection. + toNodeHeightResize, // Allows changing a node's height via mouse. + toNodeHeightDblClickResize, // Allows to reset a node's height to FDefaultNodeHeight via a double click. + toEditOnClick, // Editing mode can be entered with a single click + toEditOnDblClick, // Editing mode can be entered with a double click + toReverseFullExpandHotKey // Used to define Ctrl+'+' instead of Ctrl+Shift+'+' for full expand (and similar for collapsing) + ); + TVTMiscOptions = set of TVTMiscOption; + + // Options to control data export + TVTExportMode = ( + emAll, // export all records (regardless checked state) + emChecked, // export checked records only + emUnchecked, // export unchecked records only + emVisibleDueToExpansion, //Do not export nodes that are not visible because their parent is not expanded + emSelected // export selected nodes only + ); + // Kinds of operations TVTOperationKind = ( okAutoFitColumns, @@ -354,12 +588,31 @@ type /// An array that can be used to calculate the offsets ofthe elements in the tree. TVTOffsets = array [TVTElement] of TDimension; + TAddPopupItemType = ( + apNormal, + apDisabled, + apHidden + ); + +const + DefaultPaintOptions = [toShowButtons, toShowDropmark, toShowTreeLines, toShowRoot, toThemeAware, toUseBlendedImages]; + DefaultAnimationOptions = []; + DefaultAutoOptions = [toAutoDropExpand, toAutoTristateTracking, toAutoScrollOnExpand, toAutoDeleteMovedNodes, toAutoChangeScale, toAutoSort]; + DefaultSelectionOptions = []; + DefaultMiscOptions = [toAcceptOLEDrop, toFullRepaintOnResize, toInitOnSave, toToggleOnDblClick, toWheelPanning, + toEditOnClick]; + DefaultColumnOptions = [coAllowClick, coDraggable, coEnabled, coParentColor, coParentBidiMode, coResizable, + coShowDropmark, coVisible, coAllowFocus, coEditable, coStyleColor]; + type TBaseVirtualTree = class; TVirtualTreeClass = class of TBaseVirtualTree; PVirtualNode = ^TVirtualNode; + TColumnIndex = type Integer; + TColumnPosition = type Cardinal; + // This record must already be defined here and not later because otherwise BCB users will not be able // to compile (conversion done by BCB is wrong). TCacheEntry = record @@ -370,6 +623,51 @@ type TCache = array of TCacheEntry; TNodeArray = array of PVirtualNode; + TCustomVirtualTreeOptions = class(TPersistent) + private + FOwner: TBaseVirtualTree; + FPaintOptions: TVTPaintOptions; + FAnimationOptions: TVTAnimationOptions; + FAutoOptions: TVTAutoOptions; + FSelectionOptions: TVTSelectionOptions; + FMiscOptions: TVTMiscOptions; + FExportMode: TVTExportMode; + FEditOptions: TVTEditOptions; + procedure SetAnimationOptions(const Value: TVTAnimationOptions); + procedure SetAutoOptions(const Value: TVTAutoOptions); + procedure SetMiscOptions(const Value: TVTMiscOptions); + procedure SetPaintOptions(const Value: TVTPaintOptions); + procedure SetSelectionOptions(const Value: TVTSelectionOptions); + protected + // 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(AControl: TControl = nil): TCustomStyleServices; + //these bypass the side effects in the regular setters. + procedure InternalSetMiscOptions(const Value: TVTMiscOptions); + public + constructor Create(AOwner: TBaseVirtualTree); virtual; + procedure AssignTo(Dest: TPersistent); override; + property AnimationOptions: TVTAnimationOptions read FAnimationOptions write SetAnimationOptions default DefaultAnimationOptions; + property AutoOptions: TVTAutoOptions read FAutoOptions write SetAutoOptions default DefaultAutoOptions; + property ExportMode: TVTExportMode read FExportMode write FExportMode default emAll; + property MiscOptions: TVTMiscOptions read FMiscOptions write SetMiscOptions default DefaultMiscOptions; + property PaintOptions: TVTPaintOptions read FPaintOptions write SetPaintOptions default DefaultPaintOptions; + property SelectionOptions: TVTSelectionOptions read FSelectionOptions write SetSelectionOptions default DefaultSelectionOptions; + property EditOptions: TVTEditOptions read FEditOptions write FEditOptions default toDefaultEdit; + + property Owner: TBaseVirtualTree read FOwner; + end; + + TTreeOptionsClass = class of TCustomVirtualTreeOptions; + + TVirtualTreeOptions = class(TCustomVirtualTreeOptions) + published + property AnimationOptions; + property AutoOptions; + property ExportMode; + property MiscOptions; + property PaintOptions; + property SelectionOptions; + end; // Used in the CF_VTREFERENCE clipboard format. PVTReference = ^TVTReference; @@ -428,7 +726,38 @@ type HitPoint: TPoint; end; + // auto scroll directions + TScrollDirections = set of ( + sdLeft, + sdUp, + sdRight, + sdDown + ); + // OLE drag'n drop support + TFormatEtcArray = array of TFormatEtc; + TFormatArray = array of Word; + + // IDataObject.SetData support + TInternalStgMedium = packed record + Format: TClipFormat; + Medium: TStgMedium; + end; + TInternalStgMediumArray = array of TInternalStgMedium; + + TEnumFormatEtc = class(TInterfacedObject, IEnumFormatEtc) + private + FTree: TBaseVirtualTree; + FFormatEtcArray: TFormatEtcArray; + FCurrentIndex: Integer; + public + constructor Create(Tree: TBaseVirtualTree; const AFormatEtcArray: TFormatEtcArray); + + function Clone(out Enum: IEnumFormatEtc): HResult; stdcall; + function Next(celt: Integer; out elt; pceltFetched: PLongint): HResult; stdcall; + function Reset: HResult; stdcall; + function Skip(celt: Integer): HResult; stdcall; + end; // ----- OLE drag'n drop handling @@ -446,7 +775,73 @@ type property IsDropTarget: Boolean read GetIsDropTarget; end; + // This data object is used in two different places. One is for clipboard operations and the other while dragging. + TVTDataObject = class(TInterfacedObject, IDataObject) + private + FOwner: TBaseVirtualTree; // The tree which provides clipboard or drag data. + FForClipboard: Boolean; // Determines which data to render with GetData. + FFormatEtcArray: TFormatEtcArray; + FInternalStgMediumArray: TInternalStgMediumArray; // The available formats in the DataObject + FAdviseHolder: IDataAdviseHolder; // Reference to an OLE supplied implementation for advising. + protected + function CanonicalIUnknown(const TestUnknown: IUnknown): IUnknown; + function EqualFormatEtc(FormatEtc1, FormatEtc2: TFormatEtc): Boolean; + function FindFormatEtc(TestFormatEtc: TFormatEtc; const FormatEtcArray: TFormatEtcArray): integer; + function FindInternalStgMedium(Format: TClipFormat): PStgMedium; + function HGlobalClone(HGlobal: THandle): THandle; + function RenderInternalOLEData(const FormatEtcIn: TFormatEtc; var Medium: TStgMedium; var OLEResult: HResult): Boolean; + function StgMediumIncRef(const InStgMedium: TStgMedium; var OutStgMedium: TStgMedium; + CopyInMedium: Boolean; const DataObject: IDataObject): HRESULT; + property ForClipboard: Boolean read FForClipboard; + property FormatEtcArray: TFormatEtcArray read FFormatEtcArray write FFormatEtcArray; + property InternalStgMediumArray: TInternalStgMediumArray read FInternalStgMediumArray write FInternalStgMediumArray; + property Owner: TBaseVirtualTree read FOwner; + public + constructor Create(AOwner: TBaseVirtualTree; ForClipboard: Boolean); virtual; + destructor Destroy; override; + + function DAdvise(const FormatEtc: TFormatEtc; advf: Integer; const advSink: IAdviseSink; out dwConnection: Integer): + HResult; virtual; stdcall; + function DUnadvise(dwConnection: Integer): HResult; virtual; stdcall; + function EnumDAdvise(out enumAdvise: IEnumStatData): HResult; virtual; stdcall; + function EnumFormatEtc(Direction: Integer; out EnumFormatEtc: IEnumFormatEtc): HResult; virtual; stdcall; + function GetCanonicalFormatEtc(const FormatEtc: TFormatEtc; out FormatEtcOut: TFormatEtc): HResult; virtual; stdcall; + function GetData(const FormatEtcIn: TFormatEtc; out Medium: TStgMedium): HResult; virtual; stdcall; + function GetDataHere(const FormatEtc: TFormatEtc; out Medium: TStgMedium): HResult; virtual; stdcall; + function QueryGetData(const FormatEtc: TFormatEtc): HResult; virtual; stdcall; + function SetData(const FormatEtc: TFormatEtc; var Medium: TStgMedium; DoRelease: BOOL): HResult; virtual; stdcall; + end; + + // TVTDragManager is a class to manage drag and drop in a Virtual Treeview. + TVTDragManager = class(TInterfacedObject, IVTDragManager, IDropSource, IDropTarget) + private + FOwner, // The tree which is responsible for drag management. + FDragSource: TBaseVirtualTree; // Reference to the source tree if the source was a VT, might be different than + // the owner tree. + FIsDropTarget: Boolean; // True if the owner is currently the drop target. + FDataObject: IDataObject; // A reference to the data object passed in by DragEnter (only used when the owner + // tree is the current drop target). + FDropTargetHelper: IDropTargetHelper; // Win2k > Drag image support + FFullDragging: BOOL; // True, if full dragging is currently enabled in the system. + + function GetDataObject: IDataObject; stdcall; + function GetDragSource: TBaseVirtualTree; stdcall; + function GetDropTargetHelperSupported: Boolean; stdcall; + function GetIsDropTarget: Boolean; stdcall; + public + constructor Create(AOwner: TBaseVirtualTree); virtual; + destructor Destroy; override; + + function DragEnter(const DataObject: IDataObject; KeyState: Integer; Pt: TPoint; + var Effect: Longint): HResult; stdcall; + function DragLeave: HResult; stdcall; + function DragOver(KeyState: Integer; Pt: TPoint; var Effect: LongInt): HResult; stdcall; + function Drop(const DataObject: IDataObject; KeyState: Integer; Pt: TPoint; var Effect: Integer): HResult; stdcall; + procedure ForceDragLeave; stdcall; + function GiveFeedback(Effect: Integer): HResult; stdcall; + function QueryContinueDrag(EscapePressed: BOOL; KeyState: Integer): HResult; stdcall; + end; PVTHintData = ^TVTHintData; TVTHintData = record @@ -477,6 +872,431 @@ type function IsHintMsg(var Msg: TMsg): Boolean; override; end; + // Drag image support for the tree. + TVTTransparency = 0..255; + TVTBias = -128..127; + + // Simple move limitation for the drag image. + TVTDragMoveRestriction = ( + dmrNone, + dmrHorizontalOnly, + dmrVerticalOnly + ); + + TVTDragImageStates = set of ( + disHidden, // Internal drag image is currently hidden (always hidden if drag image helper interfaces are used). + disInDrag, // Drag image class is currently being used. + disPrepared, // Drag image class is prepared. + disSystemSupport // Running on Windows 2000 or higher. System supports drag images natively. + ); + + // Class to manage header and tree drag image during a drag'n drop operation. + TVTDragImage = class + private + FOwner: TBaseVirtualTree; + FBackImage, // backup of overwritten screen area + FAlphaImage, // target for alpha blending + FDragImage: TBitmap; // the actual drag image to blend to screen + FImagePosition, // position of image (upper left corner) in screen coordinates + FLastPosition: TPoint; // last mouse position in screen coordinates + FTransparency: TVTTransparency; // alpha value of the drag image (0 - fully transparent, 255 - fully opaque) + FPreBlendBias, // value to darken or lighten the drag image before it is blended + FPostBlendBias: TVTBias; // value to darken or lighten the alpha blend result + FFade: Boolean; // determines whether to fade the drag image from center to borders or not + FRestriction: TVTDragMoveRestriction; // determines in which directions the drag image can be moved + FColorKey: TColor; // color to make fully transparent regardless of any other setting + FStates: TVTDragImageStates; // Determines the states of the drag image class. + function GetVisible: Boolean; // True if the drag image is currently hidden (used only when dragging) + procedure InternalShowDragImage(ScreenDC: HDC); + procedure MakeAlphaChannel(Source, Target: TBitmap); + procedure RecaptureBackground(Tree: TBaseVirtualTree; R: TRect; VisibleRegion: HRGN; CaptureNCArea, + ReshowDragImage: Boolean); + function WillMove(P: TPoint): Boolean; + property Visible: Boolean read GetVisible; + property PreBlendBias: TVTBias read FPreBlendBias write FPreBlendBias default 0; + property Transparency: TVTTransparency read FTransparency write FTransparency default 128; + property ColorKey: TColor read FColorKey write FColorKey default clWindow; + property Fade: Boolean read FFade write FFade default False; + public + constructor Create(AOwner: TBaseVirtualTree); + destructor Destroy; override; + + function DragTo(P: TPoint; ForceRepaint: Boolean): Boolean; + procedure EndDrag; + function GetDragImageRect: TRect; + procedure HideDragImage; + procedure PrepareDrag(DragImage: TBitmap; ImagePosition, HotSpot: TPoint; const DataObject: IDataObject); + procedure ShowDragImage; + property ImagePosition : TPoint read FImagePosition; + property LastPosition : TPoint read FLastPosition; + property MoveRestriction: TVTDragMoveRestriction read FRestriction write FRestriction default dmrNone; + end; + + // tree columns implementation + TVirtualTreeColumns = class; + TVTHeader = class; + + TVirtualTreeColumnStyle = ( + vsText, + vsOwnerDraw + ); + + TVTHeaderColumnLayout = ( + blGlyphLeft, + blGlyphRight, + blGlyphTop, + blGlyphBottom + ); + + TSortDirection = ( + sdAscending, + sdDescending + ); + + TSortDirectionHelper = record helper for VirtualTrees.TSortDirection + strict private + const cSortDirectionToInt: Array [TSortDirection] of Integer = (1, -1); + public + /// Returns +1 for ascending and -1 for descending sort order. + function ToInt(): Integer; inline; + end; + + // Used during owner draw of the header to indicate which drop mark for the column must be drawn. + TVTDropMarkMode = ( + dmmNone, + dmmLeft, + dmmRight + ); + + TVirtualTreeColumn = class; + + // This structure carries all important information about header painting and is used in the advanced header painting. + THeaderPaintInfo = record + TargetCanvas: TCanvas; + Column: TVirtualTreeColumn; + PaintRectangle: TRect; + TextRectangle: TRect; + IsHoverIndex, + IsDownIndex, + IsEnabled, + ShowHeaderGlyph, + ShowSortGlyph, + ShowRightBorder: Boolean; + DropMark: TVTDropMarkMode; + GlyphPos, + SortGlyphPos: TPoint; + SortGlyphSize: TSize; + procedure DrawSortArrow(pDirection: TSortDirection); + procedure DrawDropMark(); + end; + + + TVirtualTreeColumn = class(TCollectionItem) + private + const cDefaultColumnSpacing = 3; + private + FText, + FHint: string; + FWidth: TDimension; + FPosition: TColumnPosition; + FMinWidth: TDimension; + FMaxWidth: TDimension; + FStyle: TVirtualTreeColumnStyle; + FImageIndex: TImageIndex; + FBiDiMode: TBiDiMode; + FLayout: TVTHeaderColumnLayout; + FMargin, + FSpacing: TDimension; + FOptions: TVTColumnOptions; + FEditOptions: TVTEditOptions; + FEditNextColumn: TDimension; + FTag: NativeInt; + FAlignment: TAlignment; + FCaptionAlignment: TAlignment; // Alignment of the caption. + FLastWidth: TDimension; + FColor: TColor; + FBonusPixel: Boolean; + FSpringRest: Single; // Accumulator for width adjustment when auto spring option is enabled. + FCaptionText: string; + FCheckBox: Boolean; + FCheckType: TCheckType; + FCheckState: TCheckState; + FImageRect: TRect; + FHasImage: Boolean; + FDefaultSortDirection: TSortDirection; + function GetCaptionAlignment: TAlignment; + function GetCaptionWidth: TDimension; + function GetLeft: TDimension; + function IsBiDiModeStored: Boolean; + function IsCaptionAlignmentStored: Boolean; + function IsColorStored: Boolean; + procedure SetAlignment(const Value: TAlignment); + procedure SetBiDiMode(Value: TBiDiMode); + procedure SetCaptionAlignment(const Value: TAlignment); + procedure SetCheckBox(Value: Boolean); + procedure SetCheckState(Value: TCheckState); + procedure SetCheckType(Value: TCheckType); + procedure SetColor(const Value: TColor); + procedure SetImageIndex(Value: TImageIndex); + procedure SetLayout(Value: TVTHeaderColumnLayout); + procedure SetMargin(Value: TDimension); + procedure SetMaxWidth(Value: TDimension); + procedure SetMinWidth(Value: TDimension); + procedure SetOptions(Value: TVTColumnOptions); + procedure SetPosition(Value: TColumnPosition); + procedure SetSpacing(Value: TDimension); + procedure SetStyle(Value: TVirtualTreeColumnStyle); + procedure SetWidth(Value: TDimension); + protected + FLeft: TDimension; + procedure ChangeScale(M, D: TDimension; isDpiChange: Boolean); virtual; + procedure ComputeHeaderLayout(var PaintInfo: THeaderPaintInfo; DrawFormat: Cardinal; CalculateTextRect: Boolean = False); + procedure DefineProperties(Filer: TFiler); override; + procedure GetAbsoluteBounds(var Left, Right: TDimension); + function GetDisplayName: string; override; + function GetText: string; virtual; // [IPK] + procedure SetText(const Value: string); virtual; // [IPK] private to protected & virtual + function GetOwner: TVirtualTreeColumns; reintroduce; + procedure InternalSetWidth(const value : TDimension); //bypass side effects in SetWidth + procedure ReadHint(Reader: TReader); + procedure ReadText(Reader: TReader); + procedure SetCollection(Value: TCollection); override; + public + constructor Create(Collection: TCollection); override; + destructor Destroy; override; + + procedure Assign(Source: TPersistent); override; + function Equals(OtherColumnObj: TObject): Boolean; override; + function GetRect: TRect; virtual; + property HasImage: Boolean read FHasImage; + property ImageRect: TRect read FImageRect; + procedure LoadFromStream(const Stream: TStream; Version: Integer); + procedure ParentBiDiModeChanged; + procedure ParentColorChanged; + procedure RestoreLastWidth; + function GetEffectiveColor(): TColor; + procedure SaveToStream(const Stream: TStream); + function UseRightToLeftReading: Boolean; + + property BonusPixel: Boolean read FBonusPixel write FBonusPixel; + property CaptionText: string read FCaptionText; + property Left: TDimension read GetLeft; + property Owner: TVirtualTreeColumns read GetOwner; + property SpringRest: Single read FSpringRest write FSpringRest; + published + property Alignment: TAlignment read FAlignment write SetAlignment default taLeftJustify; + property BiDiMode: TBiDiMode read FBiDiMode write SetBiDiMode stored IsBiDiModeStored; + property CaptionAlignment: TAlignment read GetCaptionAlignment write SetCaptionAlignment + stored IsCaptionAlignmentStored default taLeftJustify; + property CaptionWidth: TDimension read GetCaptionWidth; + property CheckType: TCheckType read FCheckType write SetCheckType default ctCheckBox; + property CheckState: TCheckState read FCheckState write SetCheckState default csUncheckedNormal; + property CheckBox: Boolean read FCheckBox write SetCheckBox default False; + property Color: TColor read FColor write SetColor stored IsColorStored; + property DefaultSortDirection: TSortDirection read FDefaultSortDirection write FDefaultSortDirection default sdAscending; + property Hint: string read FHint write FHint; + property ImageIndex: TImageIndex read FImageIndex write SetImageIndex default -1; + property Layout: TVTHeaderColumnLayout read FLayout write SetLayout default blGlyphLeft; + property Margin: TDimension read FMargin write SetMargin default 4; + property MaxWidth: TDimension read FMaxWidth write SetMaxWidth default 10000; + property MinWidth: TDimension read FMinWidth write SetMinWidth default 10; + property Options: TVTColumnOptions read FOptions write SetOptions default DefaultColumnOptions; + property EditOptions: TVTEditOptions read FEditOptions write FEditOptions default toDefaultEdit; + property EditNextColumn: TDimension read FEditNextColumn write FEditNextColumn default -1; + property Position: TColumnPosition read FPosition write SetPosition; + property Spacing: TDimension read FSpacing write SetSpacing default cDefaultColumnSpacing; + property Style: TVirtualTreeColumnStyle read FStyle write SetStyle default vsText; + property Tag: NativeInt read FTag write FTag default 0; + property Text: string read GetText write SetText; + property Width: TDimension read FWidth write SetWidth default 50; + end; + + TVirtualTreeColumnClass = class of TVirtualTreeColumn; + + TColumnsArray = array of TVirtualTreeColumn; + TCardinalArray = array of Cardinal; + TIndexArray = array of TColumnIndex; + + TVirtualTreeColumns = class(TCollection) + private + FHeader: TVTHeader; + FHeaderBitmap: TBitmap; // backbuffer for drawing + FHoverIndex, // currently "hot" column + FDownIndex, // Column on which a mouse button is held down. + FTrackIndex: TColumnIndex; // Index of column which is currently being resized. + FClickIndex: TColumnIndex; // Index of the last clicked column. + FCheckBoxHit: Boolean; // True if the last click was on a header checkbox. + FPositionToIndex: TIndexArray; + FDefaultWidth: TDimension; // the width columns are created with + FNeedPositionsFix: Boolean; // True if FixPositions must still be called after DFM loading or Bidi mode change. + FClearing: Boolean; // True if columns are being deleted entirely. + FColumnPopupMenu: TPopupMenu; // Member for storing the TVTHeaderPopupMenu + + function GetCount: TDimension; + function GetItem(Index: TColumnIndex): TVirtualTreeColumn; + function GetNewIndex(P: TPoint; var OldIndex: TColumnIndex): Boolean; + procedure SetDefaultWidth(Value: TDimension); + procedure SetItem(Index: TColumnIndex; Value: TVirtualTreeColumn); + protected + // drag support + FDragIndex: TColumnIndex; // index of column currently being dragged + FDropTarget: TColumnIndex; // current target column (index) while dragging + FDropBefore: Boolean; // True if drop position is in the left half of a column, False for the right + // side to drop the dragged column to + + procedure AdjustAutoSize(CurrentIndex: TColumnIndex; Force: Boolean = False); + function AdjustDownColumn(P: TPoint): TColumnIndex; + function AdjustHoverColumn(P: TPoint): Boolean; + procedure AdjustPosition(Column: TVirtualTreeColumn; Position: Cardinal); + function CanSplitterResize(P: TPoint; Column: TColumnIndex): Boolean; + procedure DoCanSplitterResize(P: TPoint; Column: TColumnIndex; var Allowed: Boolean); virtual; + procedure DrawButtonText(DC: HDC; Caption: string; Bounds: TRect; Enabled, Hot: Boolean; DrawFormat: Cardinal; + WrapCaption: Boolean); + procedure FixPositions; + function GetColumnAndBounds(P: TPoint; var ColumnLeft, ColumnRight: TDimension; Relative: Boolean = True): Integer; + function GetOwner: TPersistent; override; + function HandleClick(P: TPoint; Button: TMouseButton; Force, DblClick: Boolean): Boolean; virtual; + procedure HeaderPopupMenuAddHeaderPopupItem(const Sender: TBaseVirtualTree; const Column: TColumnIndex; + var Cmd: TAddPopupItemType); + procedure HeaderPopupMenuColumnChange(const Sender: TBaseVirtualTree; const Column: TColumnIndex; Visible: Boolean); + procedure IndexChanged(OldIndex, NewIndex: Integer); + procedure InitializePositionArray; + procedure Notify(Item: TCollectionItem; Action: System.Classes.TCollectionNotification); override; + procedure ReorderColumns(RTL: Boolean); + procedure SetHoverIndex(index : TColumnIndex); + procedure Update(Item: TCollectionItem); override; + procedure UpdatePositions(Force: Boolean = False); + + property HeaderBitmap: TBitmap read FHeaderBitmap; + property PositionToIndex: TIndexArray read FPositionToIndex; + property HoverIndex: TColumnIndex read FHoverIndex write FHoverIndex; + property DownIndex: TColumnIndex read FDownIndex write FDownIndex; + property CheckBoxHit: Boolean read FCheckBoxHit write FCheckBoxHit; + // 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(AControl: TControl = nil): TCustomStyleServices; + public + constructor Create(AOwner: TVTHeader); virtual; + destructor Destroy; override; + + function Add: TVirtualTreeColumn; virtual; + procedure AnimatedResize(Column: TColumnIndex; NewWidth: TDimension); + procedure Assign(Source: TPersistent); override; + procedure Clear; virtual; + function ColumnFromPosition(P: TPoint; Relative: Boolean = True): TColumnIndex; overload; virtual; + function ColumnFromPosition(PositionIndex: TColumnPosition): TColumnIndex; overload; virtual; + function Equals(OtherColumnsObj: TObject): Boolean; override; + procedure GetColumnBounds(Column: TColumnIndex; var Left, Right: TDimension); + function GetFirstVisibleColumn(ConsiderAllowFocus: Boolean = False): TColumnIndex; + function GetLastVisibleColumn(ConsiderAllowFocus: Boolean = False): TColumnIndex; + function GetFirstColumn: TColumnIndex; + function GetNextColumn(Column: TColumnIndex): TColumnIndex; + function GetNextVisibleColumn(Column: TColumnIndex; ConsiderAllowFocus: Boolean = False): TColumnIndex; + function GetPreviousColumn(Column: TColumnIndex): TColumnIndex; + function GetPreviousVisibleColumn(Column: TColumnIndex; ConsiderAllowFocus: Boolean = False): TColumnIndex; + function GetScrollWidth: TDimension; + function GetVisibleColumns: TColumnsArray; + function GetVisibleFixedWidth: TDimension; + function IsValidColumn(Column: TColumnIndex): Boolean; + procedure LoadFromStream(const Stream: TStream; Version: Integer); + procedure PaintHeader(DC: HDC; R: TRect; HOffset: TDimension); overload; virtual; + procedure PaintHeader(TargetCanvas: TCanvas; R: TRect; const Target: TPoint; + RTLOffset: TDimension = 0); overload; virtual; + procedure SaveToStream(const Stream: TStream); + procedure EndUpdate(); override; + function TotalWidth: TDimension; + + property Count: Integer read GetCount; + property ClickIndex: TColumnIndex read FClickIndex; + property DefaultWidth: TDimension read FDefaultWidth write SetDefaultWidth; + property DragIndex : TColumnIndex read FDragIndex write FDragIndex; + property DropBefore : boolean read FDropBefore write FDropBefore; + property DropTarget : TColumnIndex read FDropTarget write FDropTarget; + property Items[Index: TColumnIndex]: TVirtualTreeColumn read GetItem write SetItem; default; + property Header: TVTHeader read FHeader; + property TrackIndex: TColumnIndex read FTrackIndex write FTrackIndex; + end; + + TVirtualTreeColumnsClass = class of TVirtualTreeColumns; + + TVTConstraintPercent = 0..100; + TVTFixedAreaConstraints = class(TPersistent) + private + FHeader: TVTHeader; + FMaxHeightPercent, + FMaxWidthPercent, + FMinHeightPercent, + FMinWidthPercent: TVTConstraintPercent; + FOnChange: TNotifyEvent; + procedure SetConstraints(Index: Integer; Value: TVTConstraintPercent); + protected + procedure Change; + property Header: TVTHeader read FHeader; + public + constructor Create(AOwner: TVTHeader); + + procedure Assign(Source: TPersistent); override; + property OnChange: TNotifyEvent read FOnChange write FOnChange; + published + property MaxHeightPercent: TVTConstraintPercent index 0 read FMaxHeightPercent write SetConstraints default 0; + property MaxWidthPercent: TVTConstraintPercent index 1 read FMaxWidthPercent write SetConstraints default 95; + property MinHeightPercent: TVTConstraintPercent index 2 read FMinHeightPercent write SetConstraints default 0; + property MinWidthPercent: TVTConstraintPercent index 3 read FMinWidthPercent write SetConstraints default 0; + end; + + TVTHeaderStyle = ( + hsThickButtons, // TButton look and feel + hsFlatButtons, // flatter look than hsThickButton, like an always raised flat TToolButton + hsPlates // flat TToolButton look and feel (raise on hover etc.) + ); + + TVTHeaderOption = ( + hoAutoResize, // Adjust a column so that the header never exceeds the client width of the owner control. + hoColumnResize, // Resizing columns with the mouse is allowed. + hoDblClickResize, // Allows a column to resize itself to its largest entry. + hoDrag, // Dragging columns is allowed. + hoHotTrack, // Header captions are highlighted when mouse is over a particular column. + hoOwnerDraw, // Header items with the owner draw style can be drawn by the application via event. + hoRestrictDrag, // Header can only be dragged horizontally. + hoShowHint, // Show application defined header hint. + hoShowImages, // Show header images. + hoShowSortGlyphs, // Allow visible sort glyphs. + hoVisible, // Header is visible. + hoAutoSpring, // Distribute size changes of the header to all columns, which are sizable and have the + // coAutoSpring option enabled. + hoFullRepaintOnResize, // Fully invalidate the header (instead of subsequent columns only) when a column is resized. + hoDisableAnimatedResize, // Disable animated resize for all columns. + hoHeightResize, // Allow resizing header height via mouse. + hoHeightDblClickResize, // Allow the header to resize itself to its default height. + hoHeaderClickAutoSort, // Clicks on the header will make the clicked column the SortColumn or toggle sort direction if + // it already was the sort column + hoAutoColumnPopupMenu, // Show a context menu for activating and deactivating columns on right click + hoAutoResizeInclCaption // Includes the header caption for the auto resizing + ); + TVTHeaderOptions = set of TVTHeaderOption; + + THeaderState = ( + hsAutoSizing, // auto size chain is in progess, do not trigger again on WM_SIZE + hsDragging, // header dragging is in progress (only if enabled) + hsDragPending, // left button is down, user might want to start dragging a column + hsLoading, // The header currently loads from stream, so updates are not necessary. + hsColumnWidthTracking, // column resizing is in progress + hsColumnWidthTrackPending, // left button is down, user might want to start resize a column + hsHeightTracking, // height resizing is in progress + hsHeightTrackPending, // left button is down, user might want to start changing height + hsResizing, // multi column resizing in progress + hsScaling, // the header is scaled after a change of FixedAreaConstraints or client size + hsNeedScaling // the header needs to be scaled + ); + THeaderStates = set of THeaderState; + + + TSmartAutoFitType = ( + smaAllColumns, // consider nodes in view only for all columns + smaNoColumn, // consider nodes in view only for no column + smaUseColumnOption // use coSmartResize of the corresponding column + ); // describes the used column resize behaviour for AutoFitColumns + + TChangeReason = ( crIgnore, // used as placeholder crAccumulated, // used for delayed changes @@ -487,6 +1307,138 @@ type crNodeMoved // a node has been moved to a new place ); // desribes what made a structure change event happen + TVTHeader = class(TPersistent) + private + FOwner: TBaseVirtualTree; + FColumns: TVirtualTreeColumns; + FHeight: TDimension; + FFont: TFont; + FParentFont: Boolean; + FOptions: TVTHeaderOptions; + FStyle: TVTHeaderStyle; // button style + FBackgroundColor: TColor; + FAutoSizeIndex: TColumnIndex; + FPopupMenu: TPopupMenu; + FMainColumn: TColumnIndex; // the column which holds the tree + FMaxHeight: TDimension; + FMinHeight: TDimension; + FDefaultHeight: TDimension; + FFixedAreaConstraints: TVTFixedAreaConstraints; // Percentages for the fixed area (header, fixed columns). + FImages: TCustomImageList; + FImageChangeLink: TChangeLink; // connections to the image list to get notified about changes + fSplitterHitTolerance: TDimension; // For property SplitterHitTolerance + FSortColumn: TColumnIndex; + FSortDirection: TSortDirection; + FDragImage: TVTDragImage; // drag image management during header drag + FLastWidth: TDimension; // Used to adjust spring columns. This is the width of all visible columns, not the header rectangle. + FRestoreSelectionColumnIndex: Integer; // The column that is used to implement the coRestoreSelection option + function GetMainColumn: TColumnIndex; + function GetUseColumns: Boolean; + function IsFontStored: Boolean; + procedure SetAutoSizeIndex(Value: TColumnIndex); + procedure SetBackground(Value: TColor); + procedure SetColumns(Value: TVirtualTreeColumns); + procedure SetDefaultHeight(Value: TDimension); + procedure SetFont(const Value: TFont); + procedure SetHeight(Value: TDimension); + procedure SetImages(const Value: TCustomImageList); + procedure SetMainColumn(Value: TColumnIndex); + procedure SetMaxHeight(Value: TDimension); + procedure SetMinHeight(Value: TDimension); + procedure SetOptions(Value: TVTHeaderOptions); + procedure SetParentFont(Value: Boolean); + procedure SetSortColumn(Value: TColumnIndex); + procedure SetSortDirection(const Value: TSortDirection); + procedure SetStyle(Value: TVTHeaderStyle); + function GetRestoreSelectionColumnIndex: Integer; + protected + FStates: THeaderStates; // Used to keep track of internal states the header can enter. + FDragStart: TPoint; // initial mouse drag position + FTrackStart: TPoint; // client coordinates of the tracking start point + FTrackPoint: TPoint; // Client coordinate where the tracking started. + FDoingAutoFitColumns: boolean; // Flag to avoid using the stored width for Main column + + procedure FontChanged(Sender: TObject); virtual; + procedure AutoScale(); virtual; + function CanSplitterResize(P: TPoint): Boolean; + function CanWriteColumns: Boolean; virtual; + procedure ChangeScale(M, D: TDimension; isDpiChange: Boolean); virtual; + function DetermineSplitterIndex(P: TPoint): Boolean; virtual; + procedure DoAfterAutoFitColumn(Column: TColumnIndex); virtual; + procedure DoAfterColumnWidthTracking(Column: TColumnIndex); virtual; + procedure DoAfterHeightTracking; virtual; + function DoBeforeAutoFitColumn(Column: TColumnIndex; SmartAutoFitType: TSmartAutoFitType): Boolean; virtual; + procedure DoBeforeColumnWidthTracking(Column: TColumnIndex; Shift: TShiftState); virtual; + procedure DoBeforeHeightTracking(Shift: TShiftState); virtual; + procedure DoCanSplitterResize(P: TPoint; var Allowed: Boolean); virtual; + function DoColumnWidthDblClickResize(Column: TColumnIndex; P: TPoint; Shift: TShiftState): Boolean; virtual; + function DoColumnWidthTracking(Column: TColumnIndex; Shift: TShiftState; var TrackPoint: TPoint; P: TPoint): Boolean; virtual; + function DoGetPopupMenu(Column: TColumnIndex; Position: TPoint): TPopupMenu; virtual; + function DoHeightTracking(var P: TPoint; Shift: TShiftState): Boolean; virtual; + function DoHeightDblClickResize(var P: TPoint; Shift: TShiftState): Boolean; virtual; + procedure DoSetSortColumn(Value: TColumnIndex; pSortDirection: TSortDirection); virtual; + procedure DragTo(P: TPoint); virtual; + procedure FixedAreaConstraintsChanged(Sender: TObject); + function GetColumnsClass: TVirtualTreeColumnsClass; virtual; + function GetOwner: TPersistent; override; + function GetShiftState: TShiftState; + function HandleHeaderMouseMove(var Message: TWMMouseMove): Boolean; + function HandleMessage(var Message: TMessage): Boolean; virtual; + procedure ImageListChange(Sender: TObject); + procedure PrepareDrag(P, Start: TPoint); + procedure ReadColumns(Reader: TReader); + procedure RecalculateHeader; virtual; + procedure RescaleHeader; + procedure UpdateMainColumn; + procedure UpdateSpringColumns; + procedure WriteColumns(Writer: TWriter); + public + constructor Create(AOwner: TBaseVirtualTree); virtual; + destructor Destroy; override; + + function AllowFocus(ColumnIndex: TColumnIndex): Boolean; + procedure Assign(Source: TPersistent); override; + procedure AutoFitColumns(Animated: Boolean = True; SmartAutoFitType: TSmartAutoFitType = smaUseColumnOption; + RangeStartCol: Integer = NoColumn; RangeEndCol: Integer = NoColumn); virtual; + function InHeader(P: TPoint): Boolean; virtual; + function InHeaderSplitterArea(P: TPoint): Boolean; virtual; + procedure Invalidate(Column: TVirtualTreeColumn; ExpandToBorder: Boolean = False; UpdateNowFlag : Boolean = False); + procedure LoadFromStream(const Stream: TStream); virtual; + function ResizeColumns(ChangeBy: TDimension; RangeStartCol: TColumnIndex; RangeEndCol: TColumnIndex; + Options: TVTColumnOptions = [coVisible]): TDimension; + procedure RestoreColumns; + procedure SaveToStream(const Stream: TStream); virtual; + procedure StyleChanged(); virtual; + + property DragImage: TVTDragImage read FDragImage; + property RestoreSelectionColumnIndex: Integer read GetRestoreSelectionColumnIndex write fRestoreSelectionColumnIndex default NoColumn; + property States: THeaderStates read FStates; + property Treeview: TBaseVirtualTree read FOwner; + property UseColumns: Boolean read GetUseColumns; + property doingAutoFitColumns: boolean read FDoingAutoFitColumns; + published + property AutoSizeIndex: TColumnIndex read FAutoSizeIndex write SetAutoSizeIndex; + property Background: TColor read FBackgroundColor write SetBackground default clBtnFace; + property Columns: TVirtualTreeColumns read FColumns write SetColumns stored False; // Stored by the owner tree to support VFI. + property DefaultHeight: Integer read FDefaultHeight write SetDefaultHeight default 19; + property Font: TFont read FFont write SetFont stored IsFontStored; + property FixedAreaConstraints: TVTFixedAreaConstraints read FFixedAreaConstraints write FFixedAreaConstraints; + property Height: Integer read FHeight write SetHeight default 19; + property Images: TCustomImageList read FImages write SetImages; + property MainColumn: TColumnIndex read GetMainColumn write SetMainColumn default 0; + property MaxHeight: Integer read FMaxHeight write SetMaxHeight default 10000; + property MinHeight: Integer read FMinHeight write SetMinHeight default 10; + property Options: TVTHeaderOptions read FOptions write SetOptions default [hoColumnResize, hoDrag, hoShowSortGlyphs]; + property ParentFont: Boolean read FParentFont write SetParentFont default True; + property PopupMenu: TPopupMenu read FPopupMenu write FPopupMenu; + property SortColumn: TColumnIndex read FSortColumn write SetSortColumn default NoColumn; + property SortDirection: TSortDirection read FSortDirection write SetSortDirection default sdAscending; + property SplitterHitTolerance: Integer read fSplitterHitTolerance write fSplitterHitTolerance default 8; // The area in pixels around a spliter which is sensitive for resizing + property Style: TVTHeaderStyle read FStyle write SetStyle default hsThickButtons; + end; + + TVTHeaderClass = class of TVTHeader; + // Communication interface between a tree editor and the tree itself (declared as using stdcall in case it // is implemented in a (C/C++) DLL). The GUID is not nessecary in Delphi but important for BCB users // to allow QueryInterface and _uuidof calls. @@ -643,6 +1595,7 @@ type // A collection of line type IDs which is used while painting a node. TLineImage = array of TVTLineType; + TVTScrollIncrement = 1..10000; // Export type TVTExportType = ( @@ -662,6 +1615,106 @@ type TVTColumnExportEvent = procedure (Sender: TBaseVirtualTree; aExportType: TVTExportType; Column: TVirtualTreeColumn) of object; TVTTreeExportEvent = procedure(Sender: TBaseVirtualTree; aExportType: TVTExportType) of object; + // A class to manage scroll bar aspects. + TScrollBarOptions = class(TPersistent) + private + FAlwaysVisible: Boolean; + FOwner: TBaseVirtualTree; + FScrollBars: TScrollStyle; // used to hide or show vertical and/or horizontal scrollbar + FScrollBarStyle: TScrollBarStyle; // kind of scrollbars to use + FIncrementX, + FIncrementY: TVTScrollIncrement; // number of pixels to scroll in one step (when auto scrolling) + procedure SetAlwaysVisible(Value: Boolean); + procedure SetScrollBars(Value: TScrollStyle); + procedure SetScrollBarStyle(Value: TScrollBarStyle); + protected + function GetOwner: TPersistent; override; + public + constructor Create(AOwner: TBaseVirtualTree); + + procedure Assign(Source: TPersistent); override; + published + property AlwaysVisible: Boolean read FAlwaysVisible write SetAlwaysVisible default False; + property HorizontalIncrement: TVTScrollIncrement read FIncrementX write FIncrementX default 20; + property ScrollBars: TScrollStyle read FScrollBars write SetScrollBars default ssBoth; + property ScrollBarStyle: TScrollBarStyle read FScrollBarStyle write SetScrollBarStyle default sbmRegular; + property VerticalIncrement: TVTScrollIncrement read FIncrementY write FIncrementY default 20; + end; + + // class to collect all switchable colors into one place + TVTColors = class(TPersistent) + private + type + TVTColorEnum =(cDisabledColor, cDropMarkColor, cDropTargetColor, cFocusedSelectionColor, + cGridLineColor, cTreeLineColor, cUnfocusedSelectionColor, cBorderColor, cHotColor, + cFocusedSelectionBorderColor, cUnfocusedSelectionBorderColor, cDropTargetBorderColor, + cSelectionRectangleBlendColor, cSelectionRectangleBorderColor, cHeaderHotColor, + cSelectionTextColor, cUnfocusedColor); + + // Please make sure that the published Color properties at the corresponding index + // have the same color if you change anything here! + const cDefaultColors : array[TVTColorEnum] of TColor = ( + clBtnShadow, // DisabledColor + clHighlight, // DropMarkColor + clHighLight, // DropTargetColor + clHighLight, // FocusedSelectionColor + clBtnFace, // GridLineColor + clBtnShadow, // TreeLineColor + clInactiveCaption, // UnfocusedSelectionColor + clBtnFace, // BorderColor + clWindowText, // HotColor + clHighLight, // FocusedSelectionBorderColor + clInactiveCaption, // UnfocusedSelectionBorderColor + clHighlight, // DropTargetBorderColor + clHighlight, // SelectionRectangleBlendColor + clHighlight, // SelectionRectangleBorderColor + clBtnShadow, // HeaderHotColor + clHighlightText, // SelectionTextColor + clInactiveCaptionText); // UnfocusedColor [IPK] + + private + FOwner: TBaseVirtualTree; + FColors: array[TVTColorEnum] of TColor; // [IPK] 15 -> 16 + function GetColor(const Index: TVTColorEnum): TColor; + procedure SetColor(const Index: TVTColorEnum; const Value: TColor); + function GetBackgroundColor: TColor; + function GetHeaderFontColor: TColor; + function GetNodeFontColor: TColor; + function GetSelectedNodeFontColor(Focused:boolean): TColor; + public + constructor Create(AOwner: TBaseVirtualTree); + + procedure Assign(Source: TPersistent); override; + property BackGroundColor: TColor read GetBackgroundColor; + property HeaderFontColor: TColor read GetHeaderFontColor; + property NodeFontColor: TColor read GetNodeFontColor; + // 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(AControl: TControl = nil): TCustomStyleServices; + published + property BorderColor: TColor index cBorderColor read GetColor write SetColor default clBtnFace; + property DisabledColor: TColor index cDisabledColor read GetColor write SetColor default clBtnShadow; + property DropMarkColor: TColor index cDropMarkColor read GetColor write SetColor default clHighlight; + property DropTargetColor: TColor index cDropTargetColor read GetColor write SetColor default clHighLight; + property DropTargetBorderColor: TColor index cDropTargetBorderColor read GetColor write SetColor default clHighLight; + /// The background color of selected nodes in case the tree has the focus, or the toPopupMode flag is set. + property FocusedSelectionColor: TColor index cFocusedSelectionColor read GetColor write SetColor default clHighLight; + /// The border color of selected nodes when the tree has the focus. + property FocusedSelectionBorderColor: TColor index cFocusedSelectionBorderColor read GetColor write SetColor default clHighLight; + property GridLineColor: TColor index cGridLineColor read GetColor write SetColor default clBtnFace; + property HeaderHotColor: TColor index cHeaderHotColor read GetColor write SetColor default clBtnShadow; + property HotColor: TColor index cHotColor read GetColor write SetColor default clWindowText; + property SelectionRectangleBlendColor: TColor index cSelectionRectangleBlendColor read GetColor write SetColor default clHighlight; + property SelectionRectangleBorderColor: TColor index cSelectionRectangleBorderColor read GetColor write SetColor default clHighlight; + /// The text color of selected nodes + property SelectionTextColor: TColor index cSelectionTextColor read GetColor write SetColor default clHighlightText; + property TreeLineColor: TColor index cTreeLineColor read GetColor write SetColor default clBtnShadow; + property UnfocusedColor: TColor index cUnfocusedColor read GetColor write SetColor default clInactiveCaptionText; // [IPK] Added + /// The background color of selected nodes in case the tree does not have the focus and the toPopupMode flag is not set. + property UnfocusedSelectionColor: TColor index cUnfocusedSelectionColor read GetColor write SetColor default clInactiveCaption; + /// The border color of selected nodes in case the tree does not have the focus and the toPopupMode flag is not set. + property UnfocusedSelectionBorderColor: TColor index cUnfocusedSelectionBorderColor read GetColor write SetColor default clInactiveCaption; + end; + // For painting a node and its columns/cells a lot of information must be passed frequently around. TVTImageInfo = record Index: TImageIndex; // Index in the associated image list. @@ -821,7 +1874,8 @@ type TVTBeforeGetCheckStateEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode) of object; // header/column events - TVTHeaderAddPopupItemEvent = procedure(const Sender: TObject; const Column: TColumnIndex; var Cmd: TAddPopupItemType) of object; + TVTHeaderAddPopupItemEvent = procedure(const Sender: TBaseVirtualTree; const Column: TColumnIndex; + var Cmd: TAddPopupItemType) of object; TVTHeaderClickEvent = procedure(Sender: TVTHeader; HitInfo: TVTHeaderHitInfo) of object; TVTHeaderMouseEvent = procedure(Sender: TVTHeader; Button: TMouseButton; Shift: TShiftState; X, Y: Integer) of object; TVTHeaderMouseMoveEvent = procedure(Sender: TVTHeader; Shift: TShiftState; X, Y: Integer) of object; @@ -1318,6 +2372,7 @@ type procedure CMParentDoubleBufferedChange(var Message: TMessage); message CM_PARENTDOUBLEBUFFEREDCHANGED; procedure AdjustTotalCount(Node: PVirtualNode; Value: Integer; relative: Boolean = False); + procedure AdjustTotalHeight(Node: PVirtualNode; Value: Integer; relative: Boolean = False); function CalculateCacheEntryCount: Integer; procedure CalculateVerticalAlignments(var PaintInfo: TVTPaintInfo; var VButtonAlign: Integer); function ChangeCheckState(Node: PVirtualNode; Value: TCheckState): Boolean; @@ -1423,6 +2478,7 @@ type procedure SetVisiblePath(Node: PVirtualNode; Value: Boolean); procedure PrepareBackGroundPicture(Source: TPicture; DrawBitmap: TBitmap; DrawBitmapWidth: Integer; DrawBitMapHeight: Integer; ABkgcolor: TColor); procedure StaticBackground(Source: TPicture; Target: TCanvas; OffsetPosition: TPoint; R: TRect; aBkgColor: TColor); + procedure StopTimer(ID: Integer); procedure TileBackground(Source: TPicture; Target: TCanvas; Offset: TPoint; R: TRect; aBkgColor: TColor); function ToggleCallback(Step, StepSize: Integer; Data: Pointer): Boolean; @@ -1492,7 +2548,6 @@ type procedure AddToSelection(const NewItems: TNodeArray; NewLength: Integer; ForceInsert: Boolean = False); overload; virtual; procedure AdjustPaintCellRect(var PaintInfo: TVTPaintInfo; var NextNonEmpty: TColumnIndex); virtual; procedure AdjustPanningCursor(X, Y: Integer); virtual; - procedure AdjustTotalHeight(Node: PVirtualNode; Value: Integer; relative: Boolean = False); procedure AdviseChangeEvent(StructureChange: Boolean; Node: PVirtualNode; Reason: TChangeReason); virtual; function AllocateInternalDataArea(Size: Cardinal): Cardinal; virtual; procedure Animate(Steps, Duration: Cardinal; Callback: TVTAnimationCallback; Data: Pointer); virtual; @@ -1513,7 +2568,6 @@ type function CountVisibleChildren(Node: PVirtualNode): Cardinal; virtual; procedure CreateParams(var Params: TCreateParams); override; procedure CreateWnd; override; - procedure DecVisibleCount; procedure DefineProperties(Filer: TFiler); override; procedure DeleteNode(Node: PVirtualNode; Reindex: Boolean; ParentClearing: Boolean); overload; function DetermineDropMode(const P: TPoint; var HitInfo: THitInfo; var NodeRect: TRect): TDropMode; virtual; @@ -1683,7 +2737,6 @@ type procedure HandleClickSelection(LastFocused, NewNode: PVirtualNode; Shift: TShiftState; DragPending: Boolean); function HasImage(Node: PVirtualNode; Kind: TVTImageKind; Column: TColumnIndex): Boolean; virtual; deprecated 'Use GetImageSize instead'; function HasPopupMenu(Node: PVirtualNode; Column: TColumnIndex; Pos: TPoint): Boolean; virtual; - procedure IncVisibleCount; procedure InitChildren(Node: PVirtualNode); virtual; procedure InitNode(Node: PVirtualNode); virtual; procedure InternalAddFromStream(Stream: TStream; Version: Integer; Node: PVirtualNode); virtual; @@ -1695,7 +2748,6 @@ type procedure InternalConnectNode(Node, Destination: PVirtualNode; Target: TBaseVirtualTree; Mode: TVTNodeAttachMode); virtual; function InternalData(Node: PVirtualNode): Pointer; procedure InternalDisconnectNode(Node: PVirtualNode; KeepFocus: Boolean; Reindex: Boolean = True; ParentClearing: Boolean = False); virtual; - procedure InternalSetFocusedColumn(const index : TColumnIndex); procedure InternalRemoveFromSelection(Node: PVirtualNode); virtual; procedure InterruptValidation(pWaitForValidationTermination: Boolean = True); procedure InvalidateCache; @@ -1734,7 +2786,6 @@ type procedure SkipNode(Stream: TStream); virtual; procedure StartOperation(OperationKind: TVTOperationKind); procedure StartWheelPanning(Position: TPoint); virtual; - procedure StopTimer(ID: Integer); procedure StopWheelPanning; virtual; procedure StructureChange(Node: PVirtualNode; Reason: TChangeReason); virtual; function SuggestDropEffect(Source: TObject; Shift: TShiftState; Pt: TPoint; AllowedEffects: Integer): Integer; virtual; @@ -2028,7 +3079,6 @@ type function GetLastNoInit(Node: PVirtualNode = nil; ConsiderChildrenAbove: Boolean = False): PVirtualNode; function GetLastChild(Node: PVirtualNode): PVirtualNode; function GetLastChildNoInit(Node: PVirtualNode): PVirtualNode; - function GetLastSelected(ConsiderChildrenAbove: Boolean = False): PVirtualNode; function GetLastVisible(Node: PVirtualNode = nil; ConsiderChildrenAbove: Boolean = True; IncludeFiltered: Boolean = False): PVirtualNode; function GetLastVisibleChild(Node: PVirtualNode; IncludeFiltered: Boolean = False): PVirtualNode; @@ -2211,8 +3261,116 @@ type property DoubleBuffered: Boolean read GetDoubleBuffered write SetDoubleBuffered default True; end; + + // --------- TCustomVirtualStringTree + + // Options regarding strings (useful only for the string tree and descendants): + TVTStringOption = ( + toSaveCaptions, // If set then the caption is automatically saved with the tree node, regardless of what is + // saved in the user data. + toShowStaticText, // Show static text in a caption which can be differently formatted than the caption + // but cannot be edited. + toAutoAcceptEditChange // Automatically accept changes during edit if the user finishes editing other then + // VK_RETURN or ESC. If not set then changes are cancelled. + ); + TVTStringOptions = set of TVTStringOption; + +const + DefaultStringOptions = [toSaveCaptions, toAutoAcceptEditChange]; + +type + TCustomStringTreeOptions = class(TCustomVirtualTreeOptions) + private + FStringOptions: TVTStringOptions; + procedure SetStringOptions(const Value: TVTStringOptions); + protected + property StringOptions: TVTStringOptions read FStringOptions write SetStringOptions default DefaultStringOptions; + public + constructor Create(AOwner: TBaseVirtualTree); override; + + procedure AssignTo(Dest: TPersistent); override; + end; + + TStringTreeOptions = class(TCustomStringTreeOptions) + published + property AnimationOptions; + property AutoOptions; + property ExportMode; + property MiscOptions; + property PaintOptions; + property SelectionOptions; + property StringOptions; + property EditOptions; + end; + TCustomVirtualStringTree = class; + // Edit support Classes. + TStringEditLink = class; + + TVTEdit = class(TCustomEdit) + private + procedure CMAutoAdjust(var Message: TMessage); message CM_AUTOADJUST; + procedure CMExit(var Message: TMessage); message CM_EXIT; + procedure CMRelease(var Message: TMessage); message CM_RELEASE; + procedure CNCommand(var Message: TWMCommand); message CN_COMMAND; + procedure WMChar(var Message: TWMChar); message WM_CHAR; + procedure WMDestroy(var Message: TWMDestroy); message WM_DESTROY; + procedure WMGetDlgCode(var Message: TWMGetDlgCode); message WM_GETDLGCODE; + procedure WMKeyDown(var Message: TWMKeyDown); message WM_KEYDOWN; + protected + FRefLink: IVTEditLink; + FLink: TStringEditLink; + procedure AutoAdjustSize; virtual; + function CalcMinHeight: Integer; virtual; + procedure CreateParams(var Params: TCreateParams); override; + function GetTextSize: TSize; virtual; + procedure KeyPress(var Key: Char); override; + public + constructor Create(Link: TStringEditLink); reintroduce; + procedure ClearLink; + procedure ClearRefLink; + procedure Release; virtual; + + property AutoSelect; + property AutoSize; + property BorderStyle; + property CharCase; + property HideSelection; + property MaxLength; + property OEMConvert; + property PasswordChar; + end; + + TStringEditLink = class(TInterfacedObject, IVTEditLink) + private + FEdit: TVTEdit; // A normal custom edit control. + protected + FTree: TCustomVirtualStringTree; // A back reference to the tree calling. + FNode: PVirtualNode; // The node to be edited. + FColumn: TColumnIndex; // The column of the node. + FAlignment: TAlignment; + FTextBounds: TRect; // Smallest rectangle around the text. + FStopping: Boolean; // Set to True when the edit link requests stopping the edit action. + procedure SetEdit(const Value: TVTEdit); // Setter for the FEdit member; + public + constructor Create; virtual; + destructor Destroy; override; + property Alignment : TAlignment read FAlignment; + property Node : PVirtualNode read FNode; // [IPK] Make FNode accessible + property Column: TColumnIndex read FColumn; // [IPK] Make Column(Index) accessible + + function BeginEdit: Boolean; virtual; stdcall; + function CancelEdit: Boolean; virtual; stdcall; + property Edit: TVTEdit read FEdit write SetEdit; + function EndEdit: Boolean; virtual; stdcall; + function GetBounds: TRect; virtual; stdcall; + function PrepareEdit(Tree: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex): Boolean; virtual; stdcall; + procedure ProcessMessage(var Message: TMessage); virtual; stdcall; + procedure SetBounds(R: TRect); virtual; stdcall; + property Stopping : boolean read FStopping; + property Tree : TCustomVirtualStringTree read FTree; + end; // Describes the type of text to return in the text and draw info retrival events. TVSTTextType = ( @@ -2625,6 +3783,254 @@ type TVTGetNodeWidthEvent = procedure(Sender: TBaseVirtualTree; HintCanvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex; var NodeWidth: Integer) of object; + // Tree descendant to let an application draw its stuff itself. + TCustomVirtualDrawTree = class(TBaseVirtualTree) + private + FOnDrawNode: TVTDrawNodeEvent; + FOnGetCellContentMargin: TVTGetCellContentMarginEvent; + FOnGetNodeWidth: TVTGetNodeWidthEvent; + protected + function DoGetCellContentMargin(Node: PVirtualNode; Column: TColumnIndex; + CellContentMarginType: TVTCellContentMarginType = ccmtAllSides; Canvas: TCanvas = nil): TPoint; override; + function DoGetNodeWidth(Node: PVirtualNode; Column: TColumnIndex; Canvas: TCanvas = nil): Integer; override; + procedure DoPaintNode(var PaintInfo: TVTPaintInfo); override; + function GetDefaultHintKind: TVTHintKind; override; + + property OnDrawNode: TVTDrawNodeEvent read FOnDrawNode write FOnDrawNode; + property OnGetCellContentMargin: TVTGetCellContentMarginEvent read FOnGetCellContentMargin write FOnGetCellContentMargin; + property OnGetNodeWidth: TVTGetNodeWidthEvent read FOnGetNodeWidth write FOnGetNodeWidth; + end; + + [ComponentPlatformsAttribute(pidWin32 or pidWin64)] + TVirtualDrawTree = class(TCustomVirtualDrawTree) + private + function GetOptions: TVirtualTreeOptions; + procedure SetOptions(const Value: TVirtualTreeOptions); + protected + function GetOptionsClass: TTreeOptionsClass; override; + public + property Canvas; + property LastDragEffect; + property CheckImageKind; // should no more be published to make #622 fix working + published + property Action; + property Align; + property Alignment; + property Anchors; + property AnimationDuration; + property AutoExpandDelay; + property AutoScrollDelay; + property AutoScrollInterval; + property Background; + property BackgroundOffsetX; + property BackgroundOffsetY; + property BiDiMode; + property BevelEdges; + property BevelInner; + property BevelOuter; + property BevelKind; + property BevelWidth; + property BorderStyle; + property BottomSpace; + property ButtonFillMode; + property ButtonStyle; + property BorderWidth; + property ChangeDelay; + property ClipboardFormats; + property Color; + property Colors; + property Constraints; + property Ctl3D; + property CustomCheckImages; + property DefaultNodeHeight; + property DefaultPasteMode; + property DragCursor; + property DragHeight; + property DragKind; + property DragImageKind; + property DragMode; + property DragOperations; + property DragType; + property DragWidth; + property DrawSelectionMode; + property EditDelay; + property Enabled; + property Font; + property Header; + property HintMode; + property HotCursor; + property Images; + property IncrementalSearch; + property IncrementalSearchDirection; + property IncrementalSearchStart; + property IncrementalSearchTimeout; + property Indent; + property LineMode; + property LineStyle; + property Margin; + property NodeAlignment; + property NodeDataSize; + property OperationCanceled; + property ParentBiDiMode; + property ParentColor default False; + property ParentCtl3D; + property ParentFont; + property ParentShowHint; + property PopupMenu; + property RootNodeCount; + property ScrollBarOptions; + property SelectionBlendFactor; + property SelectionCurveRadius; + property ShowHint; + property StateImages; + property TabOrder; + property TabStop default True; + property TextMargin; + property TreeOptions: TVirtualTreeOptions read GetOptions write SetOptions; + property Visible; + property WantTabs; + + property OnAddToSelection; + property OnAdvancedHeaderDraw; + property OnAfterAutoFitColumn; + property OnAfterAutoFitColumns; + property OnAfterCellPaint; + property OnAfterColumnExport; + property OnAfterColumnWidthTracking; + property OnAfterGetMaxColumnWidth; + property OnAfterHeaderExport; + property OnAfterHeaderHeightTracking; + property OnAfterItemErase; + property OnAfterItemPaint; + property OnAfterNodeExport; + property OnAfterPaint; + property OnAfterTreeExport; + property OnBeforeAutoFitColumn; + property OnBeforeAutoFitColumns; + property OnBeforeCellPaint; + property OnBeforeColumnExport; + property OnBeforeColumnWidthTracking; + property OnBeforeDrawTreeLine; + property OnBeforeGetMaxColumnWidth; + property OnBeforeHeaderExport; + property OnBeforeHeaderHeightTracking; + property OnBeforeItemErase; + property OnBeforeItemPaint; + property OnBeforeNodeExport; + property OnBeforePaint; + property OnBeforeTreeExport; + property OnCanSplitterResizeColumn; + property OnCanSplitterResizeHeader; + property OnCanSplitterResizeNode; + property OnChange; + property OnChecked; + property OnChecking; + property OnClick; + property OnCollapsed; + property OnCollapsing; + property OnColumnClick; + property OnColumnDblClick; + property OnColumnExport; + property OnColumnResize; + property OnColumnVisibilityChanged; + property OnColumnWidthDblClickResize; + property OnColumnWidthTracking; + property OnCompareNodes; + property OnContextPopup; + property OnCreateDataObject; + property OnCreateDragManager; + property OnCreateEditor; + property OnDblClick; + property OnDragAllowed; + property OnDragOver; + property OnDragDrop; + property OnDrawHint; + property OnDrawNode; + property OnEdited; + property OnEditing; + property OnEndDock; + property OnEndDrag; + property OnEndOperation; + property OnEnter; + property OnExit; + property OnExpanded; + property OnExpanding; + property OnFocusChanged; + property OnFocusChanging; + property OnFreeNode; + property OnGetCellIsEmpty; + property OnGetCursor; + property OnGetHeaderCursor; + property OnGetHelpContext; + property OnGetHintKind; + property OnGetHintSize; + property OnGetImageIndex; + property OnGetImageIndexEx; + property OnGetLineStyle; + property OnGetNodeDataSize; + property OnGetNodeWidth; + property OnGetPopupMenu; + property OnGetUserClipboardFormats; + property OnHeaderAddPopupItem; + property OnHeaderClick; + property OnHeaderDblClick; + property OnHeaderDragged; + property OnHeaderDraggedOut; + property OnHeaderDragging; + property OnHeaderDraw; + property OnHeaderDrawQueryElements; + property OnHeaderHeightTracking; + property OnHeaderHeightDblClickResize; + property OnHeaderMouseDown; + property OnHeaderMouseMove; + property OnHeaderMouseUp; + property OnHotChange; + property OnIncrementalSearch; + property OnInitChildren; + property OnInitNode; + property OnKeyAction; + property OnKeyDown; + property OnKeyPress; + property OnKeyUp; + property OnLoadNode; + property OnLoadTree; + property OnMeasureItem; + property OnMouseDown; + property OnMouseMove; + property OnMouseUp; + property OnMouseWheel; + property OnNodeClick; + property OnNodeCopied; + property OnNodeCopying; + property OnNodeDblClick; + property OnNodeExport; + property OnNodeHeightTracking; + property OnNodeHeightDblClickResize; + property OnNodeMoved; + property OnNodeMoving; + property OnPaintBackground; + property OnPrepareButtonBitmaps; + property OnRemoveFromSelection; + property OnRenderOLEData; + property OnResetNode; + property OnResize; + property OnSaveNode; + property OnSaveTree; + property OnScroll; + property OnShowScrollBar; + property OnStartDock; + property OnStartDrag; + property OnStartOperation; + property OnStateChange; + property OnStructureChange; + property OnUpdating; + property OnCanResize; + property OnGesture; + property Touch; + property StyleElements; + end; + + // utility routines function TreeFromNode(Node: PVirtualNode): TBaseVirtualTree; @@ -2650,14 +4056,11 @@ uses VirtualTrees.AccessibilityFactory, VirtualTrees.StyleHooks, VirtualTrees.Classes, - VirtualTrees.DataObject, VirtualTrees.WorkerThread, VirtualTrees.ClipBoard, - VirtualTrees.Utils, + VirtualTrees.Utils, VirtualTrees.Export, - VirtualTrees.HeaderPopup, - VirtualTrees.DragnDrop, - VirtualTrees.EditLink; + VirtualTrees.HeaderPopup; resourcestring // Localizable strings. @@ -2682,7 +4085,27 @@ const // in the compiled binary file. Copyright: string = 'Virtual Treeview © 1999-2021 Mike Lischke, Joachim Marder'; +var + StandardOLEFormat: TFormatEtc = ( + // Format must later be set. + cfFormat: 0; + // No specific target device to render on. + ptd: nil; + // Normal content to render. + dwAspect: DVASPECT_CONTENT; + // No specific page of multipage data (we don't use multipage data by default). + lindex: -1; + // Acceptable storage formats are IStream and global memory. The first is preferred. + tymed: TYMED_ISTREAM or TYMED_HGLOBAL; + ); +type + // protection against TRect record method that cause problems with with-statements + TWithSafeRect = record + case Integer of + 0: (Left, Top, Right, Bottom: Integer); + 1: (TopLeft, BottomRight: TPoint); + end; type // streaming support TMagicID = array[0..5] of WideChar; @@ -2730,12 +4153,6 @@ type // streaming support TCanvasEx = class(TCanvas); - //These allow us access to protected members in the classes - TVirtualTreeColumnsCracker = class(TVirtualTreeColumns); - TVTHeaderCracker = class(TVTHeader); - TVirtualTreeColumnCracker = class(TVirtualTreeColumn); - - const MagicID: TMagicID = (#$2045, 'V', 'T', WideChar(VTTreeStreamVersion), ' ', #$2046); @@ -2786,6 +4203,19 @@ end; //---------------------------------------------------------------------------------------------------------------------- +/// Wrapper function for styles services that handles differences between RAD Studio 10.4 and older versions, +/// as well as the case if these controls are used inside the IDE. +function VTStyleServices(AControl: TControl = nil): TCustomStyleServices; +begin + if Assigned(VTStyleServicesFunc) then + Result := VTStyleServicesFunc(AControl) + else + Result := Vcl.Themes.StyleServices{$if CompilerVersion >= 34}(AControl){$ifend}; +end; + +//---------------------------------------------------------------------------------------------------------------------- + + procedure QuickSort(const TheArray: TNodeArray; L, R: Integer); var @@ -3033,6 +4463,11 @@ begin // Register the tree reference clipboard format. Others will be handled in InternalClipboarFormats. CF_VTREFERENCE := RegisterClipboardFormat(CFSTR_VTREFERENCE); + // Delphi (at least version 6 and lower) does not provide a standard split cursor. + // Hence we have to load our own. + Screen.Cursors[crHeaderSplit] := LoadCursor(HInstance, 'VT_HEADERSPLIT'); + Screen.Cursors[crVertSplit] := LoadCursor(HInstance, 'VT_VERTSPLIT'); + // Clipboard format registration. // Native clipboard format. Needs a new identifier and has an average priority to allow other formats to take over. // This format is supposed to use the IStream storage format but unfortunately this does not work when @@ -3076,6 +4511,981 @@ begin gWatcher := nil; end; + + + +//----------------- TCustomVirtualTreeOptions -------------------------------------------------------------------------- + +constructor TCustomVirtualTreeOptions.Create(AOwner: TBaseVirtualTree); + +begin + FOwner := AOwner; + + FPaintOptions := DefaultPaintOptions; + FAnimationOptions := DefaultAnimationOptions; + FAutoOptions := DefaultAutoOptions; + FSelectionOptions := DefaultSelectionOptions; + FMiscOptions := DefaultMiscOptions; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TCustomVirtualTreeOptions.SetAnimationOptions(const Value: TVTAnimationOptions); + +begin + FAnimationOptions := Value; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TCustomVirtualTreeOptions.SetAutoOptions(const Value: TVTAutoOptions); + +var + ChangedOptions: TVTAutoOptions; + +begin + if FAutoOptions <> Value then + begin + // Exclusive ORing to get all entries wich are in either set but not in both. + ChangedOptions := FAutoOptions + Value - (FAutoOptions * Value); + FAutoOptions := Value; + with FOwner do + if (toAutoSpanColumns in ChangedOptions) and not (csLoading in ComponentState) and HandleAllocated then + Invalidate; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TCustomVirtualTreeOptions.InternalSetMiscOptions(const Value: TVTMiscOptions); +begin + FMiscOptions := value; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TCustomVirtualTreeOptions.SetMiscOptions(const Value: TVTMiscOptions); + +var + ToBeSet, + ToBeCleared: TVTMiscOptions; + +begin + if FMiscOptions <> Value then + begin + ToBeSet := Value - FMiscOptions; + ToBeCleared := FMiscOptions - Value; + FMiscOptions := Value; + + with FOwner do + if not (csLoading in ComponentState) and HandleAllocated then + begin + if toCheckSupport in ToBeSet + ToBeCleared then + Invalidate; + if toEditOnDblClick in ToBeSet then + FMiscOptions := FMiscOptions - [toToggleOnDblClick]; // In order for toEditOnDblClick to take effect, we need to remove toToggleOnDblClick which is handled with priority. See issue #747 + + if not (csDesigning in ComponentState) then + begin + if toAcceptOLEDrop in ToBeCleared then + RevokeDragDrop(Handle); + if toFullRepaintOnResize in ToBeSet + ToBeCleared then + RecreateWnd; + if toAcceptOLEDrop in ToBeSet then + RegisterDragDrop(Handle, DragManager as IDropTarget); + if toVariableNodeHeight in ToBeSet then begin + BeginUpdate(); + try + ReInitNode(nil, True); + finally + EndUpdate(); + end;//try..finally + end;//if toVariableNodeHeight + end; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TCustomVirtualTreeOptions.SetPaintOptions(const Value: TVTPaintOptions); + +var + ToBeSet, + ToBeCleared: TVTPaintOptions; + Run: PVirtualNode; + HandleWasAllocated: Boolean; + +begin + if FPaintOptions <> Value then + begin + ToBeSet := Value - FPaintOptions; + ToBeCleared := FPaintOptions - Value; + FPaintOptions := Value; + if (toFixedIndent in ToBeSet) then + begin + // Fixes issue #388 + Include(FPaintOptions, toShowRoot); + Include(ToBeSet, toShowRoot); + end;//if + with FOwner do + begin + HandleWasAllocated := HandleAllocated; + + if not (csLoading in ComponentState) and (toShowFilteredNodes in ToBeSet + ToBeCleared) then + begin + if HandleWasAllocated then + BeginUpdate; + InterruptValidation; + Run := GetFirstNoInit; + while Assigned(Run) do + begin + if (vsFiltered in Run.States) then + begin + if FullyVisible[Run] then + begin + if toShowFilteredNodes in ToBeSet then + Inc(FVisibleCount) + else + Dec(FVisibleCount); + end; + if toShowFilteredNodes in ToBeSet then + AdjustTotalHeight(Run, Run.NodeHeight, True) + else + AdjustTotalHeight(Run, -Run.NodeHeight, True); + end; + Run := GetNextNoInit(Run); + end; + if HandleWasAllocated then + EndUpdate; + end; + + if HandleAllocated then + begin + if IsWinVistaOrAbove and ((tsUseThemes in FStates) or + ((toThemeAware in ToBeSet) and StyleServices.Enabled)) and + (toUseExplorerTheme in (ToBeSet + ToBeCleared)) and not VclStyleEnabled then + begin + if (toUseExplorerTheme in ToBeSet) then + begin + SetWindowTheme('explorer'); + DoStateChange([tsUseExplorerTheme]); + end + else + if toUseExplorerTheme in ToBeCleared then + begin + SetWindowTheme(''); + DoStateChange([], [tsUseExplorerTheme]); + end; + end; + + if not (csLoading in ComponentState) then + begin + if ((toThemeAware in ToBeSet + ToBeCleared) or (toUseExplorerTheme in ToBeSet + ToBeCleared) or VclStyleEnabled) then + begin + if ((toThemeAware in ToBeSet) and StyleServices.Enabled) then + DoStateChange([tsUseThemes]) + else + if (toThemeAware in ToBeCleared) then + DoStateChange([], [tsUseThemes]); + + PrepareBitmaps(True, False); + RedrawWindow(Handle, nil, 0, RDW_INVALIDATE or RDW_VALIDATE or RDW_FRAME); + end; + + if toChildrenAbove in ToBeSet + ToBeCleared then + begin + InvalidateCache; + if FUpdateCount = 0 then + begin + ValidateCache; + Invalidate; + end; + end; + + Invalidate; + end; + end; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TCustomVirtualTreeOptions.SetSelectionOptions(const Value: TVTSelectionOptions); + +var + ToBeSet, + ToBeCleared: TVTSelectionOptions; + +begin + if FSelectionOptions <> Value then + begin + ToBeSet := Value - FSelectionOptions; + ToBeCleared := FSelectionOptions - Value; + FSelectionOptions := Value; + + with FOwner do + begin + if (toMultiSelect in (ToBeCleared + ToBeSet)) or + ([toLevelSelectConstraint, toSiblingSelectConstraint] * ToBeSet <> []) then + ClearSelection; + + if (toExtendedFocus in ToBeCleared) and (FFocusedColumn > 0) and HandleAllocated then + begin + FFocusedColumn := FHeader.MainColumn; + Invalidate; + end; + + if not (toExtendedFocus in FSelectionOptions) then + FFocusedColumn := FHeader.MainColumn; + end; + end; +end; + +function TCustomVirtualTreeOptions.StyleServices(AControl: TControl): TCustomStyleServices; +begin + Result := VTStyleServices(FOwner); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TCustomVirtualTreeOptions.AssignTo(Dest: TPersistent); + +begin + if Dest is TCustomVirtualTreeOptions then + begin + with Dest as TCustomVirtualTreeOptions do + begin + PaintOptions := Self.PaintOptions; + AnimationOptions := Self.AnimationOptions; + AutoOptions := Self.AutoOptions; + SelectionOptions := Self.SelectionOptions; + MiscOptions := Self.MiscOptions; + end; + end + else + inherited; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +// OLE drag and drop support classes +// This is quite heavy stuff (compared with the VCL implementation) but is much better suited to fit the needs +// of DD'ing various kinds of virtual data and works also between applications. + +//----------------- TEnumFormatEtc ------------------------------------------------------------------------------------- + +constructor TEnumFormatEtc.Create(Tree: TBaseVirtualTree; const AFormatEtcArray: TFormatEtcArray); + +var + I: Integer; + +begin + inherited Create; + + FTree := Tree; + // Make a local copy of the format data. + SetLength(FFormatEtcArray, Length(AFormatEtcArray)); + for I := 0 to High(AFormatEtcArray) do + FFormatEtcArray[I] := AFormatEtcArray[I]; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TEnumFormatEtc.Clone(out Enum: IEnumFormatEtc): HResult; + +var + AClone: TEnumFormatEtc; + +begin + Result := S_OK; + try + AClone := TEnumFormatEtc.Create(nil, FFormatEtcArray); + AClone.FCurrentIndex := FCurrentIndex; + Enum := AClone as IEnumFormatEtc; + except + Result := E_FAIL; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TEnumFormatEtc.Next(celt: Integer; out elt; pceltFetched: PLongint): HResult; + +var + CopyCount: Integer; + +begin + Result := S_FALSE; + CopyCount := Length(FFormatEtcArray) - FCurrentIndex; + if celt < CopyCount then + CopyCount := celt; + if CopyCount > 0 then + begin + Move(FFormatEtcArray[FCurrentIndex], elt, CopyCount * SizeOf(TFormatEtc)); + Inc(FCurrentIndex, CopyCount); + Result := S_OK; + end; + if Assigned(pceltFetched) then + pceltFetched^ := CopyCount; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TEnumFormatEtc.Reset: HResult; + +begin + FCurrentIndex := 0; + Result := S_OK; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TEnumFormatEtc.Skip(celt: Integer): HResult; + +begin + if FCurrentIndex + celt < High(FFormatEtcArray) then + begin + Inc(FCurrentIndex, celt); + Result := S_Ok; + end + else + Result := S_FALSE; +end; + +//----------------- TVTDataObject -------------------------------------------------------------------------------------- + +constructor TVTDataObject.Create(AOwner: TBaseVirtualTree; ForClipboard: Boolean); + +begin + inherited Create; + + FOwner := AOwner; + FForClipboard := ForClipboard; + FOwner.GetNativeClipboardFormats(FFormatEtcArray); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +destructor TVTDataObject.Destroy; + +var + I: Integer; + StgMedium: PStgMedium; + +begin + // Cancel a pending clipboard operation if this data object was created for the clipboard and + // is freed because something else is placed there. + if FForClipboard and not (tsClipboardFlushing in FOwner.TreeStates) then + FOwner.CancelCutOrCopy; + + // Release any internal clipboard formats + for I := 0 to High(FormatEtcArray) do + begin + StgMedium := FindInternalStgMedium(FormatEtcArray[I].cfFormat); + if Assigned(StgMedium) then + ReleaseStgMedium(StgMedium^); + end; + + FormatEtcArray := nil; + inherited; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDataObject.CanonicalIUnknown(const TestUnknown: IUnknown): IUnknown; + +// Uses COM object identity: An explicit call to the IUnknown::QueryInterface method, requesting the IUnknown +// interface, will always return the same pointer. + +begin + if Assigned(TestUnknown) then + begin + if TestUnknown.QueryInterface(IUnknown, Result) = 0 then + Result._Release // Don't actually need it just need the pointer value + else + Result := TestUnknown; + end + else + Result := TestUnknown; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDataObject.EqualFormatEtc(FormatEtc1, FormatEtc2: TFormatEtc): Boolean; + +begin + Result := (FormatEtc1.cfFormat = FormatEtc2.cfFormat) and (FormatEtc1.ptd = FormatEtc2.ptd) and + (FormatEtc1.dwAspect = FormatEtc2.dwAspect) and (FormatEtc1.lindex = FormatEtc2.lindex) and + (FormatEtc1.tymed and FormatEtc2.tymed <> 0); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDataObject.FindFormatEtc(TestFormatEtc: TFormatEtc; const FormatEtcArray: TFormatEtcArray): integer; + +var + I: integer; + +begin + Result := -1; + for I := 0 to High(FormatEtcArray) do + begin + if EqualFormatEtc(TestFormatEtc, FormatEtcArray[I]) then + begin + Result := I; + Break; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDataObject.FindInternalStgMedium(Format: TClipFormat): PStgMedium; + +var + I: integer; +begin + Result := nil; + for I := 0 to High(InternalStgMediumArray) do + begin + if Format = InternalStgMediumArray[I].Format then + begin + Result := @InternalStgMediumArray[I].Medium; + Break; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDataObject.HGlobalClone(HGlobal: THandle): THandle; + +// Returns a global memory block that is a copy of the passed memory block. + +var + Size: Cardinal; + Data, + NewData: PByte; + +begin + Size := GlobalSize(HGlobal); + Result := GlobalAlloc(GPTR, Size); + Data := GlobalLock(hGlobal); + try + NewData := GlobalLock(Result); + try + Move(Data^, NewData^, Size); + finally + GlobalUnLock(Result); + end; + finally + GlobalUnLock(hGlobal); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDataObject.RenderInternalOLEData(const FormatEtcIn: TFormatEtc; var Medium: TStgMedium; + var OLEResult: HResult): Boolean; + +// Tries to render one of the formats which have been stored via the SetData method. +// Since this data is already there it is just copied or its reference count is increased (depending on storage medium). + +var + InternalMedium: PStgMedium; + +begin + Result := True; + InternalMedium := FindInternalStgMedium(FormatEtcIn.cfFormat); + if Assigned(InternalMedium) then + OLEResult := StgMediumIncRef(InternalMedium^, Medium, False, Self as IDataObject) + else + Result := False; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDataObject.StgMediumIncRef(const InStgMedium: TStgMedium; var OutStgMedium: TStgMedium; + CopyInMedium: Boolean; const DataObject: IDataObject): HRESULT; + +// InStgMedium is the data that is requested, OutStgMedium is the data that we are to return either a copy of or +// increase the IDataObject's reference and send ourselves back as the data (unkForRelease). The InStgMedium is usually +// the result of a call to find a particular FormatEtc that has been stored locally through a call to SetData. +// If CopyInMedium is not true we already have a local copy of the data when the SetData function was called (during +// that call the CopyInMedium must be true). Then as the caller asks for the data through GetData we do not have to make +// copy of the data for the caller only to have them destroy it then need us to copy it again if necessary. +// This way we increase the reference count to ourselves and pass the STGMEDIUM structure initially stored in SetData. +// This way when the caller frees the structure it sees the unkForRelease is not nil and calls Release on the object +// instead of destroying the actual data. + +var + Len: Integer; + +begin + Result := S_OK; + + // Simply copy all fields to start with. + OutStgMedium := InStgMedium; + // The data handled here always results from a call of SetData we got. This ensures only one storage format + // is indicated and hence the case statement below is safe (IDataObject.GetData can optionally use several + // storage formats). + case InStgMedium.tymed of + TYMED_HGLOBAL: + begin + if CopyInMedium then + begin + // Generate a unique copy of the data passed + OutStgMedium.hGlobal := HGlobalClone(InStgMedium.hGlobal); + if OutStgMedium.hGlobal = 0 then + Result := E_OUTOFMEMORY; + end + else + // Don't generate a copy just use ourselves and the copy previously saved. + OutStgMedium.unkForRelease := Pointer(DataObject); // Does not increase RefCount. + end; + TYMED_FILE: + begin + Len := lstrLenW(InStgMedium.lpszFileName) + 1; // Don't forget the terminating null character. + OutStgMedium.lpszFileName := CoTaskMemAlloc(2 * Len); + Move(InStgMedium.lpszFileName^, OutStgMedium.lpszFileName^, 2 * Len); + end; + TYMED_ISTREAM: + IUnknown(OutStgMedium.stm)._AddRef; + TYMED_ISTORAGE: + IUnknown(OutStgMedium.stg)._AddRef; + TYMED_GDI: + if not CopyInMedium then + // Don't generate a copy just use ourselves and the previously saved data. + OutStgMedium.unkForRelease := Pointer(DataObject) // Does not increase RefCount. + else + Result := DV_E_TYMED; // Don't know how to copy GDI objects right now. + TYMED_MFPICT: + if not CopyInMedium then + // Don't generate a copy just use ourselves and the previously saved data. + OutStgMedium.unkForRelease := Pointer(DataObject) // Does not increase RefCount. + else + Result := DV_E_TYMED; // Don't know how to copy MetaFile objects right now. + TYMED_ENHMF: + if not CopyInMedium then + // Don't generate a copy just use ourselves and the previously saved data. + OutStgMedium.unkForRelease := Pointer(DataObject) // Does not increase RefCount. + else + Result := DV_E_TYMED; // Don't know how to copy enhanced metafiles objects right now. + else + Result := DV_E_TYMED; + end; + + if (Result = S_OK) and Assigned(OutStgMedium.unkForRelease) then + IUnknown(OutStgMedium.unkForRelease)._AddRef; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDataObject.DAdvise(const FormatEtc: TFormatEtc; advf: Integer; const advSink: IAdviseSink; + out dwConnection: Integer): HResult; + +// Advise sink management is greatly simplified by the IDataAdviseHolder interface. +// We use this interface and forward all concerning calls to it. + +begin + Result := S_OK; + if FAdviseHolder = nil then + Result := CreateDataAdviseHolder(FAdviseHolder); + if Result = S_OK then + Result := FAdviseHolder.Advise(Self as IDataObject, FormatEtc, advf, advSink, dwConnection); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDataObject.DUnadvise(dwConnection: Integer): HResult; + +begin + if FAdviseHolder = nil then + Result := E_NOTIMPL + else + Result := FAdviseHolder.Unadvise(dwConnection); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDataObject.EnumDAdvise(out enumAdvise: IEnumStatData): HResult; + +begin + if FAdviseHolder = nil then + Result := OLE_E_ADVISENOTSUPPORTED + else + Result := FAdviseHolder.EnumAdvise(enumAdvise); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDataObject.EnumFormatEtc(Direction: Integer; out EnumFormatEtc: IEnumFormatEtc): HResult; + +var + NewList: TEnumFormatEtc; + +begin + Result := E_FAIL; + if Direction = DATADIR_GET then + begin + NewList := TEnumFormatEtc.Create(FOwner, FormatEtcArray); + EnumFormatEtc := NewList as IEnumFormatEtc; + Result := S_OK; + end + else + EnumFormatEtc := nil; + if EnumFormatEtc = nil then + Result := OLE_S_USEREG; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDataObject.GetCanonicalFormatEtc(const FormatEtc: TFormatEtc; out FormatEtcOut: TFormatEtc): HResult; + +begin + Result := DATA_S_SAMEFORMATETC; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDataObject.GetData(const FormatEtcIn: TFormatEtc; out Medium: TStgMedium): HResult; + +// Data is requested by clipboard or drop target. This method dispatchs the call +// depending on the data being requested. + +var + I: Integer; + Data: PVTReference; + +begin + // The tree reference format is always supported and returned from here. + if FormatEtcIn.cfFormat = CF_VTREFERENCE then + begin + // Note: this format is not used while flushing the clipboard to avoid a dangling reference + // when the owner tree is destroyed before the clipboard data is replaced with something else. + if tsClipboardFlushing in FOwner.TreeStates then + Result := E_FAIL + else + begin + Medium.hGlobal := GlobalAlloc(GHND or GMEM_SHARE, SizeOf(TVTReference)); + Data := GlobalLock(Medium.hGlobal); + Data.Process := GetCurrentProcessID; + Data.Tree := FOwner; + GlobalUnlock(Medium.hGlobal); + Medium.tymed := TYMED_HGLOBAL; + Medium.unkForRelease := nil; + Result := S_OK; + end; + end + else + begin + try + // See if we accept this type and if not get the correct return value. + Result := QueryGetData(FormatEtcIn); + if Result = S_OK then + begin + for I := 0 to High(FormatEtcArray) do + begin + if EqualFormatEtc(FormatEtcIn, FormatEtcArray[I]) then + begin + if not RenderInternalOLEData(FormatEtcIn, Medium, Result) then + Result := FOwner.RenderOLEData(FormatEtcIn, Medium, FForClipboard); + Break; + end; + end; + end; + except + ZeroMemory (@Medium, SizeOf(Medium)); + Result := E_FAIL; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDataObject.GetDataHere(const FormatEtc: TFormatEtc; out Medium: TStgMedium): HResult; + +begin + Result := E_NOTIMPL; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDataObject.QueryGetData(const FormatEtc: TFormatEtc): HResult; + +var + I: Integer; + +begin + Result := DV_E_CLIPFORMAT; + for I := 0 to High(FFormatEtcArray) do + begin + if FormatEtc.cfFormat = FFormatEtcArray[I].cfFormat then + begin + if (FormatEtc.tymed and FFormatEtcArray[I].tymed) <> 0 then + begin + if FormatEtc.dwAspect = FFormatEtcArray[I].dwAspect then + begin + if FormatEtc.lindex = FFormatEtcArray[I].lindex then + begin + Result := S_OK; + Break; + end + else + Result := DV_E_LINDEX; + end + else + Result := DV_E_DVASPECT; + end + else + Result := DV_E_TYMED; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDataObject.SetData(const FormatEtc: TFormatEtc; var Medium: TStgMedium; DoRelease: BOOL): HResult; + +// Allows dynamic adding to the IDataObject during its existance. Most noteably it is used to implement +// IDropSourceHelper and allows to set a special format for optimized moves during a shell transfer. + +var + Index: Integer; + LocalStgMedium: PStgMedium; + +begin + // See if we already have a format of that type available. + Index := FindFormatEtc(FormatEtc, FormatEtcArray); + if Index > - 1 then + begin + // Just use the TFormatEct in the array after releasing the data. + LocalStgMedium := FindInternalStgMedium(FormatEtcArray[Index].cfFormat); + if Assigned(LocalStgMedium) then + begin + ReleaseStgMedium(LocalStgMedium^); + ZeroMemory(LocalStgMedium, SizeOf(LocalStgMedium^)); + end; + end + else + begin + // It is a new format so create a new TFormatCollectionItem, copy the + // FormatEtc parameter into the new object and and put it in the list. + SetLength(FFormatEtcArray, Length(FormatEtcArray) + 1); + FormatEtcArray[High(FormatEtcArray)] := FormatEtc; + + // Create a new InternalStgMedium and initialize it and associate it with the format. + SetLength(FInternalStgMediumArray, Length(InternalStgMediumArray) + 1); + InternalStgMediumArray[High(InternalStgMediumArray)].Format := FormatEtc.cfFormat; + LocalStgMedium := @InternalStgMediumArray[High(InternalStgMediumArray)].Medium; + ZeroMemory(LocalStgMedium, SizeOf(LocalStgMedium^)); + end; + + if DoRelease then + begin + // We are simply being given the data and we take control of it. + LocalStgMedium^ := Medium; + Result := S_OK; + end + else + begin + // We need to reference count or copy the data and keep our own references to it. + Result := StgMediumIncRef(Medium, LocalStgMedium^, True, Self as IDataObject); + + // Can get a circular reference if the client calls GetData then calls SetData with the same StgMedium. + // Because the unkForRelease for the IDataObject can be marshalled it is necessary to get pointers that + // can be correctly compared. See the IDragSourceHelper article by Raymond Chen at MSDN. + if Assigned(LocalStgMedium.unkForRelease) then + begin + if CanonicalIUnknown(Self) = CanonicalIUnknown(IUnknown(LocalStgMedium.unkForRelease)) then + IUnknown(LocalStgMedium.unkForRelease) := nil; // release the interface + end; + end; + + // Tell all registered advice sinks about the data change. + if Assigned(FAdviseHolder) then + FAdviseHolder.SendOnDataChange(Self as IDataObject, 0, 0); +end; + +//----------------- TVTDragManager ------------------------------------------------------------------------------------- + +constructor TVTDragManager.Create(AOwner: TBaseVirtualTree); + +begin + inherited Create; + FOwner := AOwner; + + // Create an instance of the drop target helper interface. This will fail but not harm on systems which do + // not support this interface (everything below Windows 2000); + CoCreateInstance(CLSID_DragDropHelper, nil, CLSCTX_INPROC_SERVER, IID_IDropTargetHelper, FDropTargetHelper); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +destructor TVTDragManager.Destroy; + +begin + // Set the owner's reference to us to nil otherwise it will access an invalid pointer + // after our desctruction is complete. + FOwner.ClearDragManager; + inherited; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDragManager.GetDataObject: IDataObject; + +begin + // When the owner tree starts a drag operation then it gets a data object here to pass it to the OLE subsystem. + // In this case there is no local reference to a data object and one is created (but not stored). + // If there is a local reference then the owner tree is currently the drop target and the stored interface is + // that of the drag initiator. + if Assigned(FDataObject) then + Result := FDataObject + else + begin + Result := FOwner.DoCreateDataObject; + if (Result = nil) and not Assigned(FOwner.OnCreateDataObject) then + // Do not create a TVTDataObject if the event handler explicitely decided not to supply one, issue #736. + Result := TVTDataObject.Create(FOwner, False) as IDataObject; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDragManager.GetDragSource: TBaseVirtualTree; + +begin + Result := FDragSource; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDragManager.GetDropTargetHelperSupported: Boolean; + +begin + Result := Assigned(FDropTargetHelper); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDragManager.GetIsDropTarget: Boolean; + +begin + Result := FIsDropTarget; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDragManager.DragEnter(const DataObject: IDataObject; KeyState: Integer; Pt: TPoint; + var Effect: Integer): HResult; + +begin + FDataObject := DataObject; + FIsDropTarget := True; + + SystemParametersInfo(SPI_GETDRAGFULLWINDOWS, 0, @FFullDragging, 0); + // If full dragging of window contents is disabled in the system then our tree windows will be locked + // and cannot be updated during a drag operation. With the following call painting is again enabled. + if not FFullDragging then + LockWindowUpdate(0); + if Assigned(FDropTargetHelper) and FFullDragging then begin + if toAutoScroll in Self.FOwner.TreeOptions.AutoOptions then + FDropTargetHelper.DragEnter(FOwner.Handle, DataObject, Pt, Effect) + else + FDropTargetHelper.DragEnter(0, DataObject, Pt, Effect);// Do not pass handle, otherwise the IDropTargetHelper will perform autoscroll. Issue #486 + end; + FDragSource := FOwner.GetTreeFromDataObject(DataObject); + Result := FOwner.DragEnter(KeyState, Pt, Effect); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDragManager.DragLeave: HResult; + +begin + if Assigned(FDropTargetHelper) and FFullDragging then + FDropTargetHelper.DragLeave; + + FOwner.DragLeave; + FIsDropTarget := False; + FDragSource := nil; + FDataObject := nil; + Result := NOERROR; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDragManager.DragOver(KeyState: Integer; Pt: TPoint; var Effect: Integer): HResult; + +begin + if Assigned(FDropTargetHelper) and FFullDragging then + FDropTargetHelper.DragOver(Pt, Effect); + + Result := FOwner.DragOver(FDragSource, KeyState, dsDragMove, Pt, Effect); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDragManager.Drop(const DataObject: IDataObject; KeyState: Integer; Pt: TPoint; + var Effect: Integer): HResult; + +begin + if Assigned(FDropTargetHelper) and FFullDragging then + FDropTargetHelper.Drop(DataObject, Pt, Effect); + + Result := FOwner.DragDrop(DataObject, KeyState, Pt, Effect); + FIsDropTarget := False; + FDataObject := nil; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTDragManager.ForceDragLeave; + +// Some drop targets, e.g. Internet Explorer leave a drag image on screen instead removing it when they receive +// a drop action. This method calls the drop target helper's DragLeave method to ensure it removes the drag image from +// screen. Unfortunately, sometimes not even this does help (e.g. when dragging text from VT to a text field in IE). + +begin + if Assigned(FDropTargetHelper) and FFullDragging then + FDropTargetHelper.DragLeave; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDragManager.GiveFeedback(Effect: Integer): HResult; + +begin + Result := DRAGDROP_S_USEDEFAULTCURSORS; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDragManager.QueryContinueDrag(EscapePressed: BOOL; KeyState: Integer): HResult; + +var + RButton, + LButton: Boolean; + +begin + LButton := (KeyState and MK_LBUTTON) <> 0; + RButton := (KeyState and MK_RBUTTON) <> 0; + + // Drag'n drop canceled by pressing both mouse buttons or Esc? + if (LButton and RButton) or EscapePressed then + Result := DRAGDROP_S_CANCEL + else + // Drag'n drop finished? + if not (LButton or RButton) then + Result := DRAGDROP_S_DROP + else + Result := S_OK; +end; + + //----------------- TVirtualTreeHintWindow ----------------------------------------------------------------------------- procedure TVirtualTreeHintWindow.CMTextChanged(var Message: TMessage); @@ -3291,7 +5701,7 @@ begin begin // Determine actual line break style depending on what was returned by the methods and what's in the node. if LineBreakStyle = hlbDefault then - if (vsMultiline in Node.States) or HintText.Contains(#13) then + if vsMultiline in Node.States then LineBreakStyle := hlbForceMultiLine else LineBreakStyle := hlbForceSingleLine; @@ -3407,6 +5817,545 @@ begin Result := False; end; +//----------------- TVTDragImage --------------------------------------------------------------------------------------- + +constructor TVTDragImage.Create(AOwner: TBaseVirtualTree); + +begin + FOwner := AOwner; + FTransparency := 128; + FPreBlendBias := 0; + FPostBlendBias := 0; + FFade := False; + FRestriction := dmrNone; + FColorKey := clNone; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +destructor TVTDragImage.Destroy; + +begin + EndDrag; + + inherited; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDragImage.GetVisible: Boolean; + +// Returns True if the internal drag image is used (i.e. the system does not natively support drag images) and +// the internal image is currently visible on screen. + +begin + Result := FStates * [disHidden, disInDrag, disPrepared, disSystemSupport] = [disInDrag, disPrepared]; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTDragImage.InternalShowDragImage(ScreenDC: HDC); + +// Frequently called helper routine to actually do the blend and put it onto the screen. +// Only used if the system does not support drag images. + +var + BlendMode: TBlendMode; + +begin + with FAlphaImage do + BitBlt(Canvas.Handle, 0, 0, Width, Height, FBackImage.Canvas.Handle, 0, 0, SRCCOPY); + if not FFade and (FColorKey = clNone) then + BlendMode := bmConstantAlpha + else + BlendMode := bmMasterAlpha; + with FDragImage do + AlphaBlend(Canvas.Handle, FAlphaImage.Canvas.Handle, Rect(0, 0, Width, Height), Point(0, 0), BlendMode, + FTransparency, FPostBlendBias); + + with FAlphaImage do + BitBlt(ScreenDC, FImagePosition.X, FImagePosition.Y, Width, Height, Canvas.Handle, 0, 0, SRCCOPY); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTDragImage.MakeAlphaChannel(Source, Target: TBitmap); + +// Helper method to create a proper alpha channel in Target (which must be in 32 bit pixel format), depending +// on the settings for the drag image and the color values in Source. +// Only used if the system does not support drag images. + +type + PBGRA = ^TBGRA; + TBGRA = packed record + case Boolean of + False: + (Color: Cardinal); + True: + (BGR: array[0..2] of Byte; + Alpha: Byte); + end; + +var + Color, + ColorKeyRef: COLORREF; + UseColorKey: Boolean; + SourceRun, + TargetRun: PBGRA; + X, Y, + MaxDimension, + HalfWidth, + HalfHeight: Integer; + T: Extended; + +begin + UseColorKey := ColorKey <> clNone; + ColorKeyRef := ColorToRGB(ColorKey) and $FFFFFF; + // Color values are in the form BGR (red on LSB) while bitmap colors are in the form ARGB (blue on LSB) + // hence we have to swap red and blue in the color key. + with TBGRA(ColorKeyRef) do + begin + X := BGR[0]; + BGR[0] := BGR[2]; + BGR[2] := X; + end; + + with Target do + begin + MaxDimension := Max(Width, Height); + + HalfWidth := Width div 2; + HalfHeight := Height div 2; + for Y := 0 to Height - 1 do + begin + TargetRun := Scanline[Y]; + SourceRun := Source.Scanline[Y]; + for X := 0 to Width - 1 do + begin + Color := SourceRun.Color and $FFFFFF; + if UseColorKey and (Color = ColorKeyRef) then + TargetRun.Alpha := 0 + else + begin + // If the color is not the given color key (or none is used) then do full calculation of a bell curve. + T := Exp(-8 * Sqrt(Sqr((X - HalfWidth) / MaxDimension) + Sqr((Y - HalfHeight) / MaxDimension))); + TargetRun.Alpha := Round(255 * T); + end; + Inc(SourceRun); + Inc(TargetRun); + end; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDragImage.DragTo(P: TPoint; ForceRepaint: Boolean): Boolean; + +// Moves the drag image to a new position, which is determined from the passed point P and the previous +// mouse position. +// ForceRepaint is True if something on the screen changed and the back image must be refreshed. + +var + ScreenDC: HDC; + DeltaX, + DeltaY: Integer; + + // optimized drag image move support + RSamp1, + RSamp2, // newly added parts from screen which will be overwritten + RDraw1, + RDraw2, // parts to be restored to screen + RScroll, + RClip: TRect; // ScrollDC of the existent background + +begin + // Determine distances to move the drag image. Take care for restrictions. + case FRestriction of + dmrHorizontalOnly: + begin + DeltaX := FLastPosition.X - P.X; + DeltaY := 0; + end; + dmrVerticalOnly: + begin + DeltaX := 0; + DeltaY := FLastPosition.Y - P.Y; + end; + else // dmrNone + DeltaX := FLastPosition.X - P.X; + DeltaY := FLastPosition.Y - P.Y; + end; + + Result := (DeltaX <> 0) or (DeltaY <> 0) or ForceRepaint; + if Result then + begin + if Visible then + begin + // All this stuff is only called if we have to handle the drag image ourselves. If the system supports + // drag image then this is all never executed. + ScreenDC := GetDC(0); + try + if (Abs(DeltaX) >= FDragImage.Width) or (Abs(DeltaY) >= FDragImage.Height) or ForceRepaint then + begin + // If moved more than image size then just restore old screen and blit image to new position. + BitBlt(ScreenDC, FImagePosition.X, FImagePosition.Y, FBackImage.Width, FBackImage.Height, + FBackImage.Canvas.Handle, 0, 0, SRCCOPY); + + if ForceRepaint then + UpdateWindow(FOwner.Handle); + + Inc(FImagePosition.X, -DeltaX); + Inc(FImagePosition.Y, -DeltaY); + + BitBlt(FBackImage.Canvas.Handle, 0, 0, FBackImage.Width, FBackImage.Height, ScreenDC, FImagePosition.X, + FImagePosition.Y, SRCCOPY); + end + else + begin + // overlapping copy + FillDragRectangles(FDragImage.Width, FDragImage.Height, DeltaX, DeltaY, RClip, RScroll, RSamp1, RSamp2, RDraw1, + RDraw2); + + with FBackImage.Canvas do + begin + // restore uncovered areas of the screen + if DeltaX = 0 then + begin + with TWithSafeRect(RDraw2) do + BitBlt(ScreenDC, FImagePosition.X + Left, FImagePosition.Y + Top, Right, Bottom, Handle, Left, Top, + SRCCOPY); + end + else + begin + if DeltaY = 0 then + begin + with TWithSafeRect(RDraw1) do + BitBlt(ScreenDC, FImagePosition.X + Left, FImagePosition.Y + Top, Right, Bottom, Handle, Left, Top, + SRCCOPY); + end + else + begin + with TWithSafeRect(RDraw1) do + BitBlt(ScreenDC, FImagePosition.X + Left, FImagePosition.Y + Top, Right, Bottom, Handle, Left, Top, + SRCCOPY); + with TWithSafeRect(RDraw2) do + BitBlt(ScreenDC, FImagePosition.X + Left, FImagePosition.Y + Top, Right, Bottom, Handle, Left, Top, + SRCCOPY); + end; + end; + + // move existent background + ScrollDC(Handle, DeltaX, DeltaY, RScroll, RClip, 0, nil); + + Inc(FImagePosition.X, -DeltaX); + Inc(FImagePosition.Y, -DeltaY); + + // Get first and second additional rectangle from screen. + if DeltaX = 0 then + begin + with TWithSafeRect(RSamp2) do + BitBlt(Handle, Left, Top, Right, Bottom, ScreenDC, FImagePosition.X + Left, FImagePosition.Y + Top, + SRCCOPY); + end + else + if DeltaY = 0 then + begin + with TWithSafeRect(RSamp1) do + BitBlt(Handle, Left, Top, Right, Bottom, ScreenDC, FImagePosition.X + Left, FImagePosition.Y + Top, + SRCCOPY); + end + else + begin + with TWithSafeRect(RSamp1) do + BitBlt(Handle, Left, Top, Right, Bottom, ScreenDC, FImagePosition.X + Left, FImagePosition.Y + Top, + SRCCOPY); + with TWithSafeRect(RSamp2) do + BitBlt(Handle, Left, Top, Right, Bottom, ScreenDC, FImagePosition.X + Left, FImagePosition.Y + Top, + SRCCOPY); + end; + end; + end; + InternalShowDragImage(ScreenDC); + finally + ReleaseDC(0, ScreenDC); + end; + end; + FLastPosition.X := P.X; + FLastPosition.Y := P.Y; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTDragImage.EndDrag; + +begin + HideDragImage; + FStates := FStates - [disInDrag, disPrepared]; + + FBackImage.Free; + FBackImage := nil; + FDragImage.Free; + FDragImage := nil; + FAlphaImage.Free; + FAlphaImage := nil; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDragImage.GetDragImageRect: TRect; + +// Returns the current size and position of the drag image (screen coordinates). + +begin + if Visible then + begin + with FBackImage do + Result := Rect(FImagePosition.X, FImagePosition.Y, FImagePosition.X + Width, FImagePosition.Y + Height); + end + else + Result := Rect(0, 0, 0, 0); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTDragImage.HideDragImage; + +var + ScreenDC: HDC; + +begin + if Visible then + begin + Include(FStates, disHidden); + ScreenDC := GetDC(0); + try + // restore screen + with FBackImage do + BitBlt(ScreenDC, FImagePosition.X, FImagePosition.Y, Width, Height, Canvas.Handle, 0, 0, SRCCOPY); + finally + ReleaseDC(0, ScreenDC); + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTDragImage.PrepareDrag(DragImage: TBitmap; ImagePosition, HotSpot: TPoint; const DataObject: IDataObject); + +// Creates all necessary structures to do alpha blended dragging using the given image. +// ImagePostion and HotSpot are given in screen coordinates. The first determines where to place the drag image while +// the second is the initial mouse position. +// This method also determines whether the system supports drag images natively. If so then only minimal structures +// are created. + +var + Width, + Height: Integer; + DragSourceHelper: IDragSourceHelper; + DragInfo: TSHDragImage; + lDragSourceHelper2: IDragSourceHelper2;// Needed to get Windows Vista+ style drag hints. + lNullPoint: TPoint; +begin + Width := DragImage.Width; + Height := DragImage.Height; + + // Determine whether the system supports the drag helper interfaces. + if Assigned(DataObject) and Succeeded(CoCreateInstance(CLSID_DragDropHelper, nil, CLSCTX_INPROC_SERVER, + IDragSourceHelper, DragSourceHelper)) then + begin + Include(FStates, disSystemSupport); + lNullPoint := Point(0,0); + if Supports(DragSourceHelper, IDragSourceHelper2, lDragSourceHelper2) then + lDragSourceHelper2.SetFlags(DSH_ALLOWDROPDESCRIPTIONTEXT);// Show description texts + // First let the system try to initialze the DragSourceHelper, this works fine for file system objects (CF_HDROP) + StandardOLEFormat.cfFormat := CF_HDROP; + if not Succeeded(DataObject.QueryGetData(StandardOLEFormat)) or not Succeeded(DragSourceHelper.InitializeFromWindow(0, lNullPoint, DataObject)) then + begin + // Supply the drag source helper with our drag image. + DragInfo.sizeDragImage.cx := Width; + DragInfo.sizeDragImage.cy := Height; + DragInfo.ptOffset.x := Width div 2; + DragInfo.ptOffset.y := Height div 2; + DragInfo.hbmpDragImage := CopyImage(DragImage.Handle, IMAGE_BITMAP, Width, Height, LR_COPYRETURNORG); + DragInfo.crColorKey := ColorToRGB(FColorKey); + if not Succeeded(DragSourceHelper.InitializeFromBitmap(@DragInfo, DataObject)) then + begin + DeleteObject(DragInfo.hbmpDragImage); + Exclude(FStates, disSystemSupport); + end; + end; + end + else + Exclude(FStates, disSystemSupport); + + if not (disSystemSupport in FStates) then + begin + FLastPosition := HotSpot; + + FDragImage := TBitmap.Create; + FDragImage.PixelFormat := pf32Bit; + FDragImage.SetSize(Width, Height); + + FAlphaImage := TBitmap.Create; + FAlphaImage.PixelFormat := pf32Bit; + FAlphaImage.SetSize(Width, Height); + + FBackImage := TBitmap.Create; + FBackImage.PixelFormat := pf32Bit; + FBackImage.SetSize(Width, Height); + + // Copy the given drag image and apply pre blend bias if required. + if FPreBlendBias = 0 then + with FDragImage do + BitBlt(Canvas.Handle, 0, 0, Width, Height, DragImage.Canvas.Handle, 0, 0, SRCCOPY) + else + AlphaBlend(DragImage.Canvas.Handle, FDragImage.Canvas.Handle, Rect(0, 0, Width, Height), Point(0, 0), + bmConstantAlpha, 255, FPreBlendBias); + + // Create a proper alpha channel also if no fading is required (transparent parts). + MakeAlphaChannel(DragImage, FDragImage); + + FImagePosition := ImagePosition; + + // Initially the drag image is hidden and will be shown during the immediately following DragEnter event. + FStates := FStates + [disInDrag, disHidden, disPrepared]; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTDragImage.RecaptureBackground(Tree: TBaseVirtualTree; R: TRect; VisibleRegion: HRGN; + CaptureNCArea, ReshowDragImage: Boolean); + +// Notification by the drop target tree to update the background image because something in the tree has changed. +// Note: The passed rectangle is given in client coordinates of the current drop target tree (given in Tree). +// The caller does not check if the given rectangle is actually within the drag image. Hence this method must do +// all the checks. +// This method does nothing if the system manages the drag image. + +var + DragRect, + ClipRect: TRect; + PaintTarget: TPoint; + PaintOptions: TVTInternalPaintOptions; + ScreenDC: HDC; + +begin + // Recapturing means we want the tree to paint the new part into our back bitmap instead to the screen. + if Visible then + begin + // Create the minimum rectangle to be recaptured. + MapWindowPoints(Tree.Handle, 0, R, 2); + DragRect := GetDragImageRect; + IntersectRect(R, R, DragRect); + + OffsetRgn(VisibleRegion, -DragRect.Left, -DragRect.Top); + + // The target position for painting in the drag image is relative and can be determined from screen coordinates too. + PaintTarget.X := R.Left - DragRect.Left; + PaintTarget.Y := R.Top - DragRect.Top; + + // The source rectangle is determined by the offsets in the tree. + MapWindowPoints(0, Tree.Handle, R, 2); + OffsetRect(R, -Tree.FOffsetX, -Tree.FOffsetY); + + // Finally let the tree paint the relevant part and upate the drag image on screen. + PaintOptions := [poBackground, poColumnColor, poDrawFocusRect, poDrawDropMark, poDrawSelection, poGridLines]; + with FBackImage do + begin + ClipRect.TopLeft := PaintTarget; + ClipRect.Right := ClipRect.Left + R.Right - R.Left; + ClipRect.Bottom := ClipRect.Top + R.Bottom - R.Top; + // TODO: somehow with clipping, the background image is not drawn on the + // backup image. Need to be diagnosed and fixed. For now, we have coded + // a work around in DragTo where this is used by using the condition + // IsInHeader. (found when solving issue 248) + ClipCanvas(Canvas, ClipRect, VisibleRegion); + Tree.PaintTree(Canvas, R, PaintTarget, PaintOptions); + + if CaptureNCArea then + begin + // Header is painted in this part only so when you use this routine and want + // to capture the header in backup image, this flag should be ON. + // For the non-client area we only need the visible region of the window as limit for painting. + SelectClipRgn(Canvas.Handle, VisibleRegion); + // Since WM_PRINT cannot be given a position where to draw we simply move the window origin and + // get the same effect. + GetWindowRect(Tree.Handle, ClipRect); + SetCanvasOrigin(Canvas, DragRect.Left - ClipRect.Left, DragRect.Top - ClipRect.Top); + Tree.Perform(WM_PRINT, WPARAM(Canvas.Handle), PRF_NONCLIENT); + SetCanvasOrigin(Canvas, 0, 0); + end; + SelectClipRgn(Canvas.Handle, 0); + + if ReshowDragImage then + begin + GDIFlush; + ScreenDC := GetDC(0); + try + InternalShowDragImage(ScreenDC); + finally + ReleaseDC(0, ScreenDC); + end; + end; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTDragImage.ShowDragImage; + +// Shows the drag image after it has been hidden by HideDragImage. +// Note: there might be a new background now. +// Also this method does nothing if the system manages the drag image. + +var + ScreenDC: HDC; + +begin + if FStates * [disInDrag, disHidden, disPrepared, disSystemSupport] = [disInDrag, disHidden, disPrepared] then + begin + Exclude(FStates, disHidden); + + GDIFlush; + ScreenDC := GetDC(0); + try + BitBlt(FBackImage.Canvas.Handle, 0, 0, FBackImage.Width, FBackImage.Height, ScreenDC, FImagePosition.X, + FImagePosition.Y, SRCCOPY); + + InternalShowDragImage(ScreenDC); + finally + ReleaseDC(0, ScreenDC); + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTDragImage.WillMove(P: TPoint): Boolean; + +// This method determines whether the drag image would "physically" move when DragTo would be called with the same +// target point. +// Always returns False if the system drag image support is available. + +begin + Result := Visible; + if Result then + begin + // Determine distances to move the drag image. Take care for restrictions. + case FRestriction of + dmrHorizontalOnly: + Result := FLastPosition.X <> P.X; + dmrVerticalOnly: + Result := FLastPosition.Y <> P.Y; + else // dmrNone + Result := (FLastPosition.X <> P.X) or (FLastPosition.Y <> P.Y); + end; + end; +end; //----------------- TVTVirtualNodeEnumerator --------------------------------------------------------------------------- @@ -3541,8 +6490,5588 @@ begin end; end; +//----------------- TVirtualTreeColumn --------------------------------------------------------------------------------- + +constructor TVirtualTreeColumn.Create(Collection: TCollection); + +begin + FMinWidth := 10; + FMaxWidth := 10000; + FImageIndex := -1; + FMargin := 4; + FSpacing := cDefaultColumnSpacing; + FText := ''; + FOptions := DefaultColumnOptions; + FAlignment := taLeftJustify; + FBiDiMode := bdLeftToRight; + FColor := clWindow; + FLayout := blGlyphLeft; + FBonusPixel := False; + FCaptionAlignment := taLeftJustify; + FCheckType := ctCheckBox; + FCheckState := csUncheckedNormal; + FCheckBox := False; + FHasImage := False; + FDefaultSortDirection := sdAscending; + fEditNextColumn := -1; + + inherited Create(Collection); + + if Assigned(Owner) then begin + FWidth := Owner.FDefaultWidth; + FLastWidth := Owner.FDefaultWidth; + FPosition := Owner.Count - 1; + end; +end; + +procedure TVirtualTreeColumn.SetCollection(Value: TCollection); +begin + inherited; + // Read parent bidi mode and color values as default values. + ParentBiDiModeChanged; + ParentColorChanged; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +destructor TVirtualTreeColumn.Destroy; + +var + I: Integer; + + //--------------- local function --------------------------------------------- + + procedure AdjustColumnIndex(var ColumnIndex: TColumnIndex); + + begin + if Index = ColumnIndex then + ColumnIndex := NoColumn + else + if Index < ColumnIndex then + Dec(ColumnIndex); + end; + + //--------------- end local function ----------------------------------------- + +begin + // Check if this column is somehow referenced by its collection parent or the header. + with Owner do + begin + // If the columns collection object is currently deleting all columns + // then we don't need to check the various cached indices individually. + if not FClearing then + begin + Header.Treeview.CancelEditNode; + IndexChanged(Index, -1); + + AdjustColumnIndex(FHoverIndex); + AdjustColumnIndex(FDownIndex); + AdjustColumnIndex(FTrackIndex); + AdjustColumnIndex(FClickIndex); + + with Header do + begin + AdjustColumnIndex(FAutoSizeIndex); + if Index = FMainColumn then + begin + // If the current main column is about to be destroyed then we have to find a new main column. + FMainColumn := NoColumn; + for I := 0 to Count - 1 do + if I <> Index then + begin + FMainColumn := I; + Break; + end; + end; + AdjustColumnIndex(FSortColumn); + end; + end; + end; + + inherited; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVirtualTreeColumn.GetCaptionAlignment: TAlignment; + +begin + if coUseCaptionAlignment in FOptions then + Result := FCaptionAlignment + else + Result := FAlignment; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVirtualTreeColumn.GetCaptionWidth: TDimension; +var + Theme: HTHEME; + AdvancedOwnerDraw: Boolean; + PaintInfo: THeaderPaintInfo; + RequestedElements: THeaderPaintElements; + + TextSize: TSize; + HeaderGlyphSize: TPoint; + UseText: Boolean; + R: TRect; +begin + AdvancedOwnerDraw := (hoOwnerDraw in Owner.Header.Options) and Assigned(Owner.Header.Treeview.FOnAdvancedHeaderDraw) and Assigned(Owner.Header.Treeview.FOnHeaderDrawQueryElements) and + not(csDesigning in Owner.Header.Treeview.ComponentState); + + PaintInfo.Column := Self; + PaintInfo.TargetCanvas := Owner.FHeaderBitmap.Canvas; + + with PaintInfo, Column do + begin + ShowHeaderGlyph := (hoShowImages in Owner.Header.Options) and ((Assigned(Owner.Header.Images) and (FImageIndex > -1)) or FCheckBox); + ShowSortGlyph := ((Owner.Header.FSortColumn > -1) and (Self = Owner.Items[Owner.Header.SortColumn])) and (hoShowSortGlyphs in Owner.Header.Options); + + // This path for text columns or advanced owner draw. + // See if the application wants to draw part of the header itself. + RequestedElements := []; + if AdvancedOwnerDraw then + begin + PaintInfo.Column := Self; + Owner.Header.Treeview.DoHeaderDrawQueryElements(PaintInfo, RequestedElements); + end; + end; + + UseText := Length(FText) > 0; + // If nothing is to show then don't waste time with useless preparation. + if not(UseText or PaintInfo.ShowHeaderGlyph or PaintInfo.ShowSortGlyph) then + Exit(0); + + // Calculate sizes of the involved items. + with Owner, Header do + begin + if PaintInfo.ShowHeaderGlyph then + if not FCheckBox then + begin + if Assigned(FImages) then + HeaderGlyphSize := Point(FImages.Width, FImages.Height); + end + else + with Self.Owner.Header.Treeview do + begin + if Assigned(FCheckImages) then + HeaderGlyphSize := Point(FCheckImages.Width, FCheckImages.Height); + end + else + HeaderGlyphSize := Point(0, 0); + if PaintInfo.ShowSortGlyph then + begin + if tsUseExplorerTheme in FHeader.Treeview.FStates then + begin + R := Rect(0, 0, 100, 100); + Theme := OpenThemeData(FHeader.Treeview.Handle, 'HEADER'); + GetThemePartSize(Theme, PaintInfo.TargetCanvas.Handle, HP_HEADERSORTARROW, HSAS_SORTEDUP, @R, TS_TRUE, PaintInfo.SortGlyphSize); + CloseThemeData(Theme); + end + else + begin + PaintInfo.SortGlyphSize.cx := Header.Treeview.ScaledPixels(16); + PaintInfo.SortGlyphSize.cy := Header.Treeview.ScaledPixels(4); + end; + end + else + begin + PaintInfo.SortGlyphSize.cx := 0; + PaintInfo.SortGlyphSize.cy := 0; + end; + end; + + if UseText then + begin + GetTextExtentPoint32W(PaintInfo.TargetCanvas.Handle, PWideChar(FText), Length(FText), TextSize); + Inc(TextSize.cx, 2); + end + else + begin + TextSize.cx := 0; + TextSize.cy := 0; + end; + + // if CalculateTextRect then + Result := TextSize.cx; + if PaintInfo.ShowHeaderGlyph then + if Layout in [blGlyphLeft, blGlyphRight] then + Inc(Result, HeaderGlyphSize.X + FSpacing) + else // if Layout in [ blGlyphTop, blGlyphBottom] then + Result := Max(Result, HeaderGlyphSize.X); + if PaintInfo.ShowSortGlyph then + Inc(Result, PaintInfo.SortGlyphSize.cx + FSpacing + 2); // without this +2, there is a slight movement of the sort glyph when expanding the column + +end; +//---------------------------------------------------------------------------------------------------------------------- + +function TVirtualTreeColumn.GetLeft: Integer; + +begin + Result := FLeft; + if [coVisible, coFixed] * FOptions <> [coVisible, coFixed] then + Dec(Result, Owner.Header.Treeview.FEffectiveOffsetX); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVirtualTreeColumn.IsBiDiModeStored: Boolean; + +begin + Result := not (coParentBiDiMode in FOptions); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVirtualTreeColumn.IsCaptionAlignmentStored: Boolean; + +begin + Result := coUseCaptionAlignment in FOptions; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVirtualTreeColumn.IsColorStored: Boolean; + +begin + Result := not (coParentColor in FOptions); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumn.SetAlignment(const Value: TAlignment); + +begin + if FAlignment <> Value then + begin + FAlignment := Value; + Changed(False); + // Setting the alignment affects also the tree, hence invalidate it too. + Owner.Header.TreeView.Invalidate; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumn.SetBiDiMode(Value: TBiDiMode); + +begin + if Value <> FBiDiMode then + begin + FBiDiMode := Value; + Exclude(FOptions, coParentBiDiMode); + Changed(False); + // Setting the alignment affects also the tree, hence invalidate it too. + Owner.Header.TreeView.Invalidate; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumn.SetCaptionAlignment(const Value: TAlignment); + +begin + if not (coUseCaptionAlignment in FOptions) or (FCaptionAlignment <> Value) then + begin + FCaptionAlignment := Value; + Include(FOptions, coUseCaptionAlignment); + // Setting the alignment affects also the tree, hence invalidate it too. + Owner.Header.Invalidate(Self); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumn.SetColor(const Value: TColor); + +begin + if FColor <> Value then + begin + FColor := Value; + Exclude(FOptions, coParentColor); + Exclude(FOptions, coStyleColor); // Issue #919 + Changed(False); + Owner.Header.TreeView.Invalidate; + end; +end; + +function TVirtualTreeColumn.GetEffectiveColor(): TColor; +// Returns the color that should effectively be used as background color for this +// column considering all flags in the TVirtualTreeColumn.Options property +begin + if (coParentColor in Options) or ((coStyleColor in Options) and Owner.Header.TreeView.VclStyleEnabled) then + Result := Owner.Header.TreeView.FColors.BackGroundColor + else + Result := Self.Color; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumn.SetCheckBox(Value: Boolean); + +begin + if Value <> FCheckBox then + begin + FCheckBox := Value; + if Value and (csDesigning in Owner.Header.Treeview.ComponentState) then + Owner.Header.Options := Owner.Header.Options + [hoShowImages]; + Changed(False); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumn.SetCheckState(Value: TCheckState); + +begin + if Value <> FCheckState then + begin + FCheckState := Value; + Changed(False); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumn.SetCheckType(Value: TCheckType); + +begin + if Value <> FCheckType then + begin + FCheckType := Value; + Changed(False); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumn.SetImageIndex(Value: TImageIndex); + +begin + if Value <> FImageIndex then + begin + FImageIndex := Value; + Changed(False); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumn.SetLayout(Value: TVTHeaderColumnLayout); + +begin + if FLayout <> Value then + begin + FLayout := Value; + Changed(False); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumn.SetMargin(Value: Integer); + +begin + // Compatibility setting for -1. + if Value < 0 then + Value := 4; + if FMargin <> Value then + begin + FMargin := Value; + Changed(False); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumn.SetMaxWidth(Value: Integer); + +begin + if Value < FMinWidth then + Value := FMinWidth; + FMaxWidth := Value; + SetWidth(FWidth); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumn.SetMinWidth(Value: Integer); + +begin + if Value < 0 then + Value := 0; + if Value > FMaxWidth then + Value := FMaxWidth; + FMinWidth := Value; + SetWidth(FWidth); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumn.SetOptions(Value: TVTColumnOptions); + +var + ToBeSet, + ToBeCleared: TVTColumnOptions; + VisibleChanged, + lParentColorSet: Boolean; + lTreeView: TBaseVirtualTree; +begin + if FOptions <> Value then + begin + ToBeCleared := FOptions - Value; + ToBeSet := Value - FOptions; + + FOptions := Value; + + VisibleChanged := coVisible in (ToBeSet + ToBeCleared); + lParentColorSet := coParentColor in ToBeSet; + + if coParentBidiMode in ToBeSet then + ParentBiDiModeChanged; + if lParentColorSet then begin + Include(FOptions, coStyleColor);// Issue #919 + ParentColorChanged(); + end; + + if coAutoSpring in ToBeSet then + FSpringRest := 0; + + if coVisible in ToBeCleared then + Owner.Header.UpdateMainColumn(); // Fixes issue #946 + + if ((coFixed in ToBeSet) or (coFixed in ToBeCleared)) and (coVisible in FOptions) then + Owner.Header.RescaleHeader; + + Changed(False); + // Need to repaint and adjust the owner tree too. + lTreeView := Owner.Header.Treeview; + if not (csLoading in lTreeview.ComponentState) and (VisibleChanged or lParentColorSet) and (Owner.UpdateCount = 0) and lTreeView.HandleAllocated then + begin + lTreeview.Invalidate(); + if VisibleChanged then begin + lTreeview.DoColumnVisibilityChanged(Self.Index, coVisible in ToBeSet); + lTreeview.UpdateHorizontalScrollBar(False); + end; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumn.SetPosition(Value: TColumnPosition); + +var + Temp: TColumnIndex; + +begin + if (csLoading in Owner.Header.Treeview.ComponentState) or (Owner.UpdateCount > 0) then + // Only cache the position for final fixup when loading from DFM. + FPosition := Value + else + begin + if Value >= TColumnPosition(Collection.Count) then + Value := Collection.Count - 1; + if FPosition <> Value then + begin + with Owner do + begin + InitializePositionArray; + Header.Treeview.CancelEditNode; + AdjustPosition(Self, Value); + Self.Changed(False); + + // Need to repaint. + with Header do + begin + if (UpdateCount = 0) and Treeview.HandleAllocated then + begin + Invalidate(Self); + Treeview.Invalidate; + end; + end; + end; + + // If the moved column is now within the fixed columns then we make it fixed as well. If it's not + // we clear the fixed state (in case that fixed column is moved outside fixed area). + if (coFixed in FOptions) and (FPosition > 0) then + Temp := Owner.ColumnFromPosition(FPosition - 1) + else + Temp := Owner.ColumnFromPosition(FPosition + 1); + + if Temp <> NoColumn then + begin + if coFixed in Owner[Temp].Options then + Options := Options + [coFixed] + else + Options := Options - [coFixed]; + end; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumn.SetSpacing(Value: Integer); + +begin + if FSpacing <> Value then + begin + FSpacing := Value; + Changed(False); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumn.SetStyle(Value: TVirtualTreeColumnStyle); + +begin + if FStyle <> Value then + begin + FStyle := Value; + Changed(False); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumn.SetText(const Value: string); + +begin + if FText <> Value then + begin + FText := Value; + FCaptionText := ''; + Changed(False); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumn.SetWidth(Value: Integer); + +var + EffectiveMaxWidth, + EffectiveMinWidth, + TotalFixedMaxWidth, + TotalFixedMinWidth: Integer; + I: TColumnIndex; + +begin + if not (hsScaling in Owner.Header.States) then + if ([coVisible, coFixed] * FOptions = [coVisible, coFixed]) then + begin + with Owner, FHeader, FFixedAreaConstraints, TreeView do + begin + TotalFixedMinWidth := 0; + TotalFixedMaxWidth := 0; + for I := 0 to FColumns.Count - 1 do + if ([coVisible, coFixed] * FColumns[I].Options = [coVisible, coFixed]) then + begin + Inc(TotalFixedMaxWidth, FColumns[I].MaxWidth); + Inc(TotalFixedMinWidth, FColumns[I].MinWidth); + end; + + if HandleAllocated then // Prevent premature creation of window handle, see issue #1073 + begin + // The percentage values have precedence over the pixel values. + If FMaxWidthPercent > 0 then + TotalFixedMinWidth:= Min((ClientWidth * FMaxWidthPercent) div 100, TotalFixedMinWidth); + If FMinWidthPercent > 0 then + TotalFixedMaxWidth := Max((ClientWidth * FMinWidthPercent) div 100, TotalFixedMaxWidth); + + EffectiveMaxWidth := Min(TotalFixedMaxWidth - (GetVisibleFixedWidth - Self.FWidth), FMaxWidth); + EffectiveMinWidth := Max(TotalFixedMinWidth - (GetVisibleFixedWidth - Self.FWidth), FMinWidth); + Value := Min(Max(Value, EffectiveMinWidth), EffectiveMaxWidth); + + if FMinWidthPercent > 0 then + Value := Max((ClientWidth * FMinWidthPercent) div 100 - GetVisibleFixedWidth + Self.FWidth, Value); + if FMaxWidthPercent > 0 then + Value := Min((ClientWidth * FMaxWidthPercent) div 100 - GetVisibleFixedWidth + Self.FWidth, Value); + end;// if HandleAllocated + end; + end + else + Value := Min(Max(Value, FMinWidth), FMaxWidth); + + if FWidth <> Value then + begin + FLastWidth := FWidth; + if not (hsResizing in Owner.Header.States) then + FBonusPixel := False; + if not (hoAutoResize in Owner.Header.Options) or (Index <> Owner.Header.AutoSizeIndex) then + begin + FWidth := Value; + Owner.UpdatePositions; + end; + if not (csLoading in Owner.Header.Treeview.ComponentState) and (Owner.UpdateCount = 0) then + begin + if hoAutoResize in Owner.Header.Options then + Owner.AdjustAutoSize(Index); + Owner.Header.Treeview.DoColumnResize(Index); + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumn.ChangeScale(M, D: TDimension; isDpiChange: Boolean); +begin + FMinWidth := MulDiv(FMinWidth, M, D); + FMaxWidth := MulDiv(FMaxWidth, M, D); + FSpacing := MulDiv(FSpacing, M, D); + Self.Width := MulDiv(Self.Width, M, D); +end; + +procedure TVirtualTreeColumn.ComputeHeaderLayout(var PaintInfo: THeaderPaintInfo; DrawFormat: Cardinal; CalculateTextRect: Boolean = False); + +// The layout of a column header is determined by a lot of factors. This method takes them all into account and +// determines all necessary positions and bounds: +// - for the header text +// - the header glyph +// - the sort glyph + +var + TextSize: TSize; + TextPos, + ClientSize, + HeaderGlyphSize: TPoint; + CurrentAlignment: TAlignment; + MinLeft, + MaxRight, + TextSpacing: Integer; + UseText: Boolean; + R: TRect; + Theme: HTHEME; + +begin + UseText := Length(FText) > 0; + // If nothing is to show then don't waste time with useless preparation. + if not (UseText or PaintInfo.ShowHeaderGlyph or PaintInfo.ShowSortGlyph) then + Exit; + + CurrentAlignment := CaptionAlignment; + if FBiDiMode <> bdLeftToRight then + ChangeBiDiModeAlignment(CurrentAlignment); + + // Calculate sizes of the involved items. + ClientSize := Point(PaintInfo.PaintRectangle.Right - PaintInfo.PaintRectangle.Left, PaintInfo.PaintRectangle.Bottom - PaintInfo.PaintRectangle.Top); + with Owner, Header do + begin + if PaintInfo.ShowHeaderGlyph then + if not FCheckBox then + HeaderGlyphSize := Point(FImages.Width, FImages.Height) + else + with Self.Owner.Header.Treeview do + begin + if Assigned(FCheckImages) then + HeaderGlyphSize := Point(FCheckImages.Width, FCheckImages.Height); + end + else + HeaderGlyphSize := Point(0, 0); + if PaintInfo.ShowSortGlyph then + begin + if tsUseExplorerTheme in FHeader.Treeview.FStates then + begin + R := Rect(0, 0, 100, 100); + Theme := OpenThemeData(FHeader.Treeview.Handle, 'HEADER'); + GetThemePartSize(Theme, PaintInfo.TargetCanvas.Handle, HP_HEADERSORTARROW, HSAS_SORTEDUP, @R, TS_TRUE, PaintInfo.SortGlyphSize); + CloseThemeData(Theme); + end + else + begin + PaintInfo.SortGlyphSize.cx := Header.Treeview.ScaledPixels(16); + PaintInfo.SortGlyphSize.cy := Header.Treeview.ScaledPixels(4); + end; + + // In any case, the sort glyph is vertically centered. + PaintInfo.SortGlyphPos.Y := (ClientSize.Y - PaintInfo.SortGlyphSize.cy) div 2; + end + else + begin + PaintInfo.SortGlyphSize.cx := 0; + PaintInfo.SortGlyphSize.cy := 0; + end; + end; + + if UseText then + begin + if not (coWrapCaption in FOptions) then + begin + FCaptionText := FText; + GetTextExtentPoint32W(PaintInfo.TargetCanvas.Handle, PWideChar(FText), Length(FText), TextSize); + Inc(TextSize.cx, 2); + PaintInfo.TextRectangle := Rect(0, 0, TextSize.cx, TextSize.cy); + end + else + begin + R := PaintInfo.PaintRectangle; + if FCaptionText = '' then + FCaptionText := WrapString(PaintInfo.TargetCanvas.Handle, FText, R, DT_RTLREADING and DrawFormat <> 0, DrawFormat); + + GetStringDrawRect(PaintInfo.TargetCanvas.Handle, FCaptionText, R, DrawFormat); + TextSize.cx := PaintInfo.PaintRectangle.Right - PaintInfo.PaintRectangle.Left; + TextSize.cy := R.Bottom - R.Top; + PaintInfo.TextRectangle := Rect(0, 0, TextSize.cx, TextSize.cy); + end; + TextSpacing := FSpacing; + end + else + begin + TextSpacing := 0; + TextSize.cx := 0; + TextSize.cy := 0; + end; + + // Check first for the special case where nothing is shown except the sort glyph. + if PaintInfo.ShowSortGlyph and not (UseText or PaintInfo.ShowHeaderGlyph) then + begin + // Center the sort glyph in the available area if nothing else is there. + PaintInfo.SortGlyphPos := Point((ClientSize.X - PaintInfo.SortGlyphSize.cx) div 2, (ClientSize.Y - PaintInfo.SortGlyphSize.cy) div 2); + end + else + begin + // Determine extents of text and glyph and calculate positions which are clear from the layout. + if (Layout in [blGlyphLeft, blGlyphRight]) or not PaintInfo.ShowHeaderGlyph then + begin + PaintInfo.GlyphPos.Y := (ClientSize.Y - HeaderGlyphSize.Y) div 2; + // If the text is taller than the given height, perform no vertical centration as this + // would make the text even less readable. + //Using Max() fixes badly positioned text if Extra Large fonts have been activated in the Windows display options + TextPos.Y := Max(-5, (ClientSize.Y - TextSize.cy) div 2); + end + else + begin + if Layout = blGlyphTop then + begin + PaintInfo.GlyphPos.Y := (ClientSize.Y - HeaderGlyphSize.Y - TextSize.cy - TextSpacing) div 2; + TextPos.Y := PaintInfo.GlyphPos.Y + HeaderGlyphSize.Y + TextSpacing; + end + else + begin + TextPos.Y := (ClientSize.Y - HeaderGlyphSize.Y - TextSize.cy - TextSpacing) div 2; + PaintInfo.GlyphPos.Y := TextPos.Y + TextSize.cy + TextSpacing; + end; + end; + + // Each alignment needs special consideration. + case CurrentAlignment of + taLeftJustify: + begin + MinLeft := FMargin; + if PaintInfo.ShowSortGlyph and (FBiDiMode <> bdLeftToRight) then + begin + // In RTL context is the sort glyph placed on the left hand side. + PaintInfo.SortGlyphPos.X := MinLeft; + Inc(MinLeft, PaintInfo.SortGlyphSize.cx + FSpacing); + end; + if Layout in [blGlyphTop, blGlyphBottom] then + begin + // Header glyph is above or below text, so both must be considered when calculating + // the left positition of the sort glyph (if it is on the right hand side). + TextPos.X := MinLeft; + if PaintInfo.ShowHeaderGlyph then + begin + PaintInfo.GlyphPos.X := (ClientSize.X - HeaderGlyphSize.X) div 2; + if PaintInfo.GlyphPos.X < MinLeft then + PaintInfo.GlyphPos.X := MinLeft; + MinLeft := Max(TextPos.X + TextSize.cx + TextSpacing, PaintInfo.GlyphPos.X + HeaderGlyphSize.X + FSpacing); + end + else + MinLeft := TextPos.X + TextSize.cx + TextSpacing; + end + else + begin + // Everything is lined up. TextSpacing might be 0 if there is no text. + // This simplifies the calculation because no extra tests are necessary. + if PaintInfo.ShowHeaderGlyph and (Layout = blGlyphLeft) then + begin + PaintInfo.GlyphPos.X := MinLeft; + Inc(MinLeft, HeaderGlyphSize.X + FSpacing); + end; + TextPos.X := MinLeft; + Inc(MinLeft, TextSize.cx + TextSpacing); + if PaintInfo.ShowHeaderGlyph and (Layout = blGlyphRight) then + begin + PaintInfo.GlyphPos.X := MinLeft; + Inc(MinLeft, HeaderGlyphSize.X + FSpacing); + end; + end; + if PaintInfo.ShowSortGlyph and (FBiDiMode = bdLeftToRight) then + PaintInfo.SortGlyphPos.X := MinLeft; + end; + taCenter: + begin + if Layout in [blGlyphTop, blGlyphBottom] then + begin + PaintInfo.GlyphPos.X := (ClientSize.X - HeaderGlyphSize.X) div 2; + TextPos.X := (ClientSize.X - TextSize.cx) div 2; + if PaintInfo.ShowSortGlyph then + Dec(TextPos.X, PaintInfo.SortGlyphSize.cx div 2); + end + else + begin + MinLeft := (ClientSize.X - HeaderGlyphSize.X - TextSpacing - TextSize.cx) div 2; + if PaintInfo.ShowHeaderGlyph and (Layout = blGlyphLeft) then + begin + PaintInfo.GlyphPos.X := MinLeft; + Inc(MinLeft, HeaderGlyphSize.X + TextSpacing); + end; + TextPos.X := MinLeft; + Inc(MinLeft, TextSize.cx + TextSpacing); + if PaintInfo.ShowHeaderGlyph and (Layout = blGlyphRight) then + PaintInfo.GlyphPos.X := MinLeft; + end; + if PaintInfo.ShowHeaderGlyph then + begin + MinLeft := Min(PaintInfo.GlyphPos.X, TextPos.X); + MaxRight := Max(PaintInfo.GlyphPos.X + HeaderGlyphSize.X, TextPos.X + TextSize.cx); + end + else + begin + MinLeft := TextPos.X; + MaxRight := TextPos.X + TextSize.cx; + end; + // Place the sort glyph directly to the left or right of the larger item. + if PaintInfo.ShowSortGlyph then + if FBiDiMode = bdLeftToRight then + begin + // Sort glyph on the right hand side. + PaintInfo.SortGlyphPos.X := MaxRight + FSpacing; + end + else + begin + // Sort glyph on the left hand side. + PaintInfo.SortGlyphPos.X := MinLeft - FSpacing - PaintInfo.SortGlyphSize.cx; + end; + end; + else + // taRightJustify + MaxRight := ClientSize.X - FMargin; + if PaintInfo.ShowSortGlyph and (FBiDiMode = bdLeftToRight) then + begin + // In LTR context is the sort glyph placed on the right hand side. + Dec(MaxRight, PaintInfo.SortGlyphSize.cx); + PaintInfo.SortGlyphPos.X := MaxRight; + Dec(MaxRight, FSpacing); + end; + if Layout in [blGlyphTop, blGlyphBottom] then + begin + TextPos.X := MaxRight - TextSize.cx; + if PaintInfo.ShowHeaderGlyph then + begin + PaintInfo.GlyphPos.X := (ClientSize.X - HeaderGlyphSize.X) div 2; + if PaintInfo.GlyphPos.X + HeaderGlyphSize.X + FSpacing > MaxRight then + PaintInfo.GlyphPos.X := MaxRight - HeaderGlyphSize.X - FSpacing; + MaxRight := Min(TextPos.X - TextSpacing, PaintInfo.GlyphPos.X - FSpacing); + end + else + MaxRight := TextPos.X - TextSpacing; + end + else + begin + // Everything is lined up. TextSpacing might be 0 if there is no text. + // This simplifies the calculation because no extra tests are necessary. + if PaintInfo.ShowHeaderGlyph and (Layout = blGlyphRight) then + begin + PaintInfo.GlyphPos.X := MaxRight - HeaderGlyphSize.X; + MaxRight := PaintInfo.GlyphPos.X - FSpacing; + end; + TextPos.X := MaxRight - TextSize.cx; + MaxRight := TextPos.X - TextSpacing; + if PaintInfo.ShowHeaderGlyph and (Layout = blGlyphLeft) then + begin + PaintInfo.GlyphPos.X := MaxRight - HeaderGlyphSize.X; + MaxRight := PaintInfo.GlyphPos.X - FSpacing; + end; + end; + if PaintInfo.ShowSortGlyph and (FBiDiMode <> bdLeftToRight) then + PaintInfo.SortGlyphPos.X := MaxRight - PaintInfo.SortGlyphSize.cx; + end; + end; + + // Once the position of each element is determined there remains only one but important step. + // The horizontal positions of every element must be adjusted so that it always fits into the + // given header area. This is accomplished by shorten the text appropriately. + + // These are the maximum bounds. Nothing goes beyond them. + MinLeft := FMargin; + MaxRight := ClientSize.X - FMargin; + if PaintInfo.ShowSortGlyph then + begin + if FBiDiMode = bdLeftToRight then + begin + // Sort glyph on the right hand side. + if PaintInfo.SortGlyphPos.X + PaintInfo.SortGlyphSize.cx > MaxRight then + PaintInfo.SortGlyphPos.X := MaxRight - PaintInfo.SortGlyphSize.cx; + MaxRight := PaintInfo.SortGlyphPos.X - FSpacing; + end; + + // Consider also the left side of the sort glyph regardless of the bidi mode. + if PaintInfo.SortGlyphPos.X < MinLeft then + PaintInfo.SortGlyphPos.X := MinLeft; + // Left border needs only adjustment if the sort glyph marks the left border. + if FBiDiMode <> bdLeftToRight then + MinLeft := PaintInfo.SortGlyphPos.X + PaintInfo.SortGlyphSize.cx + FSpacing; + + // Finally transform sort glyph to its actual position. + Inc(PaintInfo.SortGlyphPos.X, PaintInfo.PaintRectangle.Left); + Inc(PaintInfo.SortGlyphPos.Y, PaintInfo.PaintRectangle.Top); + end; + if PaintInfo.ShowHeaderGlyph then + begin + if PaintInfo.GlyphPos.X + HeaderGlyphSize.X > MaxRight then + PaintInfo.GlyphPos.X := MaxRight - HeaderGlyphSize.X; + if Layout = blGlyphRight then + MaxRight := PaintInfo.GlyphPos.X - FSpacing; + if PaintInfo.GlyphPos.X < MinLeft then + PaintInfo.GlyphPos.X := MinLeft; + if Layout = blGlyphLeft then + MinLeft := PaintInfo.GlyphPos.X + HeaderGlyphSize.X + FSpacing; + if FCheckBox and (Owner.Header.MainColumn = Self.Index) then + Dec(PaintInfo.GlyphPos.X, 2) + else + if Owner.Header.MainColumn <> Self.Index then + Dec(PaintInfo.GlyphPos.X, 2); + + // Finally transform header glyph to its actual position. + Inc(PaintInfo.GlyphPos.X, PaintInfo.PaintRectangle.Left); + Inc(PaintInfo.GlyphPos.Y, PaintInfo.PaintRectangle.Top); + end; + if UseText then + begin + if TextPos.X < MinLeft then + TextPos.X := MinLeft; + OffsetRect(PaintInfo.TextRectangle, TextPos.X, TextPos.Y); + if PaintInfo.TextRectangle.Right > MaxRight then + PaintInfo.TextRectangle.Right := MaxRight; + OffsetRect(PaintInfo.TextRectangle, PaintInfo.PaintRectangle.Left, PaintInfo.PaintRectangle.Top); + + if coWrapCaption in FOptions then + begin + // Wrap the column caption if necessary. + R := PaintInfo.TextRectangle; + FCaptionText := WrapString(PaintInfo.TargetCanvas.Handle, FText, R, DT_RTLREADING and DrawFormat <> 0, DrawFormat); + GetStringDrawRect(PaintInfo.TargetCanvas.Handle, FCaptionText, R, DrawFormat); + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumn.DefineProperties(Filer: TFiler); + +begin + inherited; + + // These properites are remains from non-Unicode Delphi versions, readers remain for backward compatibility. + Filer.DefineProperty('WideText', ReadText, nil, False); + Filer.DefineProperty('WideHint', ReadHint, nil, False); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumn.GetAbsoluteBounds(var Left, Right: Integer); + +// Returns the column's left and right bounds in header coordinates, that is, independant of the scrolling position. + +begin + Left := FLeft; + Right := FLeft + FWidth; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVirtualTreeColumn.GetDisplayName: string; +begin + Result := FText // Use column header caption as display name +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVirtualTreeColumn.GetOwner: TVirtualTreeColumns; + +begin + Result := Collection as TVirtualTreeColumns; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumn.InternalSetWidth(const value : TDimension); +begin + FWidth := value; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumn.ReadText(Reader: TReader); + +begin + case Reader.NextValue of + vaLString, vaString: + SetText(Reader.ReadString); + else + SetText(Reader.ReadString); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumn.ReadHint(Reader: TReader); + +begin + case Reader.NextValue of + vaLString, vaString: + FHint := Reader.ReadString; + else + FHint := Reader.ReadString; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumn.Assign(Source: TPersistent); + +var + OldOptions: TVTColumnOptions; + +begin + if Source is TVirtualTreeColumn then + begin + OldOptions := FOptions; + FOptions := []; + + BiDiMode := TVirtualTreeColumn(Source).BiDiMode; + ImageIndex := TVirtualTreeColumn(Source).ImageIndex; + Layout := TVirtualTreeColumn(Source).Layout; + Margin := TVirtualTreeColumn(Source).Margin; + MaxWidth := TVirtualTreeColumn(Source).MaxWidth; + MinWidth := TVirtualTreeColumn(Source).MinWidth; + Position := TVirtualTreeColumn(Source).Position; + Spacing := TVirtualTreeColumn(Source).Spacing; + Style := TVirtualTreeColumn(Source).Style; + Text := TVirtualTreeColumn(Source).Text; + Hint := TVirtualTreeColumn(Source).Hint; + Width := TVirtualTreeColumn(Source).Width; + Alignment := TVirtualTreeColumn(Source).Alignment; + CaptionAlignment := TVirtualTreeColumn(Source).CaptionAlignment; + Color := TVirtualTreeColumn(Source).Color; + Tag := TVirtualTreeColumn(Source).Tag; + EditOptions := TVirtualTreeColumn(Source).EditOptions; + EditNextColumn := TVirtualTreeColumn(Source).EditNextColumn; + + // Order is important. Assign options last. + FOptions := OldOptions; + Options := TVirtualTreeColumn(Source).Options; + + Changed(False); + end + else + inherited Assign(Source); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVirtualTreeColumn.Equals(OtherColumnObj: TObject): Boolean; +var + OtherColumn : TVirtualTreeColumn; +begin + if OtherColumnObj is TVirtualTreeColumn then + begin + OtherColumn := TVirtualTreeColumn (OtherColumnObj); + Result := (BiDiMode = OtherColumn.BiDiMode) and + (ImageIndex = OtherColumn.ImageIndex) and + (Layout = OtherColumn.Layout) and + (Margin = OtherColumn.Margin) and + (MaxWidth = OtherColumn.MaxWidth) and + (MinWidth = OtherColumn.MinWidth) and + (Position = OtherColumn.Position) and + (Spacing = OtherColumn.Spacing) and + (Style = OtherColumn.Style) and + (Text = OtherColumn.Text) and + (Hint = OtherColumn.Hint) and + (Width = OtherColumn.Width) and + (Alignment = OtherColumn.Alignment) and + (CaptionAlignment = OtherColumn.CaptionAlignment) and + (Color = OtherColumn.Color) and + (Tag = OtherColumn.Tag) and + (Options = OtherColumn.Options); + end + else + Result := False; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVirtualTreeColumn.GetRect: TRect; + +// Returns the rectangle this column occupies in the header (relative to (0, 0) of the non-client area). + +begin + with TVirtualTreeColumns(GetOwner).FHeader do + Result := Treeview.FHeaderRect; + Inc(Result.Left, FLeft); + Result.Right := Result.Left + FWidth; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +// [IPK] +function TVirtualTreeColumn.GetText: string; + +begin + Result := FText; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumn.LoadFromStream(const Stream: TStream; Version: Integer); +var + Dummy: Integer; + S: string; + +begin + with Stream do + begin + ReadBuffer(Dummy, SizeOf(Dummy)); + SetLength(S, Dummy); + ReadBuffer(PWideChar(S)^, 2 * Dummy); + Text := S; + ReadBuffer(Dummy, SizeOf(Dummy)); + SetLength(FHint, Dummy); + ReadBuffer(PWideChar(FHint)^, 2 * Dummy); + ReadBuffer(Dummy, SizeOf(Dummy)); + Width := Dummy; + ReadBuffer(Dummy, SizeOf(Dummy)); + MinWidth := Dummy; + ReadBuffer(Dummy, SizeOf(Dummy)); + MaxWidth := Dummy; + ReadBuffer(Dummy, SizeOf(Dummy)); + Style := TVirtualTreeColumnStyle(Dummy); + ReadBuffer(Dummy, SizeOf(Dummy)); + ImageIndex := Dummy; + ReadBuffer(Dummy, SizeOf(Dummy)); + Layout := TVTHeaderColumnLayout(Dummy); + ReadBuffer(Dummy, SizeOf(Dummy)); + Margin := Dummy; + ReadBuffer(Dummy, SizeOf(Dummy)); + Spacing := Dummy; + ReadBuffer(Dummy, SizeOf(Dummy)); + BiDiMode := TBiDiMode(Dummy); + + ReadBuffer(Dummy, SizeOf(Dummy)); + if Version >= 3 then + Options := TVTColumnOptions(Dummy); + + if Version > 0 then + begin + // Parts which have been introduced/changed with header stream version 1+. + ReadBuffer(Dummy, SizeOf(Dummy)); + Tag := Dummy; + ReadBuffer(Dummy, SizeOf(Dummy)); + Alignment := TAlignment(Dummy); + + if Version > 1 then + begin + ReadBuffer(Dummy, SizeOf(Dummy)); + Color := TColor(Dummy); + end; + + if Version > 5 then + begin + if coUseCaptionAlignment in FOptions then + begin + ReadBuffer(Dummy, SizeOf(Dummy)); + CaptionAlignment := TAlignment(Dummy); + end; + end; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumn.ParentBiDiModeChanged; + +var + Columns: TVirtualTreeColumns; + +begin + if coParentBiDiMode in FOptions then + begin + Columns := GetOwner as TVirtualTreeColumns; + if Assigned(Columns) and (FBiDiMode <> Columns.FHeader.Treeview.BiDiMode) then + begin + FBiDiMode := Columns.FHeader.Treeview.BiDiMode; + Changed(False); + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumn.ParentColorChanged; + +var + Columns: TVirtualTreeColumns; + +begin + if coParentColor in FOptions then + begin + Columns := GetOwner as TVirtualTreeColumns; + if Assigned(Columns) and (FColor <> Columns.FHeader.Treeview.Color) then + begin + FColor := Columns.FHeader.Treeview.Color; + Changed(False); + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumn.RestoreLastWidth; + +begin + TVirtualTreeColumns(GetOwner).AnimatedResize(Index, FLastWidth); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumn.SaveToStream(const Stream: TStream); + +var + Dummy: Integer; + +begin + with Stream do + begin + Dummy := Length(FText); + WriteBuffer(Dummy, SizeOf(Dummy)); + WriteBuffer(PWideChar(FText)^, 2 * Dummy); + Dummy := Length(FHint); + WriteBuffer(Dummy, SizeOf(Dummy)); + WriteBuffer(PWideChar(FHint)^, 2 * Dummy); + WriteBuffer(FWidth, SizeOf(FWidth)); + WriteBuffer(FMinWidth, SizeOf(FMinWidth)); + WriteBuffer(FMaxWidth, SizeOf(FMaxWidth)); + Dummy := Ord(FStyle); + WriteBuffer(Dummy, SizeOf(Dummy)); + Dummy := FImageIndex; + WriteBuffer(Dummy, SizeOf(Dummy)); + Dummy := Ord(FLayout); + WriteBuffer(Dummy, SizeOf(Dummy)); + WriteBuffer(FMargin, SizeOf(FMargin)); + WriteBuffer(FSpacing, SizeOf(FSpacing)); + Dummy := Ord(FBiDiMode); + WriteBuffer(Dummy, SizeOf(Dummy)); + Dummy := Integer(FOptions); + WriteBuffer(Dummy, SizeOf(Dummy)); + + // parts introduced with stream version 1 + WriteBuffer(FTag, SizeOf(Dummy)); + Dummy := Cardinal(FAlignment); + WriteBuffer(Dummy, SizeOf(Dummy)); + + // parts introduced with stream version 2 + Dummy := Integer(FColor); + WriteBuffer(Dummy, SizeOf(Dummy)); + + // parts introduced with stream version 6 + if coUseCaptionAlignment in FOptions then + begin + Dummy := Cardinal(FCaptionAlignment); + WriteBuffer(Dummy, SizeOf(Dummy)); + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVirtualTreeColumn.UseRightToLeftReading: Boolean; + +begin + Result := FBiDiMode <> bdLeftToRight; +end; + +//----------------- TVirtualTreeColumns -------------------------------------------------------------------------------- + +constructor TVirtualTreeColumns.Create(AOwner: TVTHeader); + +var + ColumnClass: TVirtualTreeColumnClass; + +begin + FHeader := AOwner; + + // Determine column class to be used in the header. + ColumnClass := AOwner.FOwner.GetColumnClass; + // The owner tree always returns the default tree column class if not changed by application/descendants. + inherited Create(ColumnClass); + + FHeaderBitmap := TBitmap.Create; + FHeaderBitmap.PixelFormat := pf32Bit; + + FHoverIndex := NoColumn; + FDownIndex := NoColumn; + FClickIndex := NoColumn; + FDropTarget := NoColumn; + FTrackIndex := NoColumn; + FDefaultWidth := 50; + Self.FColumnPopupMenu := nil; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +destructor TVirtualTreeColumns.Destroy; + +begin + FreeAndNil(FColumnPopupMenu); + FreeAndNil(FHeaderBitmap); + inherited; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVirtualTreeColumns.GetCount: Integer; + +begin + Result := inherited Count; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVirtualTreeColumns.GetItem(Index: TColumnIndex): TVirtualTreeColumn; + +begin + Result := TVirtualTreeColumn(inherited GetItem(Index)); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVirtualTreeColumns.GetNewIndex(P: TPoint; var OldIndex: TColumnIndex): Boolean; + +var + NewIndex: Integer; + +begin + Result := False; + // convert to local coordinates + Inc(P.Y, FHeader.Height); + NewIndex := ColumnFromPosition(P); + if NewIndex <> OldIndex then + begin + if OldIndex > NoColumn then + FHeader.Invalidate(Items[OldIndex], False, True); + OldIndex := NewIndex; + if OldIndex > NoColumn then + FHeader.Invalidate(Items[OldIndex], False, True); + Result := True; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumns.SetDefaultWidth(Value: Integer); + +begin + FDefaultWidth := Value; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumns.SetItem(Index: TColumnIndex; Value: TVirtualTreeColumn); + +begin + inherited SetItem(Index, Value); +end; + +function TVirtualTreeColumns.StyleServices(AControl: TControl): TCustomStyleServices; +begin + if AControl = nil then + AControl := FHeader.Treeview; + Result := VTStyleServices(AControl); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumns.AdjustAutoSize(CurrentIndex: TColumnIndex; Force: Boolean = False); + +// Called only if the header is in auto-size mode which means a column needs to be so large +// that it fills all the horizontal space not occupied by the other columns. +// CurrentIndex (if not InvalidColumn) describes which column has just been resized. + +var + NewValue, + AutoIndex, + Index, + RestWidth: Integer; + WasUpdating: Boolean; +begin + if Count > 0 then + begin + // Determine index to be used for auto resizing. This is usually given by the owner's AutoSizeIndex, but + // could be different if the column whose resize caused the invokation here is either the auto column itself + // or visually to the right of the auto size column. + AutoIndex := FHeader.AutoSizeIndex; + if (AutoIndex < 0) or (AutoIndex >= Count) then + AutoIndex := Count - 1; + + if AutoIndex >= 0 then + begin + with FHeader.Treeview do + begin + if HandleAllocated then + RestWidth := ClientWidth + else + RestWidth := Width; + end; + + // Go through all columns and calculate the rest space remaining. + for Index := 0 to Count - 1 do + if (Index <> AutoIndex) and (coVisible in Items[Index].Options) then + Dec(RestWidth, Items[Index].Width); + + with Items[AutoIndex] do + begin + NewValue := Max(MinWidth, Min(MaxWidth, RestWidth)); + if Force or (FWidth <> NewValue) then + begin + FWidth := NewValue; + UpdatePositions; + WasUpdating := csUpdating in FHeader.Treeview.ComponentState; + if not WasUpdating then + FHeader.Treeview.Updating();// Fixes #398 + try + FHeader.Treeview.DoColumnResize(AutoIndex); + finally + if not WasUpdating then + FHeader.Treeview.Updated(); + end; + end; + end; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVirtualTreeColumns.AdjustDownColumn(P: TPoint): TColumnIndex; + +// Determines the column from the given position and returns it. If this column is allowed to be clicked then +// it is also kept for later use. + +begin + // Convert to local coordinates. + Inc(P.Y, FHeader.Height); + Result := ColumnFromPosition(P); + if (Result > NoColumn) and (Result <> FDownIndex) and (coAllowClick in Items[Result].Options) and + (coEnabled in Items[Result].Options) then + begin + if FDownIndex > NoColumn then + FHeader.Invalidate(Items[FDownIndex]); + FDownIndex := Result; + FCheckBoxHit := Items[Result].HasImage and PtInRect(Items[Result].ImageRect, P) and Items[Result].CheckBox; + FHeader.Invalidate(Items[FDownIndex]); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVirtualTreeColumns.AdjustHoverColumn(P: TPoint): Boolean; + +// Determines the new hover column index and returns True if the index actually changed else False. + +begin + Result := GetNewIndex(P, FHoverIndex); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumns.AdjustPosition(Column: TVirtualTreeColumn; Position: Cardinal); + +// Reorders the column position array so that the given column gets the given position. + +var + OldPosition: Cardinal; + +begin + OldPosition := Column.Position; + if OldPosition <> Position then + begin + if OldPosition < Position then + begin + // column will be moved up so move down other entries + Move(FPositionToIndex[OldPosition + 1], FPositionToIndex[OldPosition], (Position - OldPosition) * SizeOf(Cardinal)); + end + else + begin + // column will be moved down so move up other entries + Move(FPositionToIndex[Position], FPositionToIndex[Position + 1], (OldPosition - Position) * SizeOf(Cardinal)); + end; + FPositionToIndex[Position] := Column.Index; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVirtualTreeColumns.CanSplitterResize(P: TPoint; Column: TColumnIndex): Boolean; + +begin + Result := (Column > NoColumn) and ([coResizable, coVisible] * Items[Column].Options = [coResizable, coVisible]); + DoCanSplitterResize(P, Column, Result); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumns.DoCanSplitterResize(P: TPoint; Column: TColumnIndex; var Allowed: Boolean); + +begin + if Assigned(FHeader.Treeview.FOnCanSplitterResizeColumn) then + FHeader.Treeview.FOnCanSplitterResizeColumn(FHeader, P, Column, Allowed); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumns.DrawButtonText(DC: HDC; Caption: string; Bounds: TRect; Enabled, Hot: Boolean; + DrawFormat: Cardinal; WrapCaption: Boolean); + +var + TextSpace: Integer; + Size: TSize; + +begin + if not WrapCaption then + begin + // Do we need to shorten the caption due to limited space? + GetTextExtentPoint32W(DC, PWideChar(Caption), Length(Caption), Size); + TextSpace := Bounds.Right - Bounds.Left; + if TextSpace < Size.cx then + Caption := ShortenString(DC, Caption, TextSpace); + end; + + SetBkMode(DC, TRANSPARENT); + if not Enabled then + if FHeader.Treeview.VclStyleEnabled then + begin + SetTextColor(DC, ColorToRGB(FHeader.Treeview.FColors.HeaderFontColor)); + Winapi.Windows.DrawTextW(DC, PWideChar(Caption), Length(Caption), Bounds, DrawFormat); + end + else + begin + OffsetRect(Bounds, 1, 1); + SetTextColor(DC, ColorToRGB(clBtnHighlight)); + Winapi.Windows.DrawTextW(DC, PWideChar(Caption), Length(Caption), Bounds, DrawFormat); + OffsetRect(Bounds, -1, -1); + SetTextColor(DC, ColorToRGB(clBtnShadow)); + Winapi.Windows.DrawTextW(DC, PWideChar(Caption), Length(Caption), Bounds, DrawFormat); + end + else + begin + if Hot then + SetTextColor(DC, ColorToRGB(FHeader.Treeview.FColors.HeaderHotColor)) + else + SetTextColor(DC, ColorToRGB(FHeader.Treeview.FColors.HeaderFontColor)); + Winapi.Windows.DrawTextW(DC, PWideChar(Caption), Length(Caption), Bounds, DrawFormat); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumns.FixPositions; + +// Fixes column positions after loading from DFM or Bidi mode change. + +var + I: Integer; + +begin + for I := 0 to Count - 1 do + FPositionToIndex[Items[I].Position] := I; + + FNeedPositionsFix := False; + UpdatePositions(True); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVirtualTreeColumns.GetColumnAndBounds(P: TPoint; var ColumnLeft, ColumnRight: Integer; + Relative: Boolean = True): Integer; + +// Returns the column where the mouse is currently in as well as the left and right bound of +// this column (Left and Right are undetermined if no column is involved). + +var + I: Integer; + +begin + Result := InvalidColumn; + if Relative and (P.X >= Header.Columns.GetVisibleFixedWidth) then + ColumnLeft := -FHeader.Treeview.FEffectiveOffsetX + else + ColumnLeft := 0; + + if FHeader.Treeview.UseRightToLeftAlignment then + Inc(ColumnLeft, FHeader.Treeview.ComputeRTLOffset(True)); + + for I := 0 to Count - 1 do + with Items[FPositionToIndex[I]] do + if coVisible in FOptions then + begin + ColumnRight := ColumnLeft + FWidth; + + //fix: in right to left alignment, X can be in the + //area on the left of first column which is OUT. + if (P.X < ColumnLeft) and (I = 0) then + begin + Result := InvalidColumn; + exit; + end; + if P.X < ColumnRight then + begin + Result := FPositionToIndex[I]; + Exit; + end; + ColumnLeft := ColumnRight; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVirtualTreeColumns.GetOwner: TPersistent; + +begin + Result := FHeader; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVirtualTreeColumns.HandleClick(P: TPoint; Button: TMouseButton; Force, DblClick: Boolean): Boolean; + +// Generates a click event if the mouse button has been released over the same column it was pressed first. +// Alternatively, Force might be set to True to indicate that the down index does not matter (right, middle and +// double click). +// Returns true if the click was handled, False otherwise. + +var + HitInfo: TVTHeaderHitInfo; + NewClickIndex: Integer; + Menu: TPopupMenu; +begin + Result := False; + if (csDesigning in Header.Treeview.ComponentState) then + exit; + // Convert vertical position to local coordinates. + Inc(P.Y, FHeader.Height); + NewClickIndex := ColumnFromPosition(P); + with HitInfo do + begin + X := P.X; + Y := P.Y; + Shift := FHeader.GetShiftState; + if DblClick then + Shift := Shift + [ssDouble]; + end; + HitInfo.Button := Button; + + if (NewClickIndex > NoColumn) and (coAllowClick in Items[NewClickIndex].Options) and + ((NewClickIndex = FDownIndex) or Force) then + begin + FClickIndex := NewClickIndex; + HitInfo.Column := NewClickIndex; + HitInfo.HitPosition := [hhiOnColumn]; + + if Items[NewClickIndex].HasImage and PtInRect(Items[NewClickIndex].ImageRect, P) then + begin + Include(HitInfo.HitPosition, hhiOnIcon); + if Items[NewClickIndex].CheckBox then + begin + if Button = mbLeft then + FHeader.Treeview.UpdateColumnCheckState(Items[NewClickIndex]); + Include(HitInfo.HitPosition, hhiOnCheckbox); + end; + end; + end + else + begin + FClickIndex := NoColumn; + HitInfo.Column := NoColumn; + HitInfo.HitPosition := [hhiNoWhere]; + end; + + if DblClick then + FHeader.Treeview.DoHeaderDblClick(HitInfo) + else begin + if (hoHeaderClickAutoSort in Header.Options) and (HitInfo.Button = mbLeft) and not (hhiOnCheckbox in HitInfo.HitPosition) and (HitInfo.Column >= 0) then + begin + // handle automatic setting of SortColumn and toggling of the sort order + if HitInfo.Column <> Header.SortColumn then + begin + // set sort column + Header.DoSetSortColumn(HitInfo.Column, Self[HitInfo.Column].DefaultSortDirection); + end//if + else + begin + // toggle sort direction + if Header.SortDirection = sdDescending then + Header.SortDirection := sdAscending + else + Header.SortDirection := sdDescending; + end;//else + Result := True; + end;//if + + if (Button = mbRight) then + begin + Dec(P.Y, FHeader.Height); // popup menus at actual clicked point + FreeAndNil(fColumnPopupMenu);// Attention: Do not free the TVTHeaderPopupMenu at the end of this method, otherwise the clikc events of the menu item will not be fired. + Self.FDownIndex := NoColumn; + Self.FTrackIndex := NoColumn; + Self.FCheckBoxHit := False; + Menu := Header.DoGetPopupMenu(Self.ColumnFromPosition(Point(P.X, P.Y + Integer(Header.Treeview.Height))), P); + if Assigned(Menu) then + begin + Header.Treeview.StopTimer(ScrollTimer); + Header.Treeview.StopTimer(HeaderTimer); + Header.Columns.SetHoverIndex(NoColumn); + Header.Treeview.DoStateChange([], [tsScrollPending, tsScrolling]); + + Menu.PopupComponent := Header.Treeview; + With Header.Treeview.ClientToScreen(P) do + Menu.Popup(X, Y); + Result := True; + end + else if (hoAutoColumnPopupMenu in Header.Options) then + begin + fColumnPopupMenu := TVTHeaderPopupMenu.Create(Header.TreeView); + TVTHeaderPopupMenu(fColumnPopupMenu).OnAddHeaderPopupItem := HeaderPopupMenuAddHeaderPopupItem; + TVTHeaderPopupMenu(fColumnPopupMenu).OnColumnChange := HeaderPopupMenuColumnChange; + fColumnPopupMenu.PopupComponent := Header.Treeview; + if (hoDblClickResize in Header.Options) and ((Header.Treeview.ChildCount[nil] > 0) or (hoAutoResizeInclCaption in Header.Options)) then + TVTHeaderPopupMenu(fColumnPopupMenu).Options := TVTHeaderPopupMenu(fColumnPopupMenu).Options + [poResizeToFitItem] + else + TVTHeaderPopupMenu(fColumnPopupMenu).Options := TVTHeaderPopupMenu(fColumnPopupMenu).Options - [poResizeToFitItem]; + With Header.Treeview.ClientToScreen(P) do + fColumnPopupMenu.Popup(X, Y); + Result := True; + end; // if hoAutoColumnPopupMenu + end;//if mbRight + FHeader.Treeview.DoHeaderClick(HitInfo); + end;//else (not DblClick) + + if not (hhiNoWhere in HitInfo.HitPosition) then + FHeader.Invalidate(Items[NewClickIndex]); + if (FClickIndex > NoColumn) and (FClickIndex <> NewClickIndex) then + FHeader.Invalidate(Items[FClickIndex]); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumns.HeaderPopupMenuAddHeaderPopupItem(const Sender: TBaseVirtualTree; const Column: TColumnIndex; + var Cmd: TAddPopupItemType); +begin + Sender.DoHeaderAddPopupItem(Column, Cmd); +end; + +//---------------------------------------------------------------------------------------------------------------------- + + +procedure TVirtualTreeColumns.HeaderPopupMenuColumnChange(const Sender: TBaseVirtualTree; const Column: TColumnIndex; Visible: Boolean); +begin + Sender.DoColumnVisibilityChanged(Column, Visible); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumns.IndexChanged(OldIndex, NewIndex: Integer); + +// Called by a column when its index in the collection changes. If NewIndex is -1 then the column is +// about to be removed, otherwise it is moved to a new index. +// The method will then update the position array to reflect the change. + +var + I: Integer; + Increment: Integer; + Lower, + Upper: Integer; + +begin + if NewIndex = -1 then + begin + // Find position in the array with the old index. + Upper := High(FPositionToIndex); + for I := 0 to Upper do + begin + if FPositionToIndex[I] = OldIndex then + begin + // Index found. Move all higher entries one step down and remove the last entry. + if I < Upper then + Move(FPositionToIndex[I + 1], FPositionToIndex[I], (Upper - I) * SizeOf(TColumnIndex)); + end; + // Decrease all indices, which are greater than the index to be deleted. + if FPositionToIndex[I] > OldIndex then + Dec(FPositionToIndex[I]); + end; + SetLength(FPositionToIndex, High(FPositionToIndex)); + end + else + begin + if OldIndex < NewIndex then + Increment := -1 + else + Increment := 1; + + Lower := Min(OldIndex, NewIndex); + Upper := Max(OldIndex, NewIndex); + for I := 0 to High(FPositionToIndex) do + begin + if (FPositionToIndex[I] >= Lower) and (FPositionToIndex[I] < Upper) then + Inc(FPositionToIndex[I], Increment) + else + if FPositionToIndex[I] = OldIndex then + FPositionToIndex[I] := NewIndex; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumns.InitializePositionArray; + +// Ensures that the column position array contains as many entries as columns are defined. +// The array is resized and initialized with default values if needed. + +var + I, OldSize: Integer; + Changed: Boolean; + +begin + if Count <> Length(FPositionToIndex) then + begin + OldSize := Length(FPositionToIndex); + SetLength(FPositionToIndex, Count); + if Count > OldSize then + begin + // New items have been added, just set their position to the same as their index. + for I := OldSize to Count - 1 do + FPositionToIndex[I] := I; + end + else + begin + // Items have been deleted, so reindex remaining entries by decrementing values larger than the highest + // possible index until no entry is higher than this limit. + repeat + Changed := False; + for I := 0 to Count - 1 do + if FPositionToIndex[I] >= Count then + begin + Dec(FPositionToIndex[I]); + Changed := True; + end; + until not Changed; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumns.Notify(Item: TCollectionItem; Action: System.Classes.TCollectionNotification); +var + I: Integer; +begin + if Action in [cnDeleting] then + begin + // Adjust all positions larger than the deleted column's position. Fixes #959, #1049 + for I := 0 to Count - 1 do begin + if Items[I].Position > TVirtualTreeColumn(Item).Position then + Items[I].Position := Items[I].Position - 1; + end;//for I + + with Header.Treeview do + if not (csLoading in ComponentState) and (FFocusedColumn = Item.Index) then + FFocusedColumn := NoColumn; + end;// if cnDeleting +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumns.ReorderColumns(RTL: Boolean); + +var + I: Integer; + +begin + if RTL then + begin + for I := 0 to Count - 1 do + FPositionToIndex[I] := Count - I - 1; + end + else + begin + for I := 0 to Count - 1 do + FPositionToIndex[I] := I; + end; + + UpdatePositions(True); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumns.SetHoverIndex(index : TColumnIndex); +begin + FHoverIndex := index; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumns.EndUpdate; +begin + InitializePositionArray(); + FixPositions(); // Accept the cuurent order. See issue #753 + inherited; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumns.Update(Item: TCollectionItem); + +begin + // This is the only place which gets notified when a new column has been added or removed + // and we need this event to adjust the column position array. + InitializePositionArray; + if csLoading in Header.Treeview.ComponentState then + FNeedPositionsFix := True + else + UpdatePositions; + + // The first column which is created is by definition also the main column. + if (Count > 0) and (Header.FMainColumn < 0) then + FHeader.MainColumn := 0; + + if not (csLoading in FHeader.Treeview.ComponentState) and not (hsLoading in FHeader.States) then + begin + with FHeader do + begin + if hoAutoResize in FOptions then + AdjustAutoSize(InvalidColumn); + if Assigned(Item) then + Invalidate(Item as TVirtualTreeColumn) + else + if Treeview.HandleAllocated then + begin + Treeview.UpdateHorizontalScrollBar(False); + Invalidate(nil); + Treeview.Invalidate; + end; + + if not (Treeview.IsUpdating) then + // This is mainly to let the designer know when a change occurs at design time which + // doesn't involve the object inspector (like column resizing with the mouse). + // This does NOT include design time code as the communication is done via an interface. + Treeview.UpdateDesigner; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumns.UpdatePositions(Force: Boolean = False); + +// Recalculates the left border of every column and updates their position property according to the +// PostionToIndex array which primarily determines where each column is placed visually. + +var + I, RunningPos: Integer; + +begin + if not (csDestroying in FHeader.Treeview.ComponentState) and not FNeedPositionsFix and (Force or (UpdateCount = 0)) then + begin + RunningPos := 0; + for I := 0 to High(FPositionToIndex) do + with Items[FPositionToIndex[I]] do + begin + FPosition := I; + FLeft := RunningPos; + if coVisible in FOptions then + Inc(RunningPos, FWidth); + end; + FHeader.Treeview.UpdateHorizontalScrollBar(False); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVirtualTreeColumns.Add: TVirtualTreeColumn; + +begin + Assert(GetCurrentThreadId = MainThreadId, 'UI controls may only be changed in UI thread.'); + Result := TVirtualTreeColumn(inherited Add); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumns.AnimatedResize(Column: TColumnIndex; NewWidth: Integer); + +// Resizes the given column animated by scrolling the window DC. + +var + OldWidth: Integer; + DC: HDC; + I, + Steps, + DX: Integer; + HeaderScrollRect, + ScrollRect, + R: TRect; + + NewBrush, + LastBrush: HBRUSH; + +begin + if not IsValidColumn(Column) then + Exit; // Just in case. + + // Make sure the width constrains are considered. + if NewWidth < Items[Column].MinWidth then + NewWidth := Items[Column].MinWidth; + if NewWidth > Items[Column].MaxWidth then + NewWidth := Items[Column].MaxWidth; + + OldWidth := Items[Column].Width; + // Nothing to do if the width is the same. + if OldWidth <> NewWidth then + begin + if not ( (hoDisableAnimatedResize in FHeader.Options) or + (coDisableAnimatedResize in Items[Column].Options) ) then + begin + DC := GetWindowDC(FHeader.Treeview.Handle); + with FHeader.Treeview do + try + Steps := 32; + DX := (NewWidth - OldWidth) div Steps; + + // Determination of the scroll rectangle is a bit complicated since we neither want + // to scroll the scrollbars nor the border of the treeview window. + HeaderScrollRect := FHeaderRect; + ScrollRect := HeaderScrollRect; + // Exclude the header itself from scrolling. + ScrollRect.Top := ScrollRect.Bottom; + ScrollRect.Bottom := ScrollRect.Top + ClientHeight; + ScrollRect.Right := ScrollRect.Left + ClientWidth; + with Items[Column] do + Inc(ScrollRect.Left, FLeft + FWidth); + HeaderScrollRect.Left := ScrollRect.Left; + HeaderScrollRect.Right := ScrollRect.Right; + + // When the new width is larger then avoid artefacts on the left hand side + // by deleting a small stripe + if NewWidth > OldWidth then + begin + R := ScrollRect; + NewBrush := CreateSolidBrush(ColorToRGB(Color)); + LastBrush := SelectObject(DC, NewBrush); + R.Right := R.Left + DX; + FillRect(DC, R, NewBrush); + SelectObject(DC, LastBrush); + DeleteObject(NewBrush); + end + else + begin + Inc(HeaderScrollRect.Left, DX); + Inc(ScrollRect.Left, DX); + end; + + for I := 0 to Steps - 1 do + begin + ScrollDC(DC, DX, 0, HeaderScrollRect, HeaderScrollRect, 0, nil); + Inc(HeaderScrollRect.Left, DX); + ScrollDC(DC, DX, 0, ScrollRect, ScrollRect, 0, nil); + Inc(ScrollRect.Left, DX); + Sleep(1); + end; + finally + ReleaseDC(Handle, DC); + end; + end; + Items[Column].Width := NewWidth; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumns.Assign(Source: TPersistent); + +begin + // Let the collection class assign the items. + inherited; + + if Source is TVirtualTreeColumns then + begin + // Copying the position array is the only needed task here. + FPositionToIndex := Copy(TVirtualTreeColumns(Source).FPositionToIndex, 0, MaxInt); + + // Make sure the left edges are correct after assignment. + FNeedPositionsFix := False; + UpdatePositions(True); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumns.Clear; + +begin + FClearing := True; + try + Header.Treeview.CancelEditNode; + + // Since we're freeing all columns, the following have to be true when we're done. + FHoverIndex := NoColumn; + FDownIndex := NoColumn; + FTrackIndex := NoColumn; + FClickIndex := NoColumn; + FCheckBoxHit := False; + + with Header do + if not (hsLoading in FStates) then + begin + FAutoSizeIndex := NoColumn; + FMainColumn := NoColumn; + FSortColumn := NoColumn; + end; + + with Header.Treeview do + if not (csLoading in ComponentState) then + FFocusedColumn := NoColumn; + + inherited Clear; + finally + FClearing := False; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVirtualTreeColumns.ColumnFromPosition(P: TPoint; Relative: Boolean = True): TColumnIndex; + +// Determines the current column based on the position passed in P. + +var + I, Sum: Integer; + +begin + Result := InvalidColumn; + + // The position must be within the header area, but we extend the vertical bounds to the entire treeview area. + if (P.X >= 0) and (P.Y >= 0) and (P.Y <= FHeader.TreeView.Height) then + with FHeader, Treeview do + begin + if Relative and (P.X >= GetVisibleFixedWidth) then + Sum := -FEffectiveOffsetX + else + Sum := 0; + + if UseRightToLeftAlignment then + Inc(Sum, ComputeRTLOffset(True)); + + for I := 0 to Count - 1 do + if coVisible in Items[FPositionToIndex[I]].Options then + begin + Inc(Sum, Items[FPositionToIndex[I]].Width); + if P.X < Sum then + begin + Result := FPositionToIndex[I]; + Break; + end; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVirtualTreeColumns.ColumnFromPosition(PositionIndex: TColumnPosition): TColumnIndex; + +// Returns the index of the column at the given position. + +begin + if Integer(PositionIndex) < Length(FPositionToIndex) then + Result := FPositionToIndex[PositionIndex] + else + Result := NoColumn; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVirtualTreeColumns.Equals(OtherColumnsObj: TObject): Boolean; + +// Compares itself with the given set of columns and returns True if all published properties are the same +// (including column order), otherwise False is returned. + +var + I: Integer; + OtherColumns : TVirtualTreeColumns; + +begin + if not (OtherColumnsObj is TVirtualTreeColumns) then + begin + Result := False; + Exit; + end; + + OtherColumns := TVirtualTreeColumns (OtherColumnsObj); + + // Same number of columns? + Result := OtherColumns.Count = Count; + if Result then + begin + // Same order of columns? + Result := CompareMem(Pointer(FPositionToIndex), Pointer(OtherColumns.FPositionToIndex), + Length(FPositionToIndex) * SizeOf(TColumnIndex)); + if Result then + begin + for I := 0 to Count - 1 do + if not Items[I].Equals(OtherColumns[I]) then + begin + Result := False; + Break; + end; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumns.GetColumnBounds(Column: TColumnIndex; var Left, Right: Integer); + +// Returns the left and right bound of the given column. If Column is NoColumn then the entire client width is returned. + +begin + if Column <= NoColumn then + begin + Left := 0; + Right := FHeader.Treeview.ClientWidth; + end + else + begin + Left := Items[Column].Left; + Right := Left + Items[Column].Width; + if FHeader.Treeview.UseRightToLeftAlignment then + begin + Inc(Left, FHeader.Treeview.ComputeRTLOffset(True)); + Inc(Right, FHeader.Treeview.ComputeRTLOffset(True)); + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVirtualTreeColumns.GetScrollWidth: Integer; + +// Returns the average width of all visible, non-fixed columns. If there is no such column the indent is returned. + +var + I: Integer; + ScrollColumnCount: Integer; + +begin + + Result := 0; + + ScrollColumnCount := 0; + for I := 0 to FHeader.Columns.Count - 1 do + begin + if ([coVisible, coFixed] * FHeader.Columns[I].Options = [coVisible]) then + begin + Inc(Result, FHeader.Columns[I].Width); + Inc(ScrollColumnCount); + end; + end; + + if ScrollColumnCount > 0 then // use average width + Result := Round(Result / ScrollColumnCount) + else // use indent + Result := Integer(FHeader.Treeview.FIndent); + +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVirtualTreeColumns.GetFirstVisibleColumn(ConsiderAllowFocus: Boolean = False): TColumnIndex; + +// Returns the index of the first visible column or "InvalidColumn" if either no columns are defined or +// all columns are hidden. +// If ConsiderAllowFocus is True then the column has not only to be visible but also focus has to be allowed. + +var + I: Integer; + +begin + Result := InvalidColumn; + if (UpdateCount > 0) or (csLoading in Header.TreeView.ComponentState) then + exit; // See issue #760 + for I := 0 to Count - 1 do + if (coVisible in Items[FPositionToIndex[I]].Options) and + ( (not ConsiderAllowFocus) or + (coAllowFocus in Items[FPositionToIndex[I]].Options) + ) then + begin + Result := FPositionToIndex[I]; + Break; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVirtualTreeColumns.GetLastVisibleColumn(ConsiderAllowFocus: Boolean = False): TColumnIndex; + +// Returns the index of the last visible column or "InvalidColumn" if either no columns are defined or +// all columns are hidden. +// If ConsiderAllowFocus is True then the column has not only to be visible but also focus has to be allowed. + +var + I: Integer; + +begin + Result := InvalidColumn; + if (UpdateCount > 0) or (csLoading in Header.TreeView.ComponentState) then + exit; // See issue #760 + for I := Count - 1 downto 0 do + if (coVisible in Items[FPositionToIndex[I]].Options) and + ( (not ConsiderAllowFocus) or + (coAllowFocus in Items[FPositionToIndex[I]].Options) + ) then + begin + Result := FPositionToIndex[I]; + Break; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVirtualTreeColumns.GetFirstColumn: TColumnIndex; + +// Returns the first column in display order. + +begin + if Count = 0 then + Result := InvalidColumn + else + Result := FPositionToIndex[0]; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVirtualTreeColumns.GetNextColumn(Column: TColumnIndex): TColumnIndex; + +// Returns the next column in display order. Column is the index of an item in the collection (a column). + +var + Position: Integer; + +begin + if Column < 0 then + Result := InvalidColumn + else + begin + Position := Items[Column].Position; + if Position < Count - 1 then + Result := FPositionToIndex[Position + 1] + else + Result := InvalidColumn; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVirtualTreeColumns.GetNextVisibleColumn(Column: TColumnIndex; ConsiderAllowFocus: Boolean = False): TColumnIndex; + +// Returns the next visible column in display order, Column is an index into the columns list. +// If ConsiderAllowFocus is True then the column has not only to be visible but also focus has to be allowed. + +begin + Result := Column; + repeat + Result := GetNextColumn(Result); + until (Result = InvalidColumn) or + ( (coVisible in Items[Result].Options) and + ( (not ConsiderAllowFocus) or + (coAllowFocus in Items[Result].Options) + ) + ); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVirtualTreeColumns.GetPreviousColumn(Column: TColumnIndex): TColumnIndex; + +// Returns the previous column in display order, Column is an index into the columns list. + +var + Position: Integer; + +begin + if Column < 0 then + Result := InvalidColumn + else + begin + Position := Items[Column].Position; + if Position > 0 then + Result := FPositionToIndex[Position - 1] + else + Result := InvalidColumn; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVirtualTreeColumns.GetPreviousVisibleColumn(Column: TColumnIndex; ConsiderAllowFocus: Boolean = False): TColumnIndex; + +// Returns the previous visible column in display order, Column is an index into the columns list. +// If ConsiderAllowFocus is True then the column has not only to be visible but also focus has to be allowed. + +begin + Result := Column; + repeat + Result := GetPreviousColumn(Result); + until (Result = InvalidColumn) or + ( (coVisible in Items[Result].Options) and + ( (not ConsiderAllowFocus) or + (coAllowFocus in Items[Result].Options) + ) + ); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVirtualTreeColumns.GetVisibleColumns: TColumnsArray; + +// Returns a list of all currently visible columns in actual order. + +var + I, Counter: Integer; + +begin + SetLength(Result, Count); + Counter := 0; + + for I := 0 to Count - 1 do + if coVisible in Items[FPositionToIndex[I]].Options then + begin + Result[Counter] := Items[FPositionToIndex[I]]; + Inc(Counter); + end; + // Set result length to actual visible count. + SetLength(Result, Counter); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVirtualTreeColumns.GetVisibleFixedWidth: Integer; + +// Determines the horizontal space all visible and fixed columns occupy. + +var + I: Integer; + +begin + Result := 0; + for I := 0 to Count - 1 do + begin + if Items[I].Options * [coVisible, coFixed] = [coVisible, coFixed] then + Inc(Result, Items[I].Width); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVirtualTreeColumns.IsValidColumn(Column: TColumnIndex): Boolean; + +// Determines whether the given column is valid or not, that is, whether it is one of the current columns. + +begin + Result := (Column > NoColumn) and (Column < Count); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumns.LoadFromStream(const Stream: TStream; Version: Integer); + +var + I, + ItemCount: Integer; + +begin + Clear; + Stream.ReadBuffer(ItemCount, SizeOf(ItemCount)); + // number of columns + if ItemCount > 0 then + begin + BeginUpdate; + try + for I := 0 to ItemCount - 1 do + Add.LoadFromStream(Stream, Version); + SetLength(FPositionToIndex, ItemCount); + Stream.ReadBuffer(FPositionToIndex[0], ItemCount * SizeOf(TColumnIndex)); + UpdatePositions(True); + finally + EndUpdate; + end; + end; + + // Data introduced with header stream version 5 + if Version > 4 then + Stream.ReadBuffer(FDefaultWidth, SizeOf(FDefaultWidth)); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumns.PaintHeader(DC: HDC; R: TRect; HOffset: Integer); + +// Backward compatible header paint method. This method takes care of visually moving floating columns + +var + VisibleFixedWidth: Integer; + RTLOffset: Integer; + + procedure PaintFixedArea; + + begin + if VisibleFixedWidth > 0 then + PaintHeader(FHeaderBitmap.Canvas, + Rect(0, 0, Min(R.Right, VisibleFixedWidth), R.Bottom - R.Top), + Point(R.Left, R.Top), RTLOffset); + end; + +begin + // Adjust size of the header bitmap + with TWithSafeRect(FHeader.Treeview.FHeaderRect) do + begin + FHeaderBitmap.SetSize(Max(Right, R.Right - R.Left), Bottom); + end; + + VisibleFixedWidth := GetVisibleFixedWidth; + + // Consider right-to-left directionality. + if FHeader.TreeView.UseRightToLeftAlignment then + RTLOffset := FHeader.Treeview.ComputeRTLOffset + else + RTLOffset := 0; + + if RTLOffset = 0 then + PaintFixedArea; + + // Paint the floating part of the header. + PaintHeader(FHeaderBitmap.Canvas, + Rect(VisibleFixedWidth - HOffset, 0, R.Right + VisibleFixedWidth - HOffset, R.Bottom - R.Top), + Point(R.Left + VisibleFixedWidth, R.Top), RTLOffset); + + // In case of right-to-left directionality we paint the fixed part last. + if RTLOffset <> 0 then + PaintFixedArea; + + // Blit the result to target. + with TWithSafeRect(R) do + BitBlt(DC, Left, Top, Right - Left, Bottom - Top, FHeaderBitmap.Canvas.Handle, Left, Top, SRCCOPY); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumns.PaintHeader(TargetCanvas: TCanvas; R: TRect; const Target: TPoint; + RTLOffset: Integer = 0); + +// Main paint method to draw the header. +// This procedure will paint the a slice (given in R) out of HeaderRect into TargetCanvas starting at position Target. +// This function does not offer the option to visually move floating columns due to scrolling. To accomplish this you +// need to call this method twice. + +var + Run: TColumnIndex; + RightBorderFlag, + NormalButtonStyle, + NormalButtonFlags, + PressedButtonStyle, + PressedButtonFlags, + RaisedButtonStyle, + RaisedButtonFlags: Cardinal; + Images: TCustomImageList; + OwnerDraw, + AdvancedOwnerDraw: Boolean; + PaintInfo: THeaderPaintInfo; + RequestedElements, + ActualElements: THeaderPaintElements; + + //--------------- local functions ------------------------------------------- + + procedure PrepareButtonStyles; + + // Prepare the button styles and flags for later usage. + + begin + RaisedButtonStyle := 0; + RaisedButtonFlags := 0; + case FHeader.Style of + hsThickButtons: + begin + NormalButtonStyle := BDR_RAISEDINNER or BDR_RAISEDOUTER; + NormalButtonFlags := BF_LEFT or BF_TOP or BF_BOTTOM or BF_MIDDLE or BF_SOFT or BF_ADJUST; + PressedButtonStyle := BDR_RAISEDINNER or BDR_RAISEDOUTER; + PressedButtonFlags := NormalButtonFlags or BF_RIGHT or BF_FLAT or BF_ADJUST; + end; + hsFlatButtons: + begin + NormalButtonStyle := BDR_RAISEDINNER; + NormalButtonFlags := BF_LEFT or BF_TOP or BF_BOTTOM or BF_MIDDLE or BF_ADJUST; + PressedButtonStyle := BDR_SUNKENOUTER; + PressedButtonFlags := BF_RECT or BF_MIDDLE or BF_ADJUST; + end; + else + // hsPlates or hsXPStyle, values are not used in the latter case + begin + NormalButtonStyle := BDR_RAISEDINNER; + NormalButtonFlags := BF_RECT or BF_MIDDLE or BF_SOFT or BF_ADJUST; + PressedButtonStyle := BDR_SUNKENOUTER; + PressedButtonFlags := BF_RECT or BF_MIDDLE or BF_ADJUST; + RaisedButtonStyle := BDR_RAISEDINNER; + RaisedButtonFlags := BF_LEFT or BF_TOP or BF_BOTTOM or BF_MIDDLE or BF_ADJUST; + end; + end; + end; + + //--------------------------------------------------------------------------- + + procedure DrawBackground; + + // Draw the header background. + + var + BackgroundRect: TRect; + Details: TThemedElementDetails; + Theme: HTheme; + begin + BackgroundRect := Rect(Target.X, Target.Y, Target.X + R.Right - R.Left, Target.Y + FHeader.Height); + + with TargetCanvas do + begin + if hpeBackground in RequestedElements then + begin + PaintInfo.PaintRectangle := BackgroundRect; + FHeader.Treeview.DoAdvancedHeaderDraw(PaintInfo, [hpeBackground]); + end + else + begin + if (FHeader.Treeview.VclStyleEnabled and (seClient in FHeader.Treeview.StyleElements)) then + begin + Details := StyleServices.GetElementDetails(thHeaderItemRightNormal); + StyleServices.DrawElement(Handle, Details, BackgroundRect, @BackgroundRect {$IF CompilerVersion >= 34}, FHeader.Treeview.FCurrentPPI{$IFEND}); + end + else + if tsUseThemes in FHeader.Treeview.FStates then + begin + Theme := OpenThemeData(FHeader.Treeview.Handle, 'HEADER'); + DrawThemeBackground(Theme, Handle, HP_HEADERITEM, HIS_NORMAL, BackgroundRect, nil); + CloseThemeData(THeme); + end + else + begin + Brush.Color := FHeader.Background; + FillRect(BackgroundRect); + end; + end; + end; + end; + + //--------------------------------------------------------------------------- + + procedure PaintColumnHeader(AColumn: TColumnIndex; ATargetRect: TRect); + + // Draw a single column to TargetRect. The clipping rect needs to be set before + // this procedure is called. + + var + SavedDC: Integer; + ColCaptionText: string; + ColImageInfo: TVTImageInfo; + Glyph: TThemedHeader; + Details: TThemedElementDetails; + WrapCaption: Boolean; + DrawFormat: Cardinal; + Pos: TRect; + DrawHot: Boolean; + ImageWidth: Integer; + Theme: HTheme; + IdState: Integer; + begin + ColImageInfo.Ghosted := False; + PaintInfo.Column := Items[AColumn]; + with PaintInfo, Column do + begin + IsHoverIndex := (AColumn = FHoverIndex) and (hoHotTrack in FHeader.Options) and (coEnabled in FOptions); + IsDownIndex := (AColumn = FDownIndex) and not FCheckBoxHit; + + if (coShowDropMark in FOptions) and (AColumn = FDropTarget) and (AColumn <> FDragIndex) then + begin + if FDropBefore then + DropMark := dmmLeft + else + DropMark := dmmRight; + end + else + DropMark := dmmNone; + + //Fix for issue 643 + //Do not show the left drop mark if the position to drop is just preceding the target which means + //the dragged column will stay where it is + if (DropMark = dmmLeft) and (Items[FDragIndex].Position = TColumnPosition(Max(Integer(Items[FDropTarget].Position) - 1, 0))) + then + DropMark := dmmNone + else + //Do not show the right drop mark if the position to drop is just following the target which means + //the dragged column will stay where it is + if (DropMark = dmmRight) and (Items[FDragIndex].Position = Items[FDropTarget].Position + 1) + then + DropMark := dmmNone; + + IsEnabled := (coEnabled in FOptions) and (FHeader.Treeview.Enabled); + ShowHeaderGlyph := (hoShowImages in FHeader.Options) and ((Assigned(Images) and (FImageIndex > -1)) or FCheckBox); + ShowSortGlyph := (AColumn = FHeader.SortColumn) and (hoShowSortGlyphs in FHeader.Options); + WrapCaption := coWrapCaption in FOptions; + + PaintRectangle := ATargetRect; + + // This path for text columns or advanced owner draw. + if (Style = vsText) or not OwnerDraw or AdvancedOwnerDraw then + begin + // See if the application wants to draw part of the header itself. + RequestedElements := []; + if AdvancedOwnerDraw then + begin + PaintInfo.Column := Items[AColumn]; + FHeader.Treeview.DoHeaderDrawQueryElements(PaintInfo, RequestedElements); + end; + + if ShowRightBorder or (AColumn < Count - 1) then + RightBorderFlag := BF_RIGHT + else + RightBorderFlag := 0; + + if hpeBackground in RequestedElements then + FHeader.Treeview.DoAdvancedHeaderDraw(PaintInfo, [hpeBackground]) + else + begin + if FHeader.Treeview.VclStyleEnabled and (seClient in FHeader.Treeview.StyleElements) then + begin + if IsDownIndex then + Details := StyleServices.GetElementDetails(thHeaderItemPressed) + else + if IsHoverIndex then + Details := StyleServices.GetElementDetails(thHeaderItemHot) + else + Details := StyleServices.GetElementDetails(thHeaderItemNormal); + StyleServices.DrawElement(TargetCanvas.Handle, Details, PaintRectangle, @PaintRectangle{$IF CompilerVersion >= 34}, FHeader.TreeView.FCurrentPPI{$IFEND}); + end + else + begin + if tsUseThemes in FHeader.Treeview.FStates then + begin + Theme := OpenThemeData(FHeader.Treeview.Handle, 'HEADER'); + if IsDownIndex then + IdState := HIS_PRESSED + else + if IsHoverIndex then + IdState := HIS_HOT + else + IdState := HIS_NORMAL; + DrawThemeBackground(Theme, TargetCanvas.Handle, HP_HEADERITEM, IdState, PaintRectangle, nil); + CloseThemeData(Theme); + end + else + if IsDownIndex then + DrawEdge(TargetCanvas.Handle, PaintRectangle, PressedButtonStyle, PressedButtonFlags) + else + // Plates have the special case of raising on mouse over. + if (FHeader.Style = hsPlates) and IsHoverIndex and + (coAllowClick in FOptions) and (coEnabled in FOptions) then + DrawEdge(TargetCanvas.Handle, PaintRectangle, RaisedButtonStyle, + RaisedButtonFlags or RightBorderFlag) + else + DrawEdge(TargetCanvas.Handle, PaintRectangle, NormalButtonStyle, + NormalButtonFlags or RightBorderFlag); + end; + end; + + PaintRectangle := ATargetRect; + + // calculate text and glyph position + InflateRect(PaintRectangle, -2, -2); + DrawFormat := DT_TOP or DT_NOPREFIX; + case CaptionAlignment of + taLeftJustify : DrawFormat := DrawFormat or DT_LEFT; + taRightJustify : DrawFormat := DrawFormat or DT_RIGHT; + taCenter : DrawFormat := DrawFormat or DT_CENTER; + end; + if UseRightToLeftReading then + DrawFormat := DrawFormat + DT_RTLREADING; + ComputeHeaderLayout(PaintInfo, DrawFormat); + + // Move glyph and text one pixel to the right and down to simulate a pressed button. + if IsDownIndex then + begin + OffsetRect(TextRectangle, 1, 1); + Inc(GlyphPos.X); + Inc(GlyphPos.Y); + Inc(SortGlyphPos.X); + Inc(SortGlyphPos.Y); + end; + + // Advanced owner draw allows to paint elements, which would normally not be painted (because of space + // limitations, empty captions etc.). + ActualElements := RequestedElements * [hpeHeaderGlyph, hpeSortGlyph, hpeDropMark, hpeText, hpeOverlay]; + + // main glyph + FHasImage := False; + if Assigned(Images) then + ImageWidth := Images.Width + else + ImageWidth := 0; + + if not (hpeHeaderGlyph in ActualElements) and ShowHeaderGlyph and + (not ShowSortGlyph or (FBiDiMode <> bdLeftToRight) or (GlyphPos.X + ImageWidth <= SortGlyphPos.X) ) then + begin + if not FCheckBox then + begin + ColImageInfo.Images := Images; + Images.Draw(TargetCanvas, GlyphPos.X, GlyphPos.Y, FImageIndex, IsEnabled); + end + else + begin + with Header.Treeview do + begin + ColImageInfo.Images := FCheckImages; + ColImageInfo.Index := GetCheckImage(nil, FCheckType, FCheckState, IsEnabled); + ColImageInfo.XPos := GlyphPos.X; + ColImageInfo.YPos := GlyphPos.Y; + PaintCheckImage(TargetCanvas, ColImageInfo, False); + end; + end; + + FHasImage := True; + with TWithSafeRect(FImageRect) do + begin + Left := GlyphPos.X; + Top := GlyphPos.Y; + Right := Left + ColImageInfo.Images.Width; + Bottom := Top + ColImageInfo.Images.Height; + end; + end; + + // caption + if WrapCaption then + ColCaptionText := FCaptionText + else + ColCaptionText := Text; + if IsHoverIndex and FHeader.Treeview.VclStyleEnabled then + DrawHot := True + else + DrawHot := (IsHoverIndex and (hoHotTrack in FHeader.Options) and not(tsUseThemes in FHeader.Treeview.FStates)); + if not(hpeText in ActualElements) and (Length(Text) > 0) then + DrawButtonText(TargetCanvas.Handle, ColCaptionText, TextRectangle, IsEnabled, DrawHot, DrawFormat, WrapCaption); + + // sort glyph + if not (hpeSortGlyph in ActualElements) and ShowSortGlyph then + begin + if tsUseExplorerTheme in FHeader.Treeview.FStates then + begin + Pos.TopLeft := SortGlyphPos; + Pos.Right := Pos.Left + SortGlyphSize.cx; + Pos.Bottom := Pos.Top + SortGlyphSize.cy; + if FHeader.SortDirection = sdAscending then + Glyph := thHeaderSortArrowSortedUp + else + Glyph := thHeaderSortArrowSortedDown; + Details := StyleServices.GetElementDetails(Glyph); + if not StyleServices.DrawElement(TargetCanvas.Handle, Details, Pos, @Pos {$IF CompilerVersion >= 34}, FHeader.TreeView.FCurrentPPI {$IFEND}) then + PaintInfo.DrawSortArrow(FHeader.SortDirection); + end + else + begin + PaintInfo.DrawSortArrow(FHeader.SortDirection); + end; + end; + + // Show an indication if this column is the current drop target in a header drag operation. + if not (hpeDropMark in ActualElements) and (DropMark <> dmmNone) then + begin + PaintInfo.DrawDropMark(); + end; + + if ActualElements <> [] then + begin + SavedDC := SaveDC(TargetCanvas.Handle); + FHeader.Treeview.DoAdvancedHeaderDraw(PaintInfo, ActualElements); + RestoreDC(TargetCanvas.Handle, SavedDC); + end; + end + else // Let application draw the header. + FHeader.Treeview.DoHeaderDraw(TargetCanvas, Items[AColumn], PaintRectangle, IsHoverIndex, IsDownIndex, + DropMark); + end; + end; + + //--------------- end local functions --------------------------------------- + +var + TargetRect: TRect; + MaxX: Integer; + +begin + if IsRectEmpty(R) then + Exit; + + // If both draw posibillities are specified then prefer the advanced way. + AdvancedOwnerDraw := (hoOwnerDraw in FHeader.Options) and Assigned(FHeader.Treeview.OnAdvancedHeaderDraw) and + Assigned(FHeader.Treeview.FOnHeaderDrawQueryElements) and not (csDesigning in FHeader.Treeview.ComponentState); + OwnerDraw := (hoOwnerDraw in FHeader.Options) and Assigned(FHeader.Treeview.OnHeaderDraw) and + not (csDesigning in FHeader.Treeview.ComponentState) and not AdvancedOwnerDraw; + + ZeroMemory(@PaintInfo, SizeOf(PaintInfo)); + PaintInfo.TargetCanvas := TargetCanvas; + + with PaintInfo, TargetCanvas do + begin + // Use shortcuts for the images and the font. + Images := FHeader.Images; + Font := FHeader.Font; + + PrepareButtonStyles; + + // At first, query the application which parts of the header it wants to draw on its own. + RequestedElements := []; + if AdvancedOwnerDraw then + begin + PaintRectangle := R; + Column := nil; + FHeader.Treeview.DoHeaderDrawQueryElements(PaintInfo, RequestedElements); + end; + + // Draw the background. + DrawBackground; + + // Now that we have drawn the background, we apply the header's dimensions to R. + R := Rect(Max(R.Left, 0), Max(R.Top, 0), Min(R.Right, TotalWidth), Min(R.Bottom, Header.Height)); + + // Determine where to stop. + MaxX := Target.X + R.Right - R.Left + //Fixes issues #544, #427 -- MaxX should also shift on BidiMode bdRightToLeft + + RTLOffset; //added for fix + + // Determine the start column. + Run := ColumnFromPosition(Point(R.Left + RTLOffset, 0), False); + if Run <= NoColumn then + Exit; + + TargetRect.Top := Target.Y; + TargetRect.Bottom := Target.Y + R.Bottom - R.Top; + TargetRect.Left := Target.X - R.Left + Items[Run].FLeft + RTLOffset; + // TargetRect.Right will be set in the loop + + ShowRightBorder := (FHeader.Style = hsThickButtons) or not (hoAutoResize in FHeader.Options) or + (FHeader.Treeview.BevelKind = bkNone); + + // Now go for each button. + while (Run > NoColumn) and (TargetRect.Left < MaxX) do + begin + TargetRect.Right := TargetRect.Left + Items[Run].Width; + + // create a clipping rect to limit painting to button area + ClipCanvas(TargetCanvas, Rect(Max(TargetRect.Left, Target.X), Target.Y + R.Top, + Min(TargetRect.Right, MaxX), TargetRect.Bottom)); + + PaintColumnHeader(Run, TargetRect); + + SelectClipRgn(Handle, 0); + + TargetRect.Left := TargetRect.Right; + Run := GetNextVisibleColumn(Run); + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualTreeColumns.SaveToStream(const Stream: TStream); + +var + I: Integer; + +begin + I := Count; + Stream.WriteBuffer(I, SizeOf(I)); + if I > 0 then + begin + for I := 0 to Count - 1 do + TVirtualTreeColumn(Items[I]).SaveToStream(Stream); + + Stream.WriteBuffer(FPositionToIndex[0], Count * SizeOf(TColumnIndex)); + end; + + // Data introduced with header stream version 5. + Stream.WriteBuffer(DefaultWidth, SizeOf(DefaultWidth)); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVirtualTreeColumns.TotalWidth: Integer; + +var + LastColumn: TColumnIndex; + +begin + Result := 0; + if (Count > 0) and (Length(FPositionToIndex) > 0) then + begin + LastColumn := FPositionToIndex[Count - 1]; + if not (coVisible in Items[LastColumn].Options) then + LastColumn := GetPreviousVisibleColumn(LastColumn); + if LastColumn > NoColumn then + with Items[LastColumn] do + Result := FLeft + FWidth; + end; +end; + +//----------------- TVTFixedAreaConstraints ---------------------------------------------------------------------------- + +constructor TVTFixedAreaConstraints.Create(AOwner: TVTHeader); + +begin + inherited Create; + FMaxWidthPercent := 95; + FHeader := AOwner; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTFixedAreaConstraints.SetConstraints(Index: Integer; Value: TVTConstraintPercent); + +begin + case Index of + 0: + if Value <> FMaxHeightPercent then + begin + FMaxHeightPercent := Value; + if (Value > 0) and (Value < FMinHeightPercent) then + FMinHeightPercent := Value; + Change; + end; + 1: + if Value <> FMaxWidthPercent then + begin + FMaxWidthPercent := Value; + if (Value > 0) and (Value < FMinWidthPercent) then + FMinWidthPercent := Value; + Change; + end; + 2: + if Value <> FMinHeightPercent then + begin + FMinHeightPercent := Value; + if (FMaxHeightPercent > 0) and (Value > FMaxHeightPercent) then + FMaxHeightPercent := Value; + Change; + end; + 3: + if Value <> FMinWidthPercent then + begin + FMinWidthPercent := Value; + if (FMaxWidthPercent > 0) and (Value > FMaxWidthPercent) then + FMaxWidthPercent := Value; + Change; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTFixedAreaConstraints.Change; + +begin + if Assigned(FOnChange) then + FOnChange(Self); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTFixedAreaConstraints.Assign(Source: TPersistent); + +begin + if Source is TVTFixedAreaConstraints then + begin + FMaxHeightPercent := TVTFixedAreaConstraints(Source).FMaxHeightPercent; + FMaxWidthPercent := TVTFixedAreaConstraints(Source).FMaxWidthPercent; + FMinHeightPercent := TVTFixedAreaConstraints(Source).FMinHeightPercent; + FMinWidthPercent := TVTFixedAreaConstraints(Source).FMinWidthPercent; + Change; + end + else + inherited; +end; + +//----------------- TVTHeader ----------------------------------------------------------------------------------------- + +constructor TVTHeader.Create(AOwner: TBaseVirtualTree); + +begin + inherited Create; + FOwner := AOwner; + FColumns := GetColumnsClass.Create(Self); + FHeight := 19; + FDefaultHeight := FHeight; + FMinHeight := 10; + FMaxHeight := 10000; + FFont := TFont.Create; + FFont.OnChange := FontChanged; + FParentFont := True; + FBackgroundColor := clBtnFace; + FOptions := [hoColumnResize, hoDrag, hoShowSortGlyphs]; + + FImageChangeLink := TChangeLink.Create; + FImageChangeLink.OnChange := ImageListChange; + + FSortColumn := NoColumn; + FSortDirection := sdAscending; + FMainColumn := NoColumn; + + FDragImage := TVTDragImage.Create(AOwner); + with FDragImage do + begin + Fade := False; + PreBlendBias := -50; + Transparency := 140; + end; + + fSplitterHitTolerance := 8; + FFixedAreaConstraints := TVTFixedAreaConstraints.Create(Self); + FFixedAreaConstraints.OnChange := FixedAreaConstraintsChanged; + + FDoingAutoFitColumns := false; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +destructor TVTHeader.Destroy; + +begin + FDragImage.Free; + FFixedAreaConstraints.Free; + FImageChangeLink.Free; + FFont.Free; + FColumns.Clear; // TCollection's Clear method is not virtual, so we have to call our own Clear method manually. + FColumns.Free; + inherited; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTHeader.FontChanged(Sender: TObject); +begin + inherited; + {$IF CompilerVersion < 31} // See issue #1043 + AutoScale(); + {$IFEND} +end; + +procedure TVTHeader.AutoScale(); +var + I: Integer; + lMaxHeight: Integer; +begin + if toAutoChangeScale in Treeview.TreeOptions.AutoOptions then + begin + // Ensure a minimum header size based on the font, so that all text is visible. + // First find the largest Columns[].Spacing + lMaxHeight := 0; + for I := 0 to Self.Columns.Count - 1 do + lMaxHeight := Max(lMaxHeight, Columns[I].Spacing); + // Calculate the required height based on the font, this is important as the user might just have increased the size of the system icon font. + with TBitmap.Create do + try + Canvas.Font.Assign(FFont); + lMaxHeight := lMaxHeight {top spacing} + (lMaxHeight div 2) {minimum bottom spacing} + Canvas.TextHeight('Q'); + finally + Free; + end; + // Get the maximum of the scaled original value and the minimum needed header height. + lMaxHeight := Max(lMaxHeight, FHeight); + // Set the calculated size + Self.SetHeight(lMaxHeight); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTHeader.GetMainColumn: TColumnIndex; + +begin + if FColumns.Count > 0 then + Result := FMainColumn + else + Result := NoColumn; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTHeader.GetUseColumns: Boolean; + +begin + Result := FColumns.Count > 0; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTHeader.IsFontStored: Boolean; + +begin + Result := not ParentFont; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTHeader.SetAutoSizeIndex(Value: TColumnIndex); + +begin + if FAutoSizeIndex <> Value then + begin + FAutoSizeIndex := Value; + if hoAutoResize in FOptions then + Columns.AdjustAutoSize(InvalidColumn); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTHeader.SetBackground(Value: TColor); + +begin + if FBackgroundColor <> Value then + begin + FBackgroundColor := Value; + Invalidate(nil); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTHeader.SetColumns(Value: TVirtualTreeColumns); + +begin + FColumns.Assign(Value); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTHeader.SetDefaultHeight(Value: Integer); + +begin + if Value < FMinHeight then + Value := FMinHeight; + if Value > FMaxHeight then + Value := FMaxHeight; + + if FHeight = FDefaultHeight then + SetHeight(Value); + FDefaultHeight := Value; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTHeader.SetFont(const Value: TFont); + +begin + FFont.Assign(Value); + FParentFont := False; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTHeader.SetHeight(Value: Integer); + +var + RelativeMaxHeight, + RelativeMinHeight, + EffectiveMaxHeight, + EffectiveMinHeight: Integer; + +begin + if not TreeView.HandleAllocated then + begin + FHeight := Value; + Include(FStates, hsNeedScaling); + end + else + begin + with FFixedAreaConstraints do + begin + RelativeMaxHeight := ((Treeview.ClientHeight + FHeight) * FMaxHeightPercent) div 100; + RelativeMinHeight := ((Treeview.ClientHeight + FHeight) * FMinHeightPercent) div 100; + + EffectiveMinHeight := IfThen(FMaxHeightPercent > 0, Min(RelativeMaxHeight, FMinHeight), FMinHeight); + EffectiveMaxHeight := IfThen(FMinHeightPercent > 0, Max(RelativeMinHeight, FMaxHeight), FMaxHeight); + + Value := Min(Max(Value, EffectiveMinHeight), EffectiveMaxHeight); + if FMinHeightPercent > 0 then + Value := Max(RelativeMinHeight, Value); + if FMaxHeightPercent > 0 then + Value := Min(RelativeMaxHeight, Value); + end; + + if FHeight <> Value then + begin + FHeight := Value; + if not (csLoading in Treeview.ComponentState) and not (hsScaling in FStates) then + RecalculateHeader; + Treeview.Invalidate; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTHeader.SetImages(const Value: TCustomImageList); + +begin + if FImages <> Value then + begin + if Assigned(FImages) then + begin + FImages.UnRegisterChanges(FImageChangeLink); + FImages.RemoveFreeNotification(FOwner); + end; + FImages := Value; + if Assigned(FImages) then + begin + FImages.RegisterChanges(FImageChangeLink); + FImages.FreeNotification(FOwner); + end; + if not (csLoading in Treeview.ComponentState) then + Invalidate(nil); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTHeader.SetMainColumn(Value: TColumnIndex); + +begin + if csLoading in Treeview.ComponentState then + FMainColumn := Value + else + begin + if Value < 0 then + Value := 0; + if Value > FColumns.Count - 1 then + Value := FColumns.Count - 1; + if Value <> FMainColumn then + begin + FMainColumn := Value; + if not (csLoading in Treeview.ComponentState) then + begin + Treeview.MainColumnChanged; + if not (toExtendedFocus in Treeview.TreeOptions.SelectionOptions) then + Treeview.FocusedColumn := FMainColumn; + Treeview.Invalidate; + end; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTHeader.SetMaxHeight(Value: Integer); + +begin + if Value < FMinHeight then + Value := FMinHeight; + FMaxHeight := Value; + SetHeight(FHeight); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTHeader.SetMinHeight(Value: Integer); + +begin + if Value < 0 then + Value := 0; + if Value > FMaxHeight then + Value := FMaxHeight; + FMinHeight := Value; + SetHeight(FHeight); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTHeader.SetOptions(Value: TVTHeaderOptions); + +var + ToBeSet, + ToBeCleared: TVTHeaderOptions; + +begin + ToBeSet := Value - FOptions; + ToBeCleared := FOptions - Value; + FOptions := Value; + + if (hoAutoResize in (ToBeSet + ToBeCleared)) and (FColumns.Count > 0) then + begin + FColumns.AdjustAutoSize(InvalidColumn); + if Treeview.HandleAllocated then + begin + Treeview.UpdateHorizontalScrollBar(False); + if hoAutoResize in ToBeSet then + Treeview.Invalidate; + end; + end; + + if not (csLoading in Treeview.ComponentState) and Treeview.HandleAllocated then + begin + if hoVisible in (ToBeSet + ToBeCleared) then + RecalculateHeader; + Invalidate(nil); + Treeview.Invalidate; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTHeader.SetParentFont(Value: Boolean); + +begin + if FParentFont <> Value then + begin + FParentFont := Value; + if FParentFont then + FFont.Assign(FOwner.Font); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTHeader.SetSortColumn(Value: TColumnIndex); + +begin + if csLoading in Treeview.ComponentState then + FSortColumn := Value + else + DoSetSortColumn(Value, FSortDirection); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTHeader.SetSortDirection(const Value: TSortDirection); + +begin + if Value <> FSortDirection then + begin + FSortDirection := Value; + Invalidate(nil); + if ((toAutoSort in Treeview.TreeOptions.AutoOptions) or (hoHeaderClickAutoSort in Options)) and (Treeview.UpdateCount = 0) then + Treeview.SortTree(FSortColumn, FSortDirection, True); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTHeader.CanSplitterResize(P: TPoint): Boolean; + +begin + Result := hoHeightResize in FOptions; + DoCanSplitterResize(P, Result); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTHeader.SetStyle(Value: TVTHeaderStyle); + +begin + if FStyle <> Value then + begin + FStyle := Value; + if not (csLoading in Treeview.ComponentState) then + Invalidate(nil); + end; +end; + +procedure TVTHeader.StyleChanged(); +begin + {$IF CompilerVersion < 31} // See issue #1043 + AutoScale(); //Elements may have changed in size + {$IFEND} +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTHeader.CanWriteColumns: Boolean; + +// descendants may override this to optionally prevent column writing (e.g. if they are build dynamically). + +begin + Result := True; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTHeader.ChangeScale(M, D: Integer; isDpiChange: Boolean); +var + I: Integer; +begin + // This method is only executed if toAutoChangeScale is set + FMinHeight := MulDiv(FMinHeight, M, D); + FMaxHeight := MulDiv(FMaxHeight, M, D); + Self.Height := MulDiv(FHeight, M, D); + if not ParentFont then + Font.Height := MulDiv(Font.Height, M, D); + // Scale the columns widths too + for I := 0 to FColumns.Count - 1 do + Self.FColumns[I].ChangeScale(M, D, isDpiChange); + if not isDpiChange then + AutoScale(); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTHeader.DetermineSplitterIndex(P: TPoint): Boolean; + +// Tries to find the index of that column whose right border corresponds to P. +// Result is True if column border was hit (with -3..+5 pixels tolerance). +// For continuous resizing the current track index and the column's left/right border are set. +// Note: The hit test is checking from right to left (or left to right in RTL mode) to make enlarging of zero-sized +// columns possible. + +var + VisibleFixedWidth: Integer; + SplitPoint: Integer; + + //--------------- local function -------------------------------------------- + + function IsNearBy(IsFixedCol: Boolean; LeftTolerance, RightTolerance: Integer): Boolean; + + begin + if IsFixedCol then + Result := (P.X < SplitPoint + Treeview.FEffectiveOffsetX + RightTolerance) and (P.X > SplitPoint + Treeview.FEffectiveOffsetX - LeftTolerance) + else + Result := (P.X > VisibleFixedWidth) and (P.X < SplitPoint + RightTolerance) and (P.X > SplitPoint - LeftTolerance); + end; + + //--------------- end local function ---------------------------------------- + +var + I: Integer; + LeftTolerance: Integer; // The area left of the column divider which allows column resizing +begin + Result := False; + + if FColumns.Count > 0 then + begin + FColumns.TrackIndex := NoColumn; + VisibleFixedWidth := FColumns.GetVisibleFixedWidth; + LeftTolerance := Round(SplitterHitTolerance * 0.6); + if Treeview.UseRightToLeftAlignment then + begin + SplitPoint := -Treeview.FEffectiveOffsetX; + if FColumns.TotalWidth < Treeview.ClientWidth then + Inc(SplitPoint, Treeview.ClientWidth - FColumns.TotalWidth); + + for I := 0 to FColumns.Count - 1 do + with FColumns, Items[FPositionToIndex[I]] do + if coVisible in FOptions then + begin + if IsNearBy(coFixed in FOptions, LeftTolerance, SplitterHitTolerance - LeftTolerance) then + begin + if CanSplitterResize(P, FPositionToIndex[I]) then + begin + Result := True; + FTrackIndex := FPositionToIndex[I]; + + // Keep the right border of this column. This and the current mouse position + // directly determine the current column width. + FTrackPoint.X := SplitPoint + IfThen(coFixed in FOptions, Treeview.FEffectiveOffsetX) + FWidth; + FTrackPoint.Y := P.Y; + Break; + end; + end; + Inc(SplitPoint, FWidth); + end; + end + else + begin + SplitPoint := -Treeview.FEffectiveOffsetX + FColumns.TotalWidth; + + for I := FColumns.Count - 1 downto 0 do + with FColumns, Items[FPositionToIndex[I]] do + if coVisible in FOptions then + begin + if IsNearBy(coFixed in FOptions, SplitterHitTolerance - LeftTolerance, LeftTolerance) then + begin + if CanSplitterResize(P, FPositionToIndex[I]) then + begin + Result := True; + FTrackIndex := FPositionToIndex[I]; + + // Keep the left border of this column. This and the current mouse position + // directly determine the current column width. + FTrackPoint.X := SplitPoint + IfThen(coFixed in FOptions, Treeview.FEffectiveOffsetX) - FWidth; + FTrackPoint.Y := P.Y; + Break; + end; + end; + Dec(SplitPoint, FWidth); + end; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTHeader.DoAfterAutoFitColumn(Column: TColumnIndex); + +begin + if Assigned(TreeView.FOnAfterAutoFitColumn) then + TreeView.FOnAfterAutoFitColumn(Self, Column); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTHeader.DoAfterColumnWidthTracking(Column: TColumnIndex); + +// Tell the application that a column width tracking operation has been finished. + +begin + if Assigned(TreeView.FOnAfterColumnWidthTracking) then + TreeView.FOnAfterColumnWidthTracking(Self, Column); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTHeader.DoAfterHeightTracking; + +// Tell the application that a height tracking operation has been finished. + +begin + if Assigned(TreeView.FOnAfterHeaderHeightTracking) then + TreeView.FOnAfterHeaderHeightTracking(Self); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTHeader.DoBeforeAutoFitColumn(Column: TColumnIndex; SmartAutoFitType: TSmartAutoFitType): Boolean; + +// Query the application if we may autofit a column. + +begin + Result := True; + if Assigned(TreeView.FOnBeforeAutoFitColumn) then + TreeView.FOnBeforeAutoFitColumn(Self, Column, SmartAutoFitType, Result); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTHeader.DoBeforeColumnWidthTracking(Column: TColumnIndex; Shift: TShiftState); + +// Tell the a application that a column width tracking operation may begin. + +begin + if Assigned(TreeView.FOnBeforeColumnWidthTracking) then + TreeView.FOnBeforeColumnWidthTracking(Self, Column, Shift); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTHeader.DoBeforeHeightTracking(Shift: TShiftState); + +// Tell the application that a height tracking operation may begin. + +begin + if Assigned(TreeView.FOnBeforeHeaderHeightTracking) then + TreeView.FOnBeforeHeaderHeightTracking(Self, Shift); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTHeader.DoCanSplitterResize(P: TPoint; var Allowed: Boolean); +begin + if Assigned(TreeView.FOnCanSplitterResizeHeader) then + TreeView.FOnCanSplitterResizeHeader(Self, P, Allowed); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTHeader.DoColumnWidthDblClickResize(Column: TColumnIndex; P: TPoint; Shift: TShiftState): Boolean; + +// Queries the application whether a double click on the column splitter should resize the column. + +begin + Result := True; + if Assigned(TreeView.FOnColumnWidthDblClickResize) then + TreeView.FOnColumnWidthDblClickResize(Self, Column, Shift, P, Result); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTHeader.DoColumnWidthTracking(Column: TColumnIndex; Shift: TShiftState; var TrackPoint: TPoint; P: TPoint): Boolean; + +begin + Result := True; + if Assigned(TreeView.FOnColumnWidthTracking) then + TreeView.FOnColumnWidthTracking(Self, Column, Shift, TrackPoint, P, Result); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTHeader.DoGetPopupMenu(Column: TColumnIndex; Position: TPoint): TPopupMenu; + +// Queries the application whether there is a column specific header popup menu. + +var + AskParent: Boolean; + +begin + Result := PopupMenu; + if Assigned(TreeView.FOnGetPopupMenu) then + TreeView.FOnGetPopupMenu(TreeView, nil, Column, Position, AskParent, Result); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTHeader.DoHeightTracking(var P: TPoint; Shift: TShiftState): Boolean; + +begin + Result := True; + if Assigned(TreeView.FOnHeaderHeightTracking) then + TreeView.FOnHeaderHeightTracking(Self, P, Shift, Result); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTHeader.DoHeightDblClickResize(var P: TPoint; Shift: TShiftState): Boolean; + +begin + Result := True; + if Assigned(TreeView.FOnHeaderHeightDblClickResize) then + TreeView.FOnHeaderHeightDblClickResize(Self, P, Shift, Result); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTHeader.DoSetSortColumn(Value: TColumnIndex; pSortDirection: TSortDirection); + +begin + if Value < NoColumn then + Value := NoColumn; + if Value > Columns.Count - 1 then + Value := Columns.Count - 1; + if FSortColumn <> Value then + begin + if FSortColumn > NoColumn then + Invalidate(Columns[FSortColumn]); + FSortColumn := Value; + FSortDirection := pSortDirection; + if FSortColumn > NoColumn then + Invalidate(Columns[FSortColumn]); + if ((toAutoSort in Treeview.TreeOptions.AutoOptions) or (hoHeaderClickAutoSort in Options)) and (Treeview.UpdateCount = 0) then + Treeview.SortTree(FSortColumn, FSortDirection, True); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTHeader.DragTo(P: TPoint); + +// Moves the drag image to a new position, which is determined from the passed point P and the previous +// mouse position. + +var + I, + NewTarget: Integer; + // optimized drag image move support + ClientP: TPoint; + Left, + Right: Integer; + NeedRepaint: Boolean; // True if the screen needs an update (changed drop target or drop side) + +begin + // Determine new drop target and which side of it is prefered. + ClientP := Treeview.ScreenToClient(P); + // Make coordinates relative to (0, 0) of the non-client area. + Inc(ClientP.Y, FHeight); + NewTarget := FColumns.ColumnFromPosition(ClientP); + NeedRepaint := (NewTarget <> InvalidColumn) and (NewTarget <> FColumns.DropTarget); + if NewTarget >= 0 then + begin + FColumns.GetColumnBounds(NewTarget, Left, Right); + if (ClientP.X < ((Left + Right) div 2)) <> FColumns.DropBefore then + begin + NeedRepaint := True; + FColumns.DropBefore := not FColumns.DropBefore; + end; + end; + + if NeedRepaint then + begin + // Invalidate columns which need a repaint. + if FColumns.DropTarget > NoColumn then + begin + I := FColumns.DropTarget; + FColumns.DropTarget := NoColumn; + Invalidate(FColumns.Items[I]); + end; + if (NewTarget > NoColumn) and (NewTarget <> FColumns.DropTarget) then + begin + Invalidate(FColumns.Items[NewTarget]); + FColumns.DropTarget := NewTarget; + end; + end; + + // Fix for various problems mentioned in issue 248. + if NeedRepaint then + begin + UpdateWindow(FOwner.Handle); + // The new routine recaptures the backup image after the updatewindow + // Note: We could have called this unconditionally but when called + // over the tree, doesn't capture the background image. Since our + // problems are in painting of the header, we call it only when the + // drag image is over the header. + if + // determine the case when the drag image is or was on the header area + (InHeader(FOwner.ScreenToClient(FDragImage.LastPosition)) + or InHeader(FOwner.ScreenToClient(FDragImage.ImagePosition)) + ) then + begin + GDIFlush; + FOwner.UpdateWindowAndDragImage(FOwner, FOwner.HeaderRect, True, true); + end; + // since we took care of UpdateWindow above, there is no need to do an + // update window again by sending NeedRepaint. So switch off the second parameter. + NeedRepaint := false; + end; + + FDragImage.DragTo(P, NeedRepaint); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTHeader.FixedAreaConstraintsChanged(Sender: TObject); + +// This method gets called when FFixedAreaConstraints is changed. + +begin + if Treeview.HandleAllocated then + RescaleHeader + else + Include(FStates, hsNeedScaling); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTHeader.GetColumnsClass: TVirtualTreeColumnsClass; + +// Returns the class to be used for the actual column implementation. descendants may optionally override this and +// return their own class. + +begin + Result := TVirtualTreeColumns; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTHeader.GetOwner: TPersistent; + +begin + Result := FOwner; +end; + +function TVTHeader.GetRestoreSelectionColumnIndex: Integer; +begin + if fRestoreSelectionColumnIndex >= 0 then + Result := fRestoreSelectionColumnIndex + else + Result := MainColumn; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTHeader.GetShiftState: TShiftState; + +begin + Result := []; + if GetKeyState(VK_SHIFT) < 0 then + Include(Result, ssShift); + if GetKeyState(VK_CONTROL) < 0 then + Include(Result, ssCtrl); + if GetKeyState(VK_MENU) < 0 then + Include(Result, ssAlt); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTHeader.HandleHeaderMouseMove(var Message: TWMMouseMove): Boolean; + +var + P: TPoint; + NextColumn, + I: TColumnIndex; + NewWidth: Integer; + +begin + Result := False; + with Message do + begin + P := Point(XPos, YPos); + if hsColumnWidthTrackPending in FStates then + begin + Treeview.StopTimer(HeaderTimer); + FStates := FStates - [hsColumnWidthTrackPending] + [hsColumnWidthTracking]; + HandleHeaderMouseMove := True; + Result := 0; + end + else + if hsHeightTrackPending in FStates then + begin + Treeview.StopTimer(HeaderTimer); + FStates := FStates - [hsHeightTrackPending] + [hsHeightTracking]; + HandleHeaderMouseMove := True; + Result := 0; + end + else + if hsColumnWidthTracking in FStates then + begin + if DoColumnWidthTracking(FColumns.TrackIndex, GetShiftState, FTrackPoint, P) then + begin + if Treeview.UseRightToLeftAlignment then + begin + NewWidth := FTrackPoint.X - XPos; + NextColumn := FColumns.GetPreviousVisibleColumn(FColumns.TrackIndex); + end + else + begin + NewWidth := XPos - FTrackPoint.X; + NextColumn := FColumns.GetNextVisibleColumn(FColumns.TrackIndex); + end; + + // The autosized column cannot be resized using the mouse normally. Instead we resize the next + // visible column, so it look as we directly resize the autosized column. + if (hoAutoResize in FOptions) and (FColumns.TrackIndex = FAutoSizeIndex) and + (NextColumn > NoColumn) and (coResizable in FColumns[NextColumn].Options) and + (FColumns[FColumns.TrackIndex].MinWidth < NewWidth) and + (FColumns[FColumns.TrackIndex].MaxWidth > NewWidth) then + FColumns[NextColumn].Width := FColumns[NextColumn].Width - NewWidth + + FColumns[FColumns.TrackIndex].Width + else + FColumns[FColumns.TrackIndex].Width := NewWidth; // 1 EListError seen here (List index out of bounds (-1)) since 10/2013 + end; + HandleHeaderMouseMove := True; + Result := 0; + end + else + if hsHeightTracking in FStates then + begin + if DoHeightTracking(P, GetShiftState) then + SetHeight(Integer(FHeight) + P.Y); + HandleHeaderMouseMove := True; + Result := 0; + end + else + begin + if hsDragPending in FStates then + begin + P := Treeview.ClientToScreen(P); + // start actual dragging if allowed + if (hoDrag in FOptions) and Treeview.DoHeaderDragging(FColumns.DownIndex) then + begin + if ((Abs(FDragStart.X - P.X) > Mouse.DragThreshold) or + (Abs(FDragStart.Y - P.Y) > Mouse.DragThreshold)) then + begin + Treeview.StopTimer(HeaderTimer); + I := FColumns.DownIndex; + FColumns.DownIndex := NoColumn; + FColumns.HoverIndex := NoColumn; + if I > NoColumn then + Invalidate(FColumns[I]); + PrepareDrag(P, FDragStart); + FStates := FStates - [hsDragPending] + [hsDragging]; + HandleHeaderMouseMove := True; + Result := 0; + end; + end; + end + else + if hsDragging in FStates then + begin + DragTo(Treeview.ClientToScreen(Point(XPos, YPos))); + HandleHeaderMouseMove := True; + Result := 0; + end; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTHeader.HandleMessage(var Message: TMessage): Boolean; + +// The header gets here the opportunity to handle certain messages before they reach the tree. This is important +// because the tree needs to handle various non-client area messages for the header as well as some dragging/tracking +// events. +// By returning True the message will not be handled further, otherwise the message is then dispatched +// to the proper message handlers. + +var + P: TPoint; + R: TRect; + I: TColumnIndex; + OldPosition: Integer; + HitIndex: TColumnIndex; + NewCursor: HCURSOR; + Button: TMouseButton; + IsInHeader, + IsHSplitterHit, + IsVSplitterHit: Boolean; + + //--------------- local function -------------------------------------------- + + function HSplitterHit: Boolean; + begin + Result := (hoColumnResize in FOptions) and DetermineSplitterIndex(P); + if Result and not InHeader(P) then + begin + // Code commented due to issue #1067. What was the orginal inention of this code? It does not make much sense unless you allow column resize outside the header. + // NextCol := FColumns.GetNextVisibleColumn(FColumns.TrackIndex); + // if not (coFixed in FColumns[FColumns.TrackIndex].Options) or (NextCol <= NoColumn) or + // (coFixed in FColumns[NextCol].Options) or (P.Y > Integer(Treeview.FRangeY)) then + Result := False; + end; + end; + + //--------------- end local function ---------------------------------------- + +begin + Result := False; + case Message.Msg of + WM_SIZE: + begin + if not (tsWindowCreating in FOwner.TreeStates) then + if (hoAutoResize in FOptions) and not (hsAutoSizing in FStates) then + begin + FColumns.AdjustAutoSize(InvalidColumn); + Invalidate(nil); + end + else + if not (hsScaling in FStates) then + begin + RescaleHeader; + Invalidate(nil); + end; + end; + CM_PARENTFONTCHANGED: + if FParentFont then + FFont.Assign(FOwner.Font); + CM_BIDIMODECHANGED: + for I := 0 to FColumns.Count - 1 do + if coParentBiDiMode in FColumns[I].Options then + FColumns[I].ParentBiDiModeChanged; + WM_NCMBUTTONDOWN: + begin + with TWMNCMButtonDown(Message) do + P := Treeview.ScreenToClient(Point(XCursor, YCursor)); + if InHeader(P) then + FOwner.DoHeaderMouseDown(mbMiddle, GetShiftState, P.X, P.Y + Integer(FHeight)); + end; + WM_NCMBUTTONUP: + begin + with TWMNCMButtonUp(Message) do + P := FOwner.ScreenToClient(Point(XCursor, YCursor)); + if InHeader(P) then + begin + FColumns.HandleClick(P, mbMiddle, True, False); + FOwner.DoHeaderMouseUp(mbMiddle, GetShiftState, P.X, P.Y + Integer(FHeight)); + FColumns.DownIndex := NoColumn; + FColumns.CheckBoxHit := False; + end; + end; + WM_LBUTTONDBLCLK, + WM_NCLBUTTONDBLCLK, + WM_NCMBUTTONDBLCLK, + WM_NCRBUTTONDBLCLK: + begin + if Message.Msg <> WM_LBUTTONDBLCLK then + with TWMNCLButtonDblClk(Message) do + P := FOwner.ScreenToClient(Point(XCursor, YCursor)) + else + with TWMLButtonDblClk(Message) do + P := Point(XPos, YPos); + + if (hoHeightDblClickResize in FOptions) and InHeaderSplitterArea(P) and (FDefaultHeight > 0) then + begin + if DoHeightDblClickResize(P, GetShiftState) and (FDefaultHeight > 0) then + SetHeight(FMinHeight); + Result := True; + end + else + if HSplitterHit and ((Message.Msg = WM_NCLBUTTONDBLCLK) or (Message.Msg = WM_LBUTTONDBLCLK)) and + (hoDblClickResize in FOptions) and (FColumns.TrackIndex > NoColumn) then + begin + // If the click was on a splitter then resize column to smallest width. + if DoColumnWidthDblClickResize(FColumns.TrackIndex, P, GetShiftState) then + AutoFitColumns(True, smaUseColumnOption, FColumns[FColumns.TrackIndex].Position, + FColumns[FColumns.TrackIndex].Position); + Message.Result := 0; + Result := True; + end + else + if InHeader(P) and (Message.Msg <> WM_LBUTTONDBLCLK) then + begin + case Message.Msg of + WM_NCMBUTTONDBLCLK: + Button := mbMiddle; + WM_NCRBUTTONDBLCLK: + Button := mbRight; + else + // WM_NCLBUTTONDBLCLK + Button := mbLeft; + end; + if Button = mbLeft then + Columns.AdjustDownColumn(P); + FColumns.HandleClick(P, Button, True, True); + end; + end; + // The "hot" area of the headers horizontal splitter is partly within the client area of the the tree, so we need + // to handle WM_LBUTTONDOWN here, too. + WM_LBUTTONDOWN, + WM_NCLBUTTONDOWN: + begin + + Application.CancelHint; + + if not (csDesigning in Treeview.ComponentState) then + begin + // make sure no auto scrolling is active... + Treeview.StopTimer(ScrollTimer); + Treeview.DoStateChange([], [tsScrollPending, tsScrolling]); + // ... pending editing is cancelled (actual editing remains active) + Treeview.StopTimer(EditTimer); + Treeview.DoStateChange([], [tsEditPending]); + end; + + if Message.Msg = WM_LBUTTONDOWN then + // Coordinates are already client area based. + with TWMLButtonDown(Message) do + begin + P := Point(XPos, YPos); + // #909 + FDragStart := Treeview.ClientToScreen(p); + end + else + with TWMNCLButtonDown(Message) do + begin + // want the drag start point in screen coordinates + FDragStart := Point(XCursor, YCursor); + P := Treeview.ScreenToClient(FDragStart); + end; + + IsInHeader := InHeader(P); + // in design-time header columns are always resizable + if (csDesigning in Treeview.ComponentState) then + IsVSplitterHit := InHeaderSplitterArea(P) + else + IsVSplitterHit := InHeaderSplitterArea(P) and CanSplitterResize(P); + IsHSplitterHit := HSplitterHit; + + if IsVSplitterHit or IsHSplitterHit then + begin + FTrackStart := P; + FColumns.HoverIndex := NoColumn; + if IsVSplitterHit then + begin + if not (csDesigning in Treeview.ComponentState) then + DoBeforeHeightTracking(GetShiftState); + Include(FStates, hsHeightTrackPending); + end + else + begin + if not (csDesigning in Treeview.ComponentState) then + DoBeforeColumnWidthTracking(FColumns.TrackIndex, GetShiftState); + Include(FStates, hsColumnWidthTrackPending); + end; + + SetCapture(Treeview.Handle); + Result := True; + Message.Result := 0; + end + else + if IsInHeader then + begin + HitIndex := Columns.AdjustDownColumn(P); + // in design-time header columns are always draggable + if ((csDesigning in Treeview.ComponentState) and (HitIndex > NoColumn)) or + ((hoDrag in FOptions) and (HitIndex > NoColumn) and (coDraggable in FColumns[HitIndex].Options)) then + begin + // Show potential drag operation. + // Disabled columns do not start a drag operation because they can't be clicked. + Include(FStates, hsDragPending); + SetCapture(Treeview.Handle); + Result := True; + Message.Result := 0; + end; + end; + + // This is a good opportunity to notify the application. + if not (csDesigning in Treeview.ComponentState) and IsInHeader then + FOwner.DoHeaderMouseDown(mbLeft, GetShiftState, P.X, P.Y + Integer(FHeight)); + end; + WM_NCRBUTTONDOWN: + begin + with TWMNCRButtonDown(Message) do + P := FOwner.ScreenToClient(Point(XCursor, YCursor)); + if InHeader(P) then + FOwner.DoHeaderMouseDown(mbRight, GetShiftState, P.X, P.Y + Integer(FHeight)); + end; + WM_NCRBUTTONUP: + if not (csDesigning in FOwner.ComponentState) then + with TWMNCRButtonUp(Message) do + begin + Application.CancelHint; + P := FOwner.ScreenToClient(Point(XCursor, YCursor)); + if InHeader(P) then + begin + HandleMessage := FColumns.HandleClick(P, mbRight, True, False); + FOwner.DoHeaderMouseUp(mbRight, GetShiftState, P.X, P.Y + Integer(FHeight)); + end; + end; + // When the tree window has an active mouse capture then we only get "client-area" messages. + WM_LBUTTONUP, + WM_NCLBUTTONUP: + begin + Application.CancelHint; + + if FStates <> [] then + begin + ReleaseCapture; + if hsDragging in FStates then + begin + // successfull dragging moves columns + with TWMLButtonUp(Message) do + P := Treeview.ClientToScreen(Point(XPos, YPos)); + GetWindowRect(Treeview.Handle, R); + with FColumns do + begin + FDragImage.EndDrag; + + //Problem fixed: + //Column Header does not paint correctly after a drop in certain conditions + //** The conditions are, drag is across header, mouse is not moved after + //the drop and the graphics hardware is slow in certain operations (encountered + //on Windows 10). + //Fix for the problem on certain systems where the dropped column header + //does not appear in the new position if the mouse is not moved after + //the drop. The reason is that the restore backup image operation (BitBlt) + //in the above EndDrag is slower than the header repaint in the code below + //and overlaps the new changed header with the older image. + //This happens because BitBlt seems to operate in its own thread in the + //graphics hardware and finishes later than the following code. + // + //To solve this problem, we introduce a small delay here so that the + //changed header in the following code is correctly repainted after + //the delayed BitBlt above has finished operation to restore the old + //backup image. + sleep(50); + + if (FDropTarget > -1) and (FDropTarget <> FDragIndex) and PtInRect(R, P) then + begin + OldPosition := FColumns[FDragIndex].Position; + if FColumns.DropBefore then + begin + if FColumns[FDragIndex].Position < FColumns[FDropTarget].Position then + FColumns[FDragIndex].Position := Max(0, FColumns[FDropTarget].Position - 1) + else + FColumns[FDragIndex].Position := FColumns[FDropTarget].Position; + end + else + begin + if FColumns[FDragIndex].Position < FColumns[FDropTarget].Position then + FColumns[FDragIndex].Position := FColumns[FDropTarget].Position + else + FColumns[FDragIndex].Position := FColumns[FDropTarget].Position + 1; + end; + Treeview.DoHeaderDragged(FDragIndex, OldPosition); + end + else + Treeview.DoHeaderDraggedOut(FDragIndex, P); + FDropTarget := NoColumn; + end; + Invalidate(nil); + end; + Result := True; + Message.Result := 0; + end; + + case Message.Msg of + WM_LBUTTONUP: + with TWMLButtonUp(Message) do + begin + if FColumns.DownIndex > NoColumn then + FColumns.HandleClick(Point(XPos, YPos), mbLeft, False, False); + if FStates <> [] then + FOwner.DoHeaderMouseUp(mbLeft, KeysToShiftState(Keys), XPos, YPos); + end; + WM_NCLBUTTONUP: + with TWMNCLButtonUp(Message) do + begin + P := FOwner.ScreenToClient(Point(XCursor, YCursor)); + FColumns.HandleClick(P, mbLeft, False, False); + FOwner.DoHeaderMouseUp(mbLeft, GetShiftState, P.X, P.Y + Integer(FHeight)); + end; + end; + + if FColumns.TrackIndex > NoColumn then + begin + if hsColumnWidthTracking in FStates then + DoAfterColumnWidthTracking(FColumns.TrackIndex); + Invalidate(Columns[FColumns.TrackIndex]); + FColumns.TrackIndex := NoColumn; + end; + if FColumns.DownIndex > NoColumn then + begin + Invalidate(Columns[FColumns.DownIndex]); + FColumns.DownIndex := NoColumn; + end; + if hsHeightTracking in FStates then + DoAfterHeightTracking; + + FStates := FStates - [hsDragging, hsDragPending, + hsColumnWidthTracking, hsColumnWidthTrackPending, + hsHeightTracking, hsHeightTrackPending]; + end;// WM_NCLBUTTONUP + // hovering, mouse leave detection + WM_NCMOUSEMOVE: + with TWMNCMouseMove(Message), FColumns do + begin + P := Treeview.ScreenToClient(Point(XCursor, YCursor)); + Treeview.DoHeaderMouseMove(GetShiftState, P.X, P.Y + Integer(FHeight)); + if InHeader(P) and ((AdjustHoverColumn(P)) or ((FDownIndex >= 0) and (FHoverIndex <> FDownIndex))) then + begin + // We need a mouse leave detection from here for the non client area. + // TODO: The best solution available would be the TrackMouseEvent API. + // With the drop of the support of Win95 totally and WinNT4 we should replace the timer. + Treeview.StopTimer(HeaderTimer); + SetTimer(Treeview.Handle, HeaderTimer, 50, nil); + // use Delphi's internal hint handling for header hints too + if hoShowHint in FOptions then + begin + // client coordinates! + XCursor := P.X; + YCursor := P.Y + Integer(FHeight); + Application.HintMouseMessage(Treeview, Message); + end; + end; + end; + WM_TIMER: + if TWMTimer(Message).TimerID = HeaderTimer then + begin + // determine current mouse position to check if it left the window + GetCursorPos(P); + P := Treeview.ScreenToClient(P); + with FColumns do + begin + if not InHeader(P) or ((FDownIndex > NoColumn) and (FHoverIndex <> FDownIndex)) then + begin + Treeview.StopTimer(HeaderTimer); + FHoverIndex := NoColumn; + FClickIndex := NoColumn; + FDownIndex := NoColumn; + FCheckBoxHit := False; + Result := True; + Message.Result := 0; + Invalidate(nil); + end; + end; + end; + WM_MOUSEMOVE: // mouse capture and general message redirection + Result := HandleHeaderMouseMove(TWMMouseMove(Message)); + WM_SETCURSOR: + // Feature: design-time header + if (FStates = []) then + begin + // Retrieve last cursor position (GetMessagePos does not work here, I don't know why). + GetCursorPos(P); + + // Is the mouse in the header rectangle and near the splitters? + P := Treeview.ScreenToClient(P); + IsHSplitterHit := HSplitterHit; + // in design-time header columns are always resizable + if (csDesigning in Treeview.ComponentState) then + IsVSplitterHit := InHeaderSplitterArea(P) + else + IsVSplitterHit := InHeaderSplitterArea(P) and CanSplitterResize(P); + + if IsVSplitterHit or IsHSplitterHit then + begin + NewCursor := Screen.Cursors[Treeview.Cursor]; + if IsVSplitterHit and ((hoHeightResize in FOptions) or (csDesigning in Treeview.ComponentState)) then + NewCursor := Screen.Cursors[crVertSplit] + else + if IsHSplitterHit then + NewCursor := Screen.Cursors[crHeaderSplit]; + + if not (csDesigning in Treeview.ComponentState) then + Treeview.DoGetHeaderCursor(NewCursor); + Result := NewCursor <> Screen.Cursors[crDefault]; + if Result then + begin + Winapi.Windows.SetCursor(NewCursor); + Message.Result := 1; + end; + end; + end + else + begin + Message.Result := 1; + Result := True; + end; + WM_KEYDOWN, + WM_KILLFOCUS: + if (Message.Msg = WM_KILLFOCUS) or + (TWMKeyDown(Message).CharCode = VK_ESCAPE) then + begin + if hsDragging in FStates then + begin + ReleaseCapture; + FDragImage.EndDrag; + Exclude(FStates, hsDragging); + FColumns.DropTarget := NoColumn; + Invalidate(nil); + Result := True; + Message.Result := 0; + end + else + begin + if [hsColumnWidthTracking, hsHeightTracking] * FStates <> [] then + begin + ReleaseCapture; + if hsColumnWidthTracking in FStates then + DoAfterColumnWidthTracking(FColumns.TrackIndex); + if hsHeightTracking in FStates then + DoAfterHeightTracking; + Result := True; + Message.Result := 0; + end; + + FStates := FStates - [hsColumnWidthTracking, hsColumnWidthTrackPending, + hsHeightTracking, hsHeightTrackPending]; + end; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTHeader.ImageListChange(Sender: TObject); + +begin + if not (csDestroying in Treeview.ComponentState) then + Invalidate(nil); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTHeader.PrepareDrag(P, Start: TPoint); + +// Initializes dragging of the header, P is the current mouse postion and Start the initial mouse position. + +var + Image: TBitmap; + ImagePos: TPoint; + DragColumn: TVirtualTreeColumn; + RTLOffset: Integer; + +begin + // Determine initial position of drag image (screen coordinates). + FColumns.DropTarget := NoColumn; + Start := Treeview.ScreenToClient(Start); + Inc(Start.Y, FHeight); + FColumns.DragIndex := FColumns.ColumnFromPosition(Start); + DragColumn := FColumns[FColumns.DragIndex]; + + Image := TBitmap.Create; + with Image do + try + PixelFormat := pf32Bit; + SetSize(DragColumn.Width, FHeight); + + // Erase the entire image with the color key value, for the case not everything + // in the image is covered by the header image. + Canvas.Brush.Color := clBtnFace; + Canvas.FillRect(Rect(0, 0, Width, Height)); + + if TreeView.UseRightToLeftAlignment then + RTLOffset := Treeview.ComputeRTLOffset + else + RTLOffset := 0; + with DragColumn do + FColumns.PaintHeader(Canvas, Rect(FLeft, 0, FLeft + Width, Height), Point(-RTLOffset, 0), RTLOffset); + + if Treeview.UseRightToLeftAlignment then + ImagePos := Treeview.ClientToScreen(Point(DragColumn.Left + Treeview.ComputeRTLOffset(True), 0)) + else + ImagePos := Treeview.ClientToScreen(Point(DragColumn.Left, 0)); + // Column rectangles are given in local window coordinates not client coordinates. + Dec(ImagePos.Y, FHeight); + + if hoRestrictDrag in FOptions then + FDragImage.MoveRestriction := dmrHorizontalOnly + else + FDragImage.MoveRestriction := dmrNone; + FDragImage.PrepareDrag(Image, ImagePos, P, nil); + FDragImage.ShowDragImage; + finally + Image.Free; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTHeader.ReadColumns(Reader: TReader); + +begin + Include(FStates, hsLoading); + Columns.Clear; + Reader.ReadValue; + Reader.ReadCollection(Columns); + Exclude(FStates, hsLoading); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTHeader.RecalculateHeader; + +// Initiate a recalculation of the non-client area of the owner tree. + +begin + if Treeview.HandleAllocated then + begin + Treeview.UpdateHeaderRect; + SetWindowPos(Treeview.Handle, 0, 0, 0, 0, 0, SWP_FRAMECHANGED or SWP_NOMOVE or SWP_NOACTIVATE or SWP_NOOWNERZORDER or + SWP_NOSENDCHANGING or SWP_NOSIZE or SWP_NOZORDER); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTHeader.RescaleHeader; + +// Rescale the fixed elements (fixed columns, header itself) to FixedAreaConstraints. + +var + FixedWidth, + MaxFixedWidth, + MinFixedWidth: Integer; + + //--------------- local function -------------------------------------------- + + procedure ComputeConstraints; + + var + I: TColumnIndex; + + begin + with FColumns do + begin + I := GetFirstVisibleColumn; + while I > NoColumn do + begin + if (coFixed in FColumns[I].Options) and (FColumns[I].Width < FColumns[I].MinWidth) then + FColumns[I].InternalSetWidth(FColumns[I].MinWidth); //SetWidth has side effects and this bypasses them + I := GetNextVisibleColumn(I); + end; + FixedWidth := GetVisibleFixedWidth; + end; + + with FFixedAreaConstraints do + begin + MinFixedWidth := (TreeView.ClientWidth * FMinWidthPercent) div 100; + MaxFixedWidth := (TreeView.ClientWidth * FMaxWidthPercent) div 100; + end; + end; + + //----------- end local function -------------------------------------------- + +begin + if ([csLoading, csReading, csWriting, csDestroying] * Treeview.ComponentState = []) and not + (hsLoading in FStates) and Treeview.HandleAllocated then + begin + Include(FStates, hsScaling); + + SetHeight(FHeight); + RecalculateHeader; + + with FFixedAreaConstraints do + if (FMaxWidthPercent > 0) or (FMinWidthPercent > 0) or (FMinHeightPercent > 0) or (FMaxHeightPercent > 0) then + begin + ComputeConstraints; + + with FColumns do + if (FMaxWidthPercent > 0) and (FixedWidth > MaxFixedWidth) then + ResizeColumns(MaxFixedWidth - FixedWidth, 0, Count - 1, [coVisible, coFixed]) + else + if (FMinWidthPercent > 0) and (FixedWidth < MinFixedWidth) then + ResizeColumns(MinFixedWidth - FixedWidth, 0, Count - 1, [coVisible, coFixed]); + + FColumns.UpdatePositions; + end; + + Exclude(FStates, hsScaling); + Exclude(FStates, hsNeedScaling); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTHeader.UpdateMainColumn(); + +// Called once the load process of the owner tree is done. + +begin + if FMainColumn < 0 then + MainColumn := 0; + if FMainColumn > FColumns.Count - 1 then + MainColumn := FColumns.Count - 1; + if (FMainColumn >= 0) and not (coVisible in Self.Columns[FMainColumn].Options) then + begin + // Issue #946: Choose new MainColumn if current one ist not visible + MainColumn := Self.Columns.GetFirstVisibleColumn(); + end +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTHeader.UpdateSpringColumns; + +var + I: TColumnIndex; + SpringCount: Integer; + Sign: Integer; + ChangeBy: Single; + Difference: Single; + NewAccumulator: Single; + +begin + with TreeView do + ChangeBy := FHeaderRect.Right - FHeaderRect.Left - FLastWidth; + if (hoAutoSpring in FOptions) and (FLastWidth <> 0) and (ChangeBy <> 0) then + begin + // Stay positive if downsizing the control. + if ChangeBy < 0 then + Sign := -1 + else + Sign := 1; + ChangeBy := Abs(ChangeBy); + // Count how many columns have spring enabled. + SpringCount := 0; + for I := 0 to FColumns.Count-1 do + if [coVisible, coAutoSpring] * FColumns[I].Options = [coVisible, coAutoSpring] then + Inc(SpringCount); + if SpringCount > 0 then + begin + // Calculate the size to add/sub to each columns. + Difference := ChangeBy / SpringCount; + // Adjust the column's size accumulators and resize if the result is >= 1. + for I := 0 to FColumns.Count - 1 do + if [coVisible, coAutoSpring] * FColumns[I].Options = [coVisible, coAutoSpring] then + begin + // Sum up rest changes from previous runs and the amount from this one and store it in the + // column. If there is at least one pixel difference then do a resize and reset the accumulator. + NewAccumulator := FColumns[I].SpringRest + Difference; + // Set new width if at least one pixel size difference is reached. + if NewAccumulator >= 1 then + FColumns[I].SetWidth(FColumns[I].Width + (Trunc(NewAccumulator) * Sign)); + FColumns[I].SpringRest := Frac(NewAccumulator); + + // Keep track of the size count. + ChangeBy := ChangeBy - Difference; + // Exit loop if resize count drops below freezing point. + if ChangeBy < 0 then + Break; + end; + end; + end; + with TreeView do + FLastWidth := FHeaderRect.Right - FHeaderRect.Left; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +type + // --- HACK WARNING! + // This type cast is a partial rewrite of the private section of TWriter. The purpose is to have access to + // the FPropPath member, which is otherwise not accessible. The reason why this access is needed is that + // with nested components this member contains unneeded property path information. These information prevent + // successful load of the stored properties later. + // In System.Classes.pas you can see that FPropPath is reset several times to '' to prevent this case for certain properies. + // Unfortunately, there is no clean way for us here to do the same. + {$hints off} + TWriterHack = class(TFiler) + private + FRootAncestor: TComponent; + FPropPath: string; + end; + {$hints on} + +procedure TVTHeader.WriteColumns(Writer: TWriter); + +// Write out the columns but take care for the case VT is a nested component. + +var + LastPropPath: string; + +begin + // Save last property path for restoration. + LastPropPath := TWriterHack(Writer).FPropPath; + try + // If VT is a nested component then this path contains the name of the parent component at this time + // (otherwise it is already empty). This path is then combined with the property name under which the tree + // is defined in the parent component. Unfortunately, the load code in System.Classes.pas does not consider this case + // is then unable to load this property. + TWriterHack(Writer).FPropPath := ''; + Writer.WriteCollection(Columns); + finally + TWriterHack(Writer).FPropPath := LastPropPath; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTHeader.AllowFocus(ColumnIndex: TColumnIndex): Boolean; +begin + Result := False; + if not FColumns.IsValidColumn(ColumnIndex) then + Exit; // Just in case. + + Result := (coAllowFocus in FColumns[ColumnIndex].Options); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTHeader.Assign(Source: TPersistent); + +begin + if Source is TVTHeader then + begin + AutoSizeIndex := TVTHeader(Source).AutoSizeIndex; + Background := TVTHeader(Source).Background; + Columns := TVTHeader(Source).Columns; + Font := TVTHeader(Source).Font; + FixedAreaConstraints.Assign(TVTHeader(Source).FixedAreaConstraints); + Height := TVTHeader(Source).Height; + Images := TVTHeader(Source).Images; + MainColumn := TVTHeader(Source).MainColumn; + Options := TVTHeader(Source).Options; + ParentFont := TVTHeader(Source).ParentFont; + PopupMenu := TVTHeader(Source).PopupMenu; + SortColumn := TVTHeader(Source).SortColumn; + SortDirection := TVTHeader(Source).SortDirection; + Style := TVTHeader(Source).Style; + + RescaleHeader; + end + else + inherited; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTHeader.AutoFitColumns(Animated: Boolean = True; SmartAutoFitType: TSmartAutoFitType = smaUseColumnOption; + RangeStartCol: Integer = NoColumn; RangeEndCol: Integer = NoColumn); + + //--------------- local functions ------------------------------------------- + + function GetUseSmartColumnWidth(ColumnIndex: TColumnIndex): Boolean; + + begin + case SmartAutoFitType of + smaAllColumns: + Result := True; + smaUseColumnOption: + Result := coSmartResize in FColumns.Items[ColumnIndex].Options; + else + Result := False; + end; + end; + + //---------------------------------------------------------------------------- + + procedure DoAutoFitColumn(Column: TColumnIndex); + + begin + with FColumns do + if ([coResizable, coVisible] * Items[FPositionToIndex[Column]].Options = [coResizable, coVisible]) and + DoBeforeAutoFitColumn(FPositionToIndex[Column], SmartAutoFitType) and not TreeView.OperationCanceled then + begin + if Animated then + AnimatedResize(FPositionToIndex[Column], Treeview.GetMaxColumnWidth(FPositionToIndex[Column], + GetUseSmartColumnWidth(FPositionToIndex[Column]))) + else + FColumns[FPositionToIndex[Column]].Width := Treeview.GetMaxColumnWidth(FPositionToIndex[Column], + GetUseSmartColumnWidth(FPositionToIndex[Column])); + + DoAfterAutoFitColumn(FPositionToIndex[Column]); + end; + end; + + //--------------- end local functions ---------------------------------------- + +var + I: Integer; + StartCol, + EndCol: Integer; + +begin + StartCol := Max(NoColumn + 1, RangeStartCol); + + if RangeEndCol <= NoColumn then + EndCol := FColumns.Count - 1 + else + EndCol := Min(RangeEndCol, FColumns.Count - 1); + + if StartCol > EndCol then + Exit; // nothing to do + + TreeView.StartOperation(okAutoFitColumns); + FDoingAutoFitColumns := true; + try + if Assigned(TreeView.FOnBeforeAutoFitColumns) then + TreeView.FOnBeforeAutoFitColumns(Self, SmartAutoFitType); + + for I := StartCol to EndCol do + DoAutoFitColumn(I); + + if Assigned(TreeView.FOnAfterAutoFitColumns) then + TreeView.FOnAfterAutoFitColumns(Self); + + finally + Treeview.EndOperation(okAutoFitColumns); + TreeView.Invalidate(); + FDoingAutoFitColumns := false; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTHeader.InHeader(P: TPoint): Boolean; + +// Determines whether the given point (client coordinates!) is within the header rectangle (non-client coordinates). + +var + R, RW: TRect; + +begin + R := Treeview.FHeaderRect; + + // Current position of the owner in screen coordinates. + GetWindowRect(Treeview.Handle, RW); + + // Convert to client coordinates. + MapWindowPoints(0, Treeview.Handle, RW, 2); + + // Consider the header within this rectangle. + OffsetRect(R, RW.Left, RW.Top); + Result := PtInRect(R, P); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTHeader.InHeaderSplitterArea(P: TPoint): Boolean; + +// Determines whether the given point (client coordinates!) hits the horizontal splitter area of the header. + +var + R, RW: TRect; + +begin + if (P.Y > 2) or (P.Y < -2) or not (hoVisible in FOptions) then + Result := False + else + begin + R := Treeview.FHeaderRect; + Inc(R.Bottom, 2); + + // Current position of the owner in screen coordinates. + GetWindowRect(Treeview.Handle, RW); + + // Convert to client coordinates. + MapWindowPoints(0, Treeview.Handle, RW, 2); + + // Consider the header within this rectangle. + OffsetRect(R, RW.Left, RW.Top); + Result := PtInRect(R, P); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTHeader.Invalidate(Column: TVirtualTreeColumn; ExpandToBorder: Boolean = False; UpdateNowFlag : Boolean = False); + +// Because the header is in the non-client area of the tree it needs some special handling in order to initiate its +// repainting. +// If ExpandToBorder is True then not only the given column but everything or (depending on hoFullRepaintOnResize) just +// everything to its right (or left, in RTL mode) will be invalidated (useful for resizing). This makes only sense when +// a column is given. + +var + R, RW: TRect; + Flags: Cardinal; + +begin + if (hoVisible in FOptions) and Treeview.HandleAllocated then + with Treeview do + begin + if Column = nil then + R := FHeaderRect + else + begin + R := Column.GetRect; + if not (coFixed in Column.Options) then + OffsetRect(R, -FEffectiveOffsetX, 0); + if UseRightToLeftAlignment then + OffsetRect(R, ComputeRTLOffset, 0); + if ExpandToBorder then + begin + if (hoFullRepaintOnResize in FHeader.Options) then + begin + R.Left := FHeaderRect.Left; + R.Right := FHeaderRect.Right; + end + else + begin + if UseRightToLeftAlignment then + R.Left := FHeaderRect.Left + else + R.Right := FHeaderRect.Right; + end; + end; + end; + R.Bottom := Treeview.ClientHeight; // We want to repaint the entire column to bottom, not just the header + + // Current position of the owner in screen coordinates. + GetWindowRect(Handle, RW); + + // Consider the header within this rectangle. + OffsetRect(R, RW.Left, RW.Top); + + // Expressed in client coordinates (because RedrawWindow wants them so, they will actually become negative). + MapWindowPoints(0, Handle, R, 2); + Flags := RDW_FRAME or RDW_INVALIDATE or RDW_VALIDATE or RDW_NOINTERNALPAINT or RDW_NOERASE or RDW_NOCHILDREN; + if UpdateNowFlag then + Flags := Flags or RDW_UPDATENOW; + RedrawWindow(Handle, @R, 0, Flags); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTHeader.LoadFromStream(const Stream: TStream); + +// restore the state of the header from the given stream + +var + Dummy, + Version: Integer; + S: AnsiString; + OldOptions: TVTHeaderOptions; + +begin + Include(FStates, hsLoading); + with Stream do + try + // Switch off all options which could influence loading the columns (they will be later set again). + OldOptions := FOptions; + FOptions := []; + + // Determine whether the stream contains data without a version number. + ReadBuffer(Dummy, SizeOf(Dummy)); + if Dummy > -1 then + begin + // Seek back to undo the read operation if this is an old stream format. + Seek(-SizeOf(Dummy), soFromCurrent); + Version := -1; + end + else // Read version number if this is a "versionized" format. + ReadBuffer(Version, SizeOf(Version)); + Columns.LoadFromStream(Stream, Version); + + ReadBuffer(Dummy, SizeOf(Dummy)); + AutoSizeIndex := Dummy; + ReadBuffer(Dummy, SizeOf(Dummy)); + Background := Dummy; + ReadBuffer(Dummy, SizeOf(Dummy)); + Height := Dummy; + ReadBuffer(Dummy, SizeOf(Dummy)); + FOptions := OldOptions; + Options := TVTHeaderOptions(Dummy); + // PopupMenu is neither saved nor restored + ReadBuffer(Dummy, SizeOf(Dummy)); + Style := TVTHeaderStyle(Dummy); + // TFont has no own save routine so we do it manually + with Font do + begin + ReadBuffer(Dummy, SizeOf(Dummy)); + Color := Dummy; + ReadBuffer(Dummy, SizeOf(Dummy)); + Height := Dummy; + ReadBuffer(Dummy, SizeOf(Dummy)); + SetLength(S, Dummy); + ReadBuffer(PAnsiChar(S)^, Dummy); + Name := UTF8ToString(S); + ReadBuffer(Dummy, SizeOf(Dummy)); + Pitch := TFontPitch(Dummy); + ReadBuffer(Dummy, SizeOf(Dummy)); + Style := TFontStyles(Byte(Dummy)); + end; + + // Read data introduced by stream version 1+. + if Version > 0 then + begin + ReadBuffer(Dummy, SizeOf(Dummy)); + MainColumn := Dummy; + ReadBuffer(Dummy, SizeOf(Dummy)); + SortColumn := Dummy; + ReadBuffer(Dummy, SizeOf(Dummy)); + SortDirection := TSortDirection(Byte(Dummy)); + end; + + // Read data introduced by stream version 5+. + if Version > 4 then + begin + ReadBuffer(Dummy, SizeOf(Dummy)); + ParentFont := Boolean(Dummy); + ReadBuffer(Dummy, SizeOf(Dummy)); + FMaxHeight := Integer(Dummy); + ReadBuffer(Dummy, SizeOf(Dummy)); + FMinHeight := Integer(Dummy); + ReadBuffer(Dummy, SizeOf(Dummy)); + FDefaultHeight := Integer(Dummy); + with FFixedAreaConstraints do + begin + ReadBuffer(Dummy, SizeOf(Dummy)); + FMaxHeightPercent := TVTConstraintPercent(Dummy); + ReadBuffer(Dummy, SizeOf(Dummy)); + FMaxWidthPercent := TVTConstraintPercent(Dummy); + ReadBuffer(Dummy, SizeOf(Dummy)); + FMinHeightPercent := TVTConstraintPercent(Dummy); + ReadBuffer(Dummy, SizeOf(Dummy)); + FMinWidthPercent := TVTConstraintPercent(Dummy); + end; + end; + finally + Exclude(FStates, hsLoading); + RecalculateHeader(); + Treeview.DoColumnResize(NoColumn); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTHeader.ResizeColumns(ChangeBy: Integer; RangeStartCol: TColumnIndex; RangeEndCol: TColumnIndex; + Options: TVTColumnOptions = [coVisible]): Integer; + +// Distribute the given width change to a range of columns. A 'fair' way is used to distribute ChangeBy to the columns, +// while ensuring that everything that can be distributed will be distributed. + +var + Start, + I: TColumnIndex; + ColCount, + ToGo, + Sign, + Rest, + MaxDelta, + Difference: Integer; + Constraints, + Widths: array of Integer; + BonusPixel: Boolean; + + //--------------- local functions ------------------------------------------- + + function IsResizable (Column: TColumnIndex): Boolean; + + begin + if BonusPixel then + Result := Widths[Column - RangeStartCol] < Constraints[Column - RangeStartCol] + else + Result := Widths[Column - RangeStartCol] > Constraints[Column - RangeStartCol]; + end; + + //--------------------------------------------------------------------------- + + procedure IncDelta(Column: TColumnIndex); + + begin + if BonusPixel then + Inc(MaxDelta, FColumns[Column].MaxWidth - Widths[Column - RangeStartCol]) + else + Inc(MaxDelta, Widths[Column - RangeStartCol] - Constraints[Column - RangeStartCol]); + end; + + //--------------------------------------------------------------------------- + + function ChangeWidth(Column: TColumnIndex; Delta: Integer): Integer; + + begin + if Delta > 0 then + Delta := Min(Delta, Constraints[Column - RangeStartCol] - Widths[Column - RangeStartCol]) + else + Delta := Max(Delta, Constraints[Column - RangeStartCol] - Widths[Column - RangeStartCol]); + + Inc(Widths[Column - RangeStartCol], Delta); + Dec(ToGo, Abs(Delta)); + Result := Abs(Delta); + end; + + //--------------------------------------------------------------------------- + + function ReduceConstraints: Boolean; + + var + MaxWidth, + MaxReserveCol, + Column: TColumnIndex; + + begin + Result := True; + if not (hsScaling in FStates) or BonusPixel then + Exit; + + MaxWidth := 0; + MaxReserveCol := NoColumn; + for Column := RangeStartCol to RangeEndCol do + if (Options * FColumns[Column].Options = Options) and + (FColumns[Column].Width > MaxWidth) then + begin + MaxWidth := Widths[Column - RangeStartCol]; + MaxReserveCol := Column; + end; + + if (MaxReserveCol <= NoColumn) or (Constraints[MaxReserveCol - RangeStartCol] <= 10) then + Result := False + else + Dec(Constraints[MaxReserveCol - RangeStartCol], + Constraints[MaxReserveCol - RangeStartCol] div 10); + end; + + //----------- end local functions ------------------------------------------- + +begin + Result := 0; + if (ChangeBy <> 0) and (RangeEndCol >= 0) then // RangeEndCol == -1 means no columns, so nothing to do + begin + // Do some initialization here + BonusPixel := ChangeBy > 0; + Sign := IfThen(BonusPixel, 1, -1); + Start := IfThen(BonusPixel, RangeStartCol, RangeEndCol); + ToGo := Abs(ChangeBy); + SetLength(Widths, RangeEndCol - RangeStartCol + 1); + SetLength(Constraints, RangeEndCol - RangeStartCol + 1); + for I := RangeStartCol to RangeEndCol do + begin + Widths[I - RangeStartCol] := FColumns[I].Width; + Constraints[I - RangeStartCol] := IfThen(BonusPixel, FColumns[I].MaxWidth, FColumns[I].MinWidth); + end; + + repeat + repeat + MaxDelta := 0; + ColCount := 0; + for I := RangeStartCol to RangeEndCol do + if (Options * FColumns[I].Options = Options) and IsResizable(I) then + begin + Inc(ColCount); + IncDelta(I); + end; + if MaxDelta < Abs(ChangeBy) then + if not ReduceConstraints then + Break; + until (MaxDelta >= Abs(ChangeBy)) or not (hsScaling in FStates); + + if ColCount = 0 then + Break; + + ToGo := Min(ToGo, MaxDelta); + Difference := ToGo div ColCount; + Rest := ToGo mod ColCount; + + if Difference > 0 then + for I := RangeStartCol to RangeEndCol do + if (Options * FColumns[I].Options = Options) and IsResizable(I) then + ChangeWidth(I, Difference * Sign); + + // Now distribute Rest. + I := Start; + while Rest > 0 do + begin + if (Options * FColumns[I].Options = Options) and IsResizable(I) then + if FColumns[I].BonusPixel <> BonusPixel then + begin + Dec(Rest, ChangeWidth(I, Sign)); + FColumns[I].BonusPixel := BonusPixel; + end; + Inc(I, Sign); + if (BonusPixel and (I > RangeEndCol)) or (not BonusPixel and (I < RangeStartCol)) then + begin + for I := RangeStartCol to RangeEndCol do + if Options * FColumns[I].Options = Options then + FColumns[I].BonusPixel := not FColumns[I].BonusPixel; + I := Start; + end; + end; + until ToGo <= 0; + + // Now set the computed widths. We also compute the result here. + Include(FStates, hsResizing); + for I := RangeStartCol to RangeEndCol do + if (Options * FColumns[I].Options = Options) then + begin + Inc(Result, Widths[I - RangeStartCol] - FColumns[I].Width); + FColumns[I].SetWidth(Widths[I - RangeStartCol]); + end; + Exclude(FStates, hsResizing); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTHeader.RestoreColumns; + +// Restores all columns to their width which they had before they have been auto fitted. + +var + I: TColumnIndex; + +begin + with FColumns do + for I := Count - 1 downto 0 do + if [coResizable, coVisible] * Items[FPositionToIndex[I]].Options = [coResizable, coVisible] then + Items[I].RestoreLastWidth; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTHeader.SaveToStream(const Stream: TStream); + +// Saves the complete state of the header into the provided stream. + +var + Dummy: Integer; + Tmp: AnsiString; + +begin + with Stream do + begin + // In previous version of VT was no header stream version defined. + // For feature enhancements it is necessary, however, to know which stream + // format we are trying to load. + // In order to distict from non-version streams an indicator is inserted. + Dummy := -1; + WriteBuffer(Dummy, SizeOf(Dummy)); + // Write current stream version number, nothing more is required at the time being. + Dummy := VTHeaderStreamVersion; + WriteBuffer(Dummy, SizeOf(Dummy)); + + // Save columns in case they depend on certain options (like auto size). + Columns.SaveToStream(Stream); + + Dummy := FAutoSizeIndex; + WriteBuffer(Dummy, SizeOf(Dummy)); + Dummy := FBackgroundColor; + WriteBuffer(Dummy, SizeOf(Dummy)); + Dummy := FHeight; + WriteBuffer(Dummy, SizeOf(Dummy)); + Dummy := Integer(FOptions); + WriteBuffer(Dummy, SizeOf(Dummy)); + // PopupMenu is neither saved nor restored + Dummy := Ord(FStyle); + WriteBuffer(Dummy, SizeOf(Dummy)); + // TFont has no own save routine so we do it manually + with Font do + begin + Dummy := Color; + WriteBuffer(Dummy, SizeOf(Dummy)); + + // Need only to write one: size or height, I decided to write height. + Dummy := Height; + WriteBuffer(Dummy, SizeOf(Dummy)); + Tmp := UTF8Encode(Name); + Dummy := Length(Tmp); + WriteBuffer(Dummy, SizeOf(Dummy)); + WriteBuffer(PAnsiChar(Tmp)^, Dummy); + Dummy := Ord(Pitch); + WriteBuffer(Dummy, SizeOf(Dummy)); + Dummy := Byte(Style); + WriteBuffer(Dummy, SizeOf(Dummy)); + end; + + // Data introduced by stream version 1. + Dummy := FMainColumn; + WriteBuffer(Dummy, SizeOf(Dummy)); + Dummy := FSortColumn; + WriteBuffer(Dummy, SizeOf(Dummy)); + Dummy := Byte(FSortDirection); + WriteBuffer(Dummy, SizeOf(Dummy)); + + // Data introduced by stream version 5. + Dummy := Integer(ParentFont); + WriteBuffer(Dummy, SizeOf(Dummy)); + Dummy := Integer(FMaxHeight); + WriteBuffer(Dummy, SizeOf(Dummy)); + Dummy := Integer(FMinHeight); + WriteBuffer(Dummy, SizeOf(Dummy)); + Dummy := Integer(FDefaultHeight); + WriteBuffer(Dummy, SizeOf(Dummy)); + with FFixedAreaConstraints do + begin + Dummy := Integer(FMaxHeightPercent); + WriteBuffer(Dummy, SizeOf(Dummy)); + Dummy := Integer(FMaxWidthPercent); + WriteBuffer(Dummy, SizeOf(Dummy)); + Dummy := Integer(FMinHeightPercent); + WriteBuffer(Dummy, SizeOf(Dummy)); + Dummy := Integer(FMinWidthPercent); + WriteBuffer(Dummy, SizeOf(Dummy)); + end; + end; +end; + +//----------------- TScrollBarOptions ---------------------------------------------------------------------------------- + +constructor TScrollBarOptions.Create(AOwner: TBaseVirtualTree); + +begin + inherited Create; + + FOwner := AOwner; + FAlwaysVisible := False; + FScrollBarStyle := sbmRegular; + FScrollBars := ssBoth; + FIncrementX := 20; + FIncrementY := 20; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TScrollBarOptions.SetAlwaysVisible(Value: Boolean); + +begin + if FAlwaysVisible <> Value then + begin + FAlwaysVisible := Value; + if not (csLoading in FOwner.ComponentState) and FOwner.HandleAllocated then + FOwner.RecreateWnd; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TScrollBarOptions.SetScrollBars(Value: TScrollStyle); + +begin + if FScrollBars <> Value then + begin + FScrollBars := Value; + if not (csLoading in FOwner.ComponentState) and FOwner.HandleAllocated then + FOwner.RecreateWnd; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TScrollBarOptions.SetScrollBarStyle(Value: TScrollBarStyle); + +begin + if FScrollBarStyle <> Value then + begin + FScrollBarStyle := Value; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TScrollBarOptions.GetOwner: TPersistent; + +begin + Result := FOwner; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TScrollBarOptions.Assign(Source: TPersistent); + +begin + if Source is TScrollBarOptions then + begin + AlwaysVisible := TScrollBarOptions(Source).AlwaysVisible; + HorizontalIncrement := TScrollBarOptions(Source).HorizontalIncrement; + ScrollBars := TScrollBarOptions(Source).ScrollBars; + ScrollBarStyle := TScrollBarOptions(Source).ScrollBarStyle; + VerticalIncrement := TScrollBarOptions(Source).VerticalIncrement; + end + else + inherited; +end; + +//----------------- TVTColors ------------------------------------------------------------------------------------------ + +constructor TVTColors.Create(AOwner: TBaseVirtualTree); +var + CE : TVTColorEnum; +begin + FOwner := AOwner; + for CE := Low(TVTColorEnum) to High(TVTColorEnum) do + FColors[CE] := cDefaultColors[CE]; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTColors.GetBackgroundColor: TColor; +begin +// XE2 VCL Style + if FOwner.VclStyleEnabled and (seClient in FOwner.StyleElements) then + Result := StyleServices.GetStyleColor(scTreeView) + else + Result := FOwner.Color; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTColors.GetColor(const Index: TVTColorEnum): TColor; +begin + // Only try to fetch the color via StyleServices if theses are enabled + // Return default/user defined color otherwise + if FOwner.VclStyleEnabled then + begin + // If the ElementDetails are not defined, fall back to the SystemColor + case Index of + cDisabledColor: + if not StyleServices.GetElementColor(StyleServices.GetElementDetails(ttItemDisabled), ecTextColor, Result) then + Result := StyleServices.GetSystemColor(FColors[Index]); + cTreeLineColor: + if not StyleServices.GetElementColor(StyleServices.GetElementDetails(ttBranch), ecBorderColor, Result) then + Result := StyleServices.GetSystemColor(FColors[Index]); + cBorderColor: + if (seBorder in FOwner.StyleElements) then + Result := StyleServices.GetSystemColor(FColors[Index]) + else + Result := FColors[Index]; + cHotColor: + if not StyleServices.GetElementColor(StyleServices.GetElementDetails(ttItemHot), ecTextColor, Result) then + Result := StyleServices.GetSystemColor(FColors[Index]); + cHeaderHotColor: + if not StyleServices.GetElementColor(StyleServices.GetElementDetails(thHeaderItemHot), ecTextColor, Result) then + Result := StyleServices.GetSystemColor(FColors[Index]); + cSelectionTextColor: + if not StyleServices.GetElementColor(StyleServices.GetElementDetails(ttItemSelected), ecTextColor, Result) then + Result := StyleServices.GetSystemColor(clHighlightText); + cUnfocusedColor: + if not StyleServices.GetElementColor(StyleServices.GetElementDetails(ttItemSelectedNotFocus), ecTextColor, Result) then + Result := StyleServices.GetSystemColor(FColors[Index]); + else + Result := StyleServices.GetSystemColor(FColors[Index]); + end; + end + else + Result := FColors[Index]; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTColors.GetHeaderFontColor: TColor; +begin +// XE2+ VCL Style + if FOwner.VclStyleEnabled and (seFont in FOwner.StyleElements) then + StyleServices.GetElementColor(StyleServices.GetElementDetails(thHeaderItemNormal), ecTextColor, Result) + else + Result := FOwner.Header.Font.Color; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTColors.GetNodeFontColor: TColor; +begin + if FOwner.VclStyleEnabled and (seFont in FOwner.StyleElements) then + StyleServices.GetElementColor(StyleServices.GetElementDetails(ttItemNormal), ecTextColor, Result) + else + Result := FOwner.Font.Color; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTColors.GetSelectedNodeFontColor(Focused: boolean): TColor; +begin + if Focused then begin + if (tsUseExplorerTheme in FOwner.TreeStates) and not IsHighContrastEnabled then begin + Result := NodeFontColor + end + else + Result := SelectionTextColor + end// if Focused + else + Result := UnfocusedColor; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTColors.SetColor(const Index: TVTColorEnum; const Value: TColor); + +begin + if FColors[Index] <> Value then + begin + FColors[Index] := Value; + if not (csLoading in FOwner.ComponentState) and FOwner.HandleAllocated then + begin + // Cause helper bitmap rebuild if the button color changed. + case Index of + cTreeLineColor: + begin + FOwner.PrepareBitmaps(True, False); + FOwner.Invalidate; + end; + cBorderColor: + RedrawWindow(FOwner.Handle, nil, 0, RDW_FRAME or RDW_INVALIDATE or RDW_NOERASE or RDW_NOCHILDREN) + else + FOwner.Invalidate; + end; + end; + end; +end; + +function TVTColors.StyleServices(AControl: TControl): TCustomStyleServices; +begin + if AControl = nil then + AControl := fOwner; + Result := VTStyleServices(AControl); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTColors.Assign(Source: TPersistent); + +begin + if Source is TVTColors then + begin + FColors := TVTColors(Source).FColors; + if FOwner.UpdateCount = 0 then + FOwner.Invalidate; + end + else + inherited; +end; //----------------- TClipboardFormats ---------------------------------------------------------------------------------- @@ -4439,7 +12968,8 @@ begin Pen.Color := FColors.UnfocusedSelectionBorderColor; end; - RoundRect(R.Left, R.Top, R.Right, R.Bottom, FSelectionCurveRadius, FSelectionCurveRadius); + with TWithSafeRect(R) do + RoundRect(Left, Top, Right, Bottom, FSelectionCurveRadius, FSelectionCurveRadius); end else begin @@ -4811,7 +13341,7 @@ begin begin FDragManager := DoCreateDragManager; if FDragManager = nil then - FDragManager := TVTDragManager.Create(Self) as IVTDragManager; + FDragManager := TVTDragManager.Create(Self); end; Result := FDragManager; @@ -7270,7 +15800,7 @@ begin FEffectiveOffsetX := 0; if toAutoBidiColumnOrdering in FOptions.AutoOptions then - TVirtualTreeColumnsCracker(FHeader.Columns).ReorderColumns(UseRightToLeftAlignment); + FHeader.Columns.ReorderColumns(UseRightToLeftAlignment); FHeader.Invalidate(nil); end; @@ -7436,7 +15966,7 @@ begin HeaderMessage.WParam := 0; HeaderMessage.LParam := 0; HeaderMessage.Result := 0; - TVTHeaderCracker(FHeader).HandleMessage(HeaderMessage); + FHeader.HandleMessage(HeaderMessage); end; //---------------------------------------------------------------------------------------------------------------------- @@ -7500,7 +16030,7 @@ begin CursorRect := FHeaderRect; // Convert the cursor rectangle into real client coordinates. OffsetRect(CursorRect, 0, -Integer(FHeader.Height)); - HitInfo.HitColumn := TVirtualTreeColumnsCracker(FHeader.Columns).GetColumnAndBounds(CursorPos, CursorRect.Left, CursorRect.Right); + HitInfo.HitColumn := FHeader.Columns.GetColumnAndBounds(CursorPos, CursorRect.Left, CursorRect.Right); if (HitInfo.HitColumn > NoColumn) and not (csLButtonDown in ControlState) and (FHeader.Columns[HitInfo.HitColumn].Hint <> '') then HintStr := FHeader.Columns[HitInfo.HitColumn].Hint; @@ -7523,7 +16053,7 @@ begin CursorRect := FHeaderRect; // Convert the cursor rectangle into real client coordinates. OffsetRect(CursorRect, 0, -Integer(FHeader.Height)); - HitInfo.HitColumn := TVirtualTreeColumnsCracker(FHeader.Columns).GetColumnAndBounds(CursorPos, CursorRect.Left, CursorRect.Right); + HitInfo.HitColumn := FHeader.Columns.GetColumnAndBounds(CursorPos, CursorRect.Left, CursorRect.Right); // align the vertical hint position on the bottom bound of the header, but // avoid overlapping of mouse cursor and hint HintPos.Y := Max(HintPos.Y, ClientToScreen(Point(0, CursorRect.Bottom)).Y); @@ -7537,7 +16067,7 @@ begin with FHeader.Columns[HitInfo.HitColumn] do begin if (2 * FMargin + CaptionWidth + 1) >= Width then - HintStr := CaptionText; + HintStr := FCaptionText; end; if HintStr <> '' then ShowOwnHint := True @@ -7749,12 +16279,9 @@ begin if Assigned(Header) then begin - with TVirtualTreeColumnsCracker(Header.Columns) do - begin - DownIndex := NoColumn; - HoverIndex := NoColumn; - CheckBoxHit := False; - end; + Header.FColumns.DownIndex := NoColumn; + Header.FColumns.HoverIndex := NoColumn; + Header.FColumns.CheckBoxHit := False; end; DoMouseLeave(); inherited; @@ -7809,10 +16336,7 @@ begin else begin SystemParametersInfo(SPI_GETWHEELSCROLLLINES, 0, @ScrollLines, 0); - if ScrollLines = WHEEL_PAGESCROLL then - ScrollAmount := Trunc(WheelFactor * (ClientWidth - FHeader.Columns.GetVisibleFixedWidth)) - else - ScrollAmount := Integer(Trunc(WheelFactor * ScrollLines * FHeader.Columns.GetScrollWidth)); + ScrollAmount := Trunc(WheelFactor * ScrollLines * FHeader.Columns.GetScrollWidth); end; SetOffsetX(FOffsetX + RTLFactor * ScrollAmount); end; @@ -7889,8 +16413,8 @@ begin if vsExpanded in Node.States then Item.state := Item.state or TVIS_EXPANDED; - // Construct state image and overlay image indices. They are one based, btw. - // and zero means there is no image. + // Construct state image and overlay image indices. They are zero based, btw. + // and -1 means there is no image. ImageIndex := -1; DoGetImageIndex(Node, ikState, -1, Ghosted, ImageIndex); Item.state := Item.state or Byte(IndexToStateImageMask(ImageIndex + 1)); @@ -9104,7 +17628,7 @@ begin with FHeader do if hoVisible in FHeader.Options then with Message.CalcSize_Params^ do - Inc(rgrc[0].Top, Height); + Inc(rgrc[0].Top, FHeight); end; //---------------------------------------------------------------------------------------------------------------------- @@ -9391,7 +17915,7 @@ begin if (CursorWnd = Handle) and ([tsWheelPanning, tsWheelScrolling] * FStates = []) then begin - if not TVTHeaderCracker(FHeader).HandleMessage(TMessage(Message)) then + if not FHeader.HandleMessage(TMessage(Message)) then begin // Apply own cursors only if there is no global cursor set. if Screen.Cursor = crDefault then @@ -9414,7 +17938,7 @@ begin Node := HitInfo.HitNode; if CanSplitterResizeNode(P, Node, HitInfo.HitColumn) then - NewCursor := crVSplit; + NewCursor := crVertSplit; end; end; @@ -9465,8 +17989,8 @@ begin try DoStateChange([tsSizing]); // This call will invalidate the entire non-client area which needs recalculation on resize. - TVTHeaderCracker(FHeader).RescaleHeader; - TVTHeaderCracker(FHeader).UpdateSpringColumns; + FHeader.RescaleHeader; + FHeader.UpdateSpringColumns; UpdateScrollBars(True); if (tsEditing in FStates) and not FHeader.UseColumns then @@ -10025,7 +18549,7 @@ begin else Flags := DefaultScalingFlags; // Important for #677 if (sfHeight in Flags) then begin - TVTHeaderCracker(FHeader).ChangeScale(M, D, {$if CompilerVersion >= 31}isDpiChange{$ELSE} M <> D{$ifend}); + FHeader.ChangeScale(M, D, {$if CompilerVersion >= 31}isDpiChange{$ELSE} M <> D{$ifend}); SetDefaultNodeHeight(MulDiv(FDefaultNodeHeight, M, D)); Indent := MulDiv(Indent, M, D); FTextMargin := MulDiv(FTextMargin, M, D); @@ -10068,8 +18592,7 @@ begin Run.NodeHeight := MulDiv(Run.NodeHeight, M, D); // The next three lines fix issue #1000 lNewNodeTotalHeight := MulDiv(Run.TotalHeight, M, D); - FRoot.TotalHeight := FRoot.TotalHeight + lNewNodeTotalHeight - Run.TotalHeight; // 1 EIntOverflow exception seen here in debug build in 01/2021 - Run.TotalHeight := lNewNodeTotalHeight; + FRoot.TotalHeight := Cardinal(Int64(FRoot.TotalHeight) + Int64(lNewNodeTotalHeight) - Int64(Run.TotalHeight)); // Avoiding EIntOverflow exception. end; Run := GetNextNoInit(Run); end; // while @@ -10280,7 +18803,7 @@ begin with Params do begin - Style := Style or WS_CLIPCHILDREN or WS_CLIPSIBLINGS or ScrollBar[ScrollBarOptions.ScrollBars]; + Style := Style or WS_CLIPCHILDREN or WS_CLIPSIBLINGS or ScrollBar[ScrollBarOptions.FScrollBars]; if toFullRepaintOnResize in FOptions.MiscOptions then WindowClass.style := WindowClass.style or CS_HREDRAW or CS_VREDRAW else @@ -10334,9 +18857,9 @@ begin // Because of the special recursion and update stopper when creating the window (or resizing it) // we have to manually trigger the auto size calculation here. if hsNeedScaling in FHeader.States then - TVTHeaderCracker(FHeader).RescaleHeader; + FHeader.RescaleHeader; if hoAutoResize in FHeader.Options then - TVirtualTreeColumnsCracker(FHeader.Columns).AdjustAutoSize(InvalidColumn); + FHeader.Columns.AdjustAutoSize(InvalidColumn); PrepareBitmaps(True, True); @@ -10358,11 +18881,6 @@ begin end; -procedure TBaseVirtualTree.DecVisibleCount; -begin - Dec(FVisibleCount); -end; - procedure TBaseVirtualTree.DefineProperties(Filer: TFiler); // There were heavy changes in some properties during development of VT. This method helps to make migration easier @@ -10378,7 +18896,7 @@ begin inherited; // The header can prevent writing columns altogether. - if TVTHeaderCracker(FHeader).CanWriteColumns then + if FHeader.CanWriteColumns then begin // Check if we inherit from an ancestor form (Visual Form Inheritance). StoreIt := Filer.Ancestor = nil; @@ -10389,7 +18907,7 @@ begin else StoreIt := False; - Filer.DefineProperty('Columns', TVTHeaderCracker(FHeader).ReadColumns, TVTHeaderCracker(FHeader).WriteColumns, StoreIt); + Filer.DefineProperty('Columns', FHeader.ReadColumns, FHeader.WriteColumns, StoreIt); // #622 made old DFMs incompatible with new VTW - so the program is compiled successfully // and then suddenly crashes at user site in runtime. @@ -10412,11 +18930,8 @@ var begin ImageHit := HitInfo.HitPositions * [hiOnNormalIcon, hiOnStateIcon] <> []; LabelHit := hiOnItemLabel in HitInfo.HitPositions; - //VSOFT ======================================== - //VSOFT 5.0 chang broke our drag/drop line info. - //VSOFT CHANGE - changed back to 4.8.5 behaviour - ItemHit := (hiOnItem in HitInfo.HitPositions);{ and ((toFullRowDrag in FOptions.MiscOptions) or - (toFullRowSelect in FOptions.SelectionOptions));} + ItemHit := (hiOnItem in HitInfo.HitPositions) and ((toFullRowDrag in FOptions.MiscOptions) or + (toFullRowSelect in FOptions.SelectionOptions)); // In report mode only direct hits of the node captions/images in the main column are accepted as hits. if (toReportMode in FOptions.MiscOptions) and not (ItemHit or ((LabelHit or ImageHit) and @@ -12853,9 +21368,8 @@ begin begin FDropTargetNode := HitInfo.HitNode; R := GetDisplayRect(HitInfo.HitNode, FHeader.MainColumn, False); - //VSOFT CHANGE - changed back to 4.8.5 behaviour if (hiOnItemLabel in HitInfo.HitPositions) or ((hiOnItem in HitInfo.HitPositions) and - ((toFullRowDrag in FOptions.MiscOptions){ or (toFullRowSelect in FOptions.SelectionOptions)}))then + ((toFullRowDrag in FOptions.MiscOptions) or (toFullRowSelect in FOptions.SelectionOptions)))then FLastDropMode := dmOnNode else if ((R.Top + R.Bottom) div 2) > Pt.Y then @@ -13020,7 +21534,7 @@ begin NewDropMode := DetermineDropMode(Pt, HitInfo, R); if Assigned(Tree) then - DragImageWillMove := Tree.DragImage.WillMove(DragPos) + DragImageWillMove := Tree.FDragImage.WillMove(DragPos) else DragImageWillMove := False; @@ -13918,7 +22432,7 @@ begin FSearchBuffer := NewSearchText; FLastSearchNode := Run; FocusedNode := Run; - AddToSelection(Run, False); + Selected[Run] := True; FLastSearchNode := Run; end else @@ -13952,7 +22466,7 @@ begin if not (tsEditing in FStates) or DoEndEdit then begin - if HitInfo.HitColumn = FHeader.Columns.ClickIndex then + if HitInfo.HitColumn = FHeader.Columns.FClickIndex then DoColumnDblClick(HitInfo.HitColumn, KeysToShiftState(Message.Keys)); if HitInfo.HitNode <> nil then @@ -14124,10 +22638,10 @@ begin end; if IsEmpty then - Exit; // Nothing to do + exit; // Keep clicked column in case the application needs it. - FHeader.Columns.ClickIndex := HitInfo.HitColumn; + FHeader.Columns.FClickIndex := HitInfo.HitColumn; // Change column only if we have hit the node label. if (hiOnItemLabel in HitInfo.HitPositions) or @@ -14426,7 +22940,7 @@ begin tsScrollPending, tsScrolling]); StopTimer(ScrollTimer); - if (FHeader.Columns.ClickIndex > NoColumn) and (FHeader.Columns.ClickIndex = HitInfo.HitColumn) then + if (FHeader.Columns.FClickIndex > NoColumn) and (FHeader.Columns.FClickIndex = HitInfo.HitColumn) then DoColumnClick(HitInfo.HitColumn, KeysToShiftState(Message.Keys)); if FLastHitInfo.HitNode <> nil then begin // Use THitInfo of mouse down here, see issue #692 @@ -14489,13 +23003,6 @@ end; //---------------------------------------------------------------------------------------------------------------------- -procedure TBaseVirtualTree.IncVisibleCount; -begin - Inc(FVisibleCount); -end; - -//---------------------------------------------------------------------------------------------------------------------- - procedure TBaseVirtualTree.InitChildren(Node: PVirtualNode); // Initiates the initialization of the child number of the given node. @@ -15122,11 +23629,6 @@ begin end; end; -procedure TBaseVirtualTree.InternalSetFocusedColumn(const index: TColumnIndex); -begin - FFocusedColumn := index; -end; - //---------------------------------------------------------------------------------------------------------------------- procedure TBaseVirtualTree.InvalidateCache; @@ -15199,18 +23701,18 @@ begin // when auto resize is enabled. Updating; try - TVTHeaderCracker(FHeader).UpdateMainColumn; - TVirtualTreeColumnsCracker(FHeader.Columns).FixPositions; + FHeader.UpdateMainColumn; + FHeader.Columns.FixPositions; if toAutoBidiColumnOrdering in FOptions.AutoOptions then - TVirtualTreeColumnsCracker(FHeader.Columns).ReorderColumns(UseRightToLeftAlignment); + FHeader.Columns.ReorderColumns(UseRightToLeftAlignment); // Because of the special recursion and update stopper when creating the window (or resizing it) // we have to manually trigger the auto size calculation here. if hsNeedScaling in FHeader.States then - TVTHeaderCracker(FHeader).RescaleHeader + FHeader.RescaleHeader else - TVTHeaderCracker(FHeader).RecalculateHeader; + FHeader.RecalculateHeader; if hoAutoResize in FHeader.Options then - TVirtualTreeColumnsCracker(FHeader.Columns).AdjustAutoSize(InvalidColumn, True); + FHeader.Columns.AdjustAutoSize(InvalidColumn, True); finally Updated; end; @@ -15288,7 +23790,8 @@ begin if tsNodeHeightTracking in FStates then begin // Handle height tracking. - if DoNodeHeightTracking(FHeightTrackNode, FHeightTrackColumn, TVTHeaderCracker(FHeader).GetShiftState, FHeightTrackPoint, Point(X, Y)) then + if DoNodeHeightTracking(FHeightTrackNode, FHeightTrackColumn, FHeader.GetShiftState, + FHeightTrackPoint, Point(X, Y)) then begin // Avoid negative (or zero) node heights. if FHeightTrackPoint.Y >= Y then @@ -15432,14 +23935,17 @@ begin Inc(EdgeSize, BevelWidth); if BevelOuter <> bvNone then Inc(EdgeSize, BevelWidth); - if beLeft in BevelEdges then - Inc(RC.Left, EdgeSize); - if beTop in BevelEdges then - Inc(RC.Top, EdgeSize); - if beRight in BevelEdges then - Dec(RC.Right, EdgeSize); - if beBottom in BevelEdges then - Dec(RC.Bottom, EdgeSize); + with TWithSafeRect(RC) do + begin + if beLeft in BevelEdges then + Inc(Left, EdgeSize); + if beTop in BevelEdges then + Inc(Top, EdgeSize); + if beRight in BevelEdges then + Dec(Right, EdgeSize); + if beBottom in BevelEdges then + Dec(Bottom, EdgeSize); + end; end; // Repaint only the part in the original clipping region and not yet drawn parts. @@ -16011,17 +24517,20 @@ begin begin case Alignment of taLeftJustify: - if InnerRect.Left + NodeWidth < InnerRect.Right then - InnerRect.Right := InnerRect.Left + NodeWidth; + with TWithSafeRect(InnerRect) do + if Left + NodeWidth < Right then + Right := Left + NodeWidth; taCenter: - if (InnerRect.Right - InnerRect.Left) > NodeWidth then - begin - InnerRect.Left := (InnerRect.Left + InnerRect.Right - NodeWidth) div 2; - InnerRect.Right := InnerRect.Left + NodeWidth; - end; + with TWithSafeRect(InnerRect) do + if (Right - Left) > NodeWidth then + begin + Left := (Left + Right - NodeWidth) div 2; + Right := Left + NodeWidth; + end; taRightJustify: - if (InnerRect.Right - InnerRect.Left) > NodeWidth then - InnerRect.Left := InnerRect.Right - NodeWidth; + with TWithSafeRect(InnerRect) do + if (Right - Left) > NodeWidth then + Left := Right - NodeWidth; end; end; @@ -16047,7 +24556,8 @@ begin if (toUseBlendedSelection in FOptions.PaintOptions) then AlphaBlendSelection(Brush.Color) else - RoundRect(InnerRect.Left, InnerRect.Top, InnerRect.Right, InnerRect.Bottom, FSelectionCurveRadius, FSelectionCurveRadius); + with TWithSafeRect(InnerRect) do + RoundRect(Left, Top, Right, Bottom, FSelectionCurveRadius, FSelectionCurveRadius); end else begin @@ -16081,7 +24591,8 @@ begin if (toUseBlendedSelection in FOptions.PaintOptions) then AlphaBlendSelection(Brush.Color) else - RoundRect(InnerRect.Left, InnerRect.Top, InnerRect.Right, InnerRect.Bottom, FSelectionCurveRadius, FSelectionCurveRadius); + with TWithSafeRect(InnerRect) do + RoundRect(Left, Top, Right, Bottom, FSelectionCurveRadius, FSelectionCurveRadius); end; end; end; @@ -17314,7 +25825,7 @@ begin // Try the header whether it needs to take this message. if Assigned(FHeader) and (FHeader.States <> []) then - Handled := TVTHeaderCracker(FHeader).HandleMessage(Message); + Handled := FHeader.HandleMessage(Message); if not Handled then begin // For auto drag mode, let tree handle itself, instead of TControl. @@ -17335,7 +25846,7 @@ begin end; if not Handled and Assigned(FHeader) then - Handled := TVTHeaderCracker(FHeader).HandleMessage(Message); + Handled := FHeader.HandleMessage(Message); if not Handled then begin @@ -18068,14 +26579,11 @@ end; //---------------------------------------------------------------------------------------------------------------------- -procedure TBaseVirtualTree.CutToClipboard(); -var - lDataObject: IDataObject; +procedure TBaseVirtualTree.CutToClipboard; begin if (FSelectionCount > 0) and not (toReadOnly in FOptions.MiscOptions) then begin - lDataObject := TVTDataObject.Create(Self, True); - if OleSetClipboard(lDataObject) = S_OK then + if OleSetClipboard(TVTDataObject.Create(Self, True)) = S_OK then begin MarkCutCopyNodes; DoStateChange([tsCutPending], [tsCopyPending]); @@ -18249,10 +26757,7 @@ begin if not ParentClearing then begin - if FUpdateCount = 0 then - DetermineHiddenChildrenFlag(LastParent) - else - Include(FStates, tsUpdateHiddenChildrenNeeded); + DetermineHiddenChildrenFlag(LastParent); InvalidateCache; if FUpdateCount = 0 then begin @@ -19284,7 +27789,7 @@ begin if FHeader.UseColumns then begin - HitInfo.HitColumn := TVirtualTreeColumnsCracker(FHeader.Columns).GetColumnAndBounds(Point(X, Y), ColLeft, ColRight, False); + HitInfo.HitColumn := FHeader.Columns.GetColumnAndBounds(Point(X, Y), ColLeft, ColRight, False); // If auto column spanning is enabled then look for the last non empty column. if toAutoSpanColumns in FOptions.AutoOptions then begin @@ -19462,16 +27967,6 @@ end; //---------------------------------------------------------------------------------------------------------------------- -function TBaseVirtualTree.GetLastSelected(ConsiderChildrenAbove: Boolean = False): PVirtualNode; - -// Returns the last node in the current selection while optionally considering toChildrenAbove. - -begin - Result := GetPreviousSelected(nil, ConsiderChildrenAbove); -end; - -//---------------------------------------------------------------------------------------------------------------------- - function TBaseVirtualTree.GetLastVisible(Node: PVirtualNode = nil; ConsiderChildrenAbove: Boolean = True; IncludeFiltered: Boolean = False): PVirtualNode; @@ -20690,7 +29185,7 @@ begin if FSelectionCount > 0 then begin if (Node = nil) or (Node = FRoot) then - Result := GetLastNoInit(nil, ConsiderChildrenAbove) + Result := FRoot.LastChild else Result := GetPreviousNoInit(Node, ConsiderChildrenAbove); while Assigned(Result) and not (vsSelected in Result.States) do @@ -22230,14 +30725,14 @@ begin InitializeFirstColumnValues(PaintInfo); // Now go through all visible columns (there's still one run if columns aren't used). - with TVirtualTreeColumnsCracker(FHeader.Columns) do + with FHeader.Columns do begin while ((PaintInfo.Column > InvalidColumn) or not UseColumns) and (PaintInfo.CellRect.Left < Window.Right) do begin if UseColumns then begin - PaintInfo.Column := PositionToIndex[PaintInfo.Position]; + PaintInfo.Column := FPositionToIndex[PaintInfo.Position]; if FirstColumn = InvalidColumn then FirstColumn := PaintInfo.Column; PaintInfo.BidiMode := Items[PaintInfo.Column].BiDiMode; @@ -22321,7 +30816,7 @@ begin begin if BidiMode = bdLeftToRight then begin - DrawDottedHLine(PaintInfo, CellRect.Left + PaintInfo.Offsets[ofsCheckBox] - fImagesMargin, CellRect.Right - 1, CellRect.Bottom - 1); + DrawDottedHLine(PaintInfo, CellRect.Left + PaintInfo.Offsets[ofsCheckBox] - fImagesMargin, CellRect.Right - 1, CellRect.Bottom - 1); end else begin @@ -22432,7 +30927,7 @@ begin if coVisible in Items[NextColumn].Options then with PaintInfo do begin - TVirtualTreeColumnCracker(Items[NextColumn]).GetAbsoluteBounds(CellRect.Left, CellRect.Right); + Items[NextColumn].GetAbsoluteBounds(CellRect.Left, CellRect.Right); CellRect.Bottom := Node.NodeHeight; ContentRect.Bottom := Node.NodeHeight; end; @@ -22462,8 +30957,8 @@ begin // Put the constructed node image onto the target canvas. if not (poUnbuffered in PaintOptions) then - with NodeBitmap do - BitBlt(TargetCanvas.Handle, TargetRect.Left, TargetRect.Top, TargetRect.Width, TargetRect.Height, Canvas.Handle, Window.Left, 0, SRCCOPY); + with TWithSafeRect(TargetRect), NodeBitmap do + BitBlt(TargetCanvas.Handle, Left, Top, Width, Height, Canvas.Handle, Window.Left, 0, SRCCOPY); end; end; @@ -22705,20 +31200,23 @@ begin // Check that we have a valid rectangle. PaintRect := TreeRect; - if TreeRect.Left < 0 then + with TWithSafeRect(TreeRect) do begin - PaintTarget.X := -TreeRect.Left; - PaintRect.Left := 0; - end - else - PaintTarget.X := 0; - if TreeRect.Top < 0 then - begin - PaintTarget.Y := -TreeRect.Top; - PaintRect.Top := 0; - end - else - PaintTarget.Y := 0; + if Left < 0 then + begin + PaintTarget.X := -Left; + PaintRect.Left := 0; + end + else + PaintTarget.X := 0; + if Top < 0 then + begin + PaintTarget.Y := -Top; + PaintRect.Top := 0; + end + else + PaintTarget.Y := 0; + end; Image := TBitmap.Create; with Image do @@ -23195,7 +31693,7 @@ begin InitNode(Node); end; - if Recursive then + if Recursive and (Node.ChildCount > 0) then // Prevent previoulsy uninitilaized children from being initialized. Issue #1145 ReinitChildren(Node, True); end; @@ -23312,7 +31810,6 @@ var Run: PVirtualNode; UseColumns, HScrollBarVisible: Boolean; - OldOffsetY: Integer; ScrolledVertically, ScrolledHorizontally: Boolean; @@ -23338,13 +31835,13 @@ begin // The returned rectangle can never be empty after the expand code above. // 1) scroll vertically - OldOffsetY := FOffsetY; if R.Top < 0 then begin if Center then SetOffsetY(FOffsetY - R.Top + ClientHeight div 2) else SetOffsetY(FOffsetY - R.Top); + ScrolledVertically := True; end else if (R.Bottom > ClientHeight) or Center then @@ -23360,8 +31857,8 @@ begin // in order to avoid that the scroll bar hides the node which we wanted to have in view. if not UseColumns and not HScrollBarVisible and (Integer(FRangeX) > ClientWidth) then SetOffsetY(FOffsetY - GetSystemMetrics(SM_CYHSCROLL)); + ScrolledVertically := True; end; - ScrolledVertically := OldOffsetY <> FOffsetY; if Horizontally then // 2) scroll horizontally @@ -23389,8 +31886,7 @@ function TBaseVirtualTree.ScrollIntoView(Column: TColumnIndex; Center: Boolean; var ColumnLeft, ColumnRight: Integer; - NewOffset, - OldOffset: Integer; + NewOffset: Integer; R: TRect; begin @@ -23407,7 +31903,6 @@ begin end else Exit; - OldOffset := FOffsetX; NewOffset := FEffectiveOffsetX; if not (FHeader.UseColumns and (coFixed in Header.Columns[Column].Options)) and (not Center) then begin @@ -23423,6 +31918,7 @@ begin else SetOffsetX(-NewOffset); end; + Result := True; end else if Center then begin @@ -23434,8 +31930,8 @@ begin else SetOffsetX(-NewOffset); end; - end; - Result := OldOffset <> FOffsetX; + Result := True; + end end; //---------------------------------------------------------------------------------------------------------------------- @@ -24438,6 +32934,654 @@ begin end; end; +//----------------- TCustomStringTreeOptions --------------------------------------------------------------------------- + +constructor TCustomStringTreeOptions.Create(AOwner: TBaseVirtualTree); + +begin + inherited; + + FStringOptions := DefaultStringOptions; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TCustomStringTreeOptions.SetStringOptions(const Value: TVTStringOptions); + +var + ChangedOptions: TVTStringOptions; + +begin + if FStringOptions <> Value then + begin + // Exclusive ORing to get all entries wich are in either set but not in both. + ChangedOptions := FStringOptions + Value - (FStringOptions * Value); + FStringOptions := Value; + with FOwner do + if (toShowStaticText in ChangedOptions) and not (csLoading in ComponentState) and HandleAllocated then + Invalidate; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TCustomStringTreeOptions.AssignTo(Dest: TPersistent); + +begin + if Dest is TCustomStringTreeOptions then + begin + with Dest as TCustomStringTreeOptions do + begin + StringOptions := Self.StringOptions; + EditOptions := Self.EditOptions; + end; + end; + + // Let ancestors assign their options to the destination class. + inherited; +end; + +//----------------- TVTEdit -------------------------------------------------------------------------------------------- + +// Implementation of a generic node caption editor. + +constructor TVTEdit.Create(Link: TStringEditLink); + +begin + inherited Create(nil); + if not Assigned(Link) then + raise EArgumentException.Create('Paramter Link must not be nil.'); + ShowHint := False; + ParentShowHint := False; + // This assignment increases the reference count for the interface. + FRefLink := Link; + // This reference is used to access the link. + FLink := Link; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTEdit.ClearLink; +begin + FLink := nil +end; + +//---------------------------------------------------------------------------------------------------------------------- +procedure TVTEdit.ClearRefLink; +begin + FRefLink := nil +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTEdit.CalcMinHeight: Integer; +var + textHeight : Integer; +begin + // Get the actual text height. + textHeight := GetTextSize.cy; + // The minimal height is the actual text height in pixels plus the the non client area. + Result := textHeight + (Height - ClientHeight); + // Also, proportionally to the text size, additional pixel(s) needs to be added for the caret. + Result := Result + Trunc(textHeight * 0.05); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTEdit.CMAutoAdjust(var Message: TMessage); + +begin + AutoAdjustSize; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTEdit.CMExit(var Message: TMessage); + +begin + if Assigned(FLink) and not FLink.Stopping then + with FLink, FTree do + begin + if (toAutoAcceptEditChange in TreeOptions.StringOptions) then + DoEndEdit + else + DoCancelEdit; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTEdit.CMRelease(var Message: TMessage); + +begin + Free; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTEdit.CNCommand(var Message: TWMCommand); + +begin + if Assigned(FLink) and Assigned(FLink.Tree) and (Message.NotifyCode = EN_UPDATE) and + not (vsMultiline in FLink.Node.States) then + // Instead directly calling AutoAdjustSize it is necessary on Win9x/Me to decouple this notification message + // and eventual resizing. Hence we use a message to accomplish that. + AutoAdjustSize() + else + inherited; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTEdit.WMChar(var Message: TWMChar); + +begin + if not (Message.CharCode in [VK_ESCAPE, VK_TAB]) then + inherited; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTEdit.WMDestroy(var Message: TWMDestroy); + +begin + // If editing stopped by other means than accept or cancel then we have to do default processing for + // pending changes. + if Assigned(FLink) and not FLink.Stopping and not (csRecreating in Self.ControlState) then + begin + with FLink, FTree do + begin + if (toAutoAcceptEditChange in TreeOptions.StringOptions) and Modified then + Text[FNode, FColumn] := FEdit.Text; + end; + FLink := nil; + FRefLink := nil; + end; + + inherited; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTEdit.WMGetDlgCode(var Message: TWMGetDlgCode); + +begin + inherited; + + Message.Result := Message.Result or DLGC_WANTALLKEYS or DLGC_WANTTAB or DLGC_WANTARROWS; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTEdit.WMKeyDown(var Message: TWMKeyDown); + +// Handles some control keys. + +var + Shift: TShiftState; + EndEdit: Boolean; + Tree: TBaseVirtualTree; + NextNode: PVirtualNode; + ColumnCandidate: Integer; + EditOptions: TVTEditOptions; + Column: TVirtualTreeColumn; +begin + Tree := FLink.Tree; + case Message.CharCode of + VK_ESCAPE: + begin + Tree.DoCancelEdit; + end; + VK_RETURN: + begin + EndEdit := not (vsMultiline in FLink.Node.States); + if not EndEdit then + begin + // If a multiline node is being edited the finish editing only if Ctrl+Enter was pressed, + // otherwise allow to insert line breaks into the text. + Shift := KeyDataToShiftState(Message.KeyData); + EndEdit := ssCtrl in Shift; + end; + if EndEdit then + begin + Tree := FLink.Tree; + FLink.Tree.InvalidateNode(FLink.Node); + NextNode := Tree.GetNextVisible(FLink.Node, True); + FLink.Tree.DoEndEdit; + + // get edit options for column as priority. If column has toDefaultEdit + // use global edit options for tree + EditOptions := Tree.TreeOptions.EditOptions; // default + ColumnCandidate := -1; + if Tree.Header.Columns.Count > 0 then // are there any columns? + begin + Column := Tree.Header.Columns[Tree.FocusedColumn]; + if Column.EditOptions <> toDefaultEdit then + EditOptions := Column.EditOptions; + + // next column candidate for toVerticalEdit and toHorizontalEdit + if Column.EditNextColumn <> -1 then + ColumnCandidate := Column.EditNextColumn; + end; + + case EditOptions of + toDefaultEdit: Tree.TrySetFocus; + toVerticalEdit: + if NextNode <> nil then + begin + Tree.FocusedNode := NextNode; + + // for toVerticalEdit ColumnCandidate is also proper, + // select ColumnCandidate column in row below + if ColumnCandidate <> -1 then + begin + Tree.FocusedColumn := ColumnCandidate; + Tree.EditColumn := ColumnCandidate; + end; + + if Tree.CanEdit(Tree.FocusedNode, Tree.FocusedColumn) then + Tree.DoEdit; + end; + toHorizontalEdit: + begin + if ColumnCandidate = -1 then + begin + // for toHorizontalEdit if property EditNextColumn is not used + // try to use just next column + ColumnCandidate := Tree.FocusedColumn+1; + while (ColumnCandidate < Tree.Header.Columns.Count) + and not Tree.CanEdit(Tree.FocusedNode, ColumnCandidate) + do + Inc(ColumnCandidate); + end + else + if not Tree.CanEdit(Tree.FocusedNode, ColumnCandidate) then + ColumnCandidate := Tree.Header.Columns.Count; // omit "focus/edit column" (see below) + + if ColumnCandidate < Tree.Header.Columns.Count then + begin + Tree.FocusedColumn := ColumnCandidate; + Tree.EditColumn := ColumnCandidate; + Tree.DoEdit; + end; + end; + end; + end; + end; + VK_UP: + begin + if not (vsMultiline in FLink.Node.States) then + Message.CharCode := VK_LEFT; + inherited; + end; + VK_DOWN: + begin + if not (vsMultiline in FLink.Node.States) then + Message.CharCode := VK_RIGHT; + inherited; + end; + VK_TAB: + begin + if Tree.IsEditing then + begin + Tree.InvalidateNode(FLink.Node); + if ssShift in KeyDataToShiftState(Message.KeyData) then + NextNode := Tree.GetPreviousVisible(FLink.Node, True) // Shift+Tab goes to previous mode + else + NextNode := Tree.GetNextVisible(FLink.Node, True); + Tree.EndEditNode; + // check NextNode, otherwise we got AV + if NextNode <> nil then + begin + // Continue editing next node + Tree.ClearSelection(); + Tree.Selected[NextNode] := True; + if Tree.CanEdit(Tree.FocusedNode, Tree.FocusedColumn) then + Tree.DoEdit; + end; + end; + end; + Ord('A'): + begin + if Tree.IsEditing and ([ssCtrl] = KeyboardStateToShiftState) then + begin + Self.SelectAll(); + Message.CharCode := 0; + end; + end; + else + inherited; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTEdit.AutoAdjustSize; + +// Changes the size of the edit to accomodate as much as possible of its text within its container window. +// NewChar describes the next character which will be added to the edit's text. + +var + Size: TSize; +begin + if not (vsMultiline in FLink.Node.States) and not (toGridExtensions in FLink.Tree.TreeOptions.MiscOptions{see issue #252}) then + begin + // avoid flicker + SendMessage(Handle, WM_SETREDRAW, 0, 0); + try + Size := GetTextSize; + Inc(Size.cx, 2 * FLink.Tree.FTextMargin); + // Repaint associated node if the edit becomes smaller. + if Size.cx < Width then + FLink.Tree.Invalidate(); + + if FLink.Alignment = taRightJustify then + FLink.SetBounds(Rect(Left + Width - Size.cx, Top, Left + Width, Top + Max(Size.cy, Height))) + else + FLink.SetBounds(Rect(Left, Top, Left + Size.cx, Top + Max(Size.cy, Height))); + finally + SendMessage(Handle, WM_SETREDRAW, 1, 0); + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTEdit.CreateParams(var Params: TCreateParams); + +begin + inherited; + if not Assigned(FLink.Node) then + exit; // Prevent AV exceptions occasionally seen in code below + + // Only with multiline style we can use the text formatting rectangle. + // This does not harm formatting as single line control, if we don't use word wrapping. + with Params do + begin + Style := Style or ES_MULTILINE; + if vsMultiline in FLink.Node.States then + Style := Style and not (ES_AUTOHSCROLL or WS_HSCROLL) or WS_VSCROLL or ES_AUTOVSCROLL; + if tsUseThemes in FLink.Tree.FStates then + begin + Style := Style and not WS_BORDER; + ExStyle := ExStyle or WS_EX_CLIENTEDGE; + end + else + begin + Style := Style or WS_BORDER; + ExStyle := ExStyle and not WS_EX_CLIENTEDGE; + end; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVTEdit.GetTextSize: TSize; +var + DC: HDC; + LastFont: THandle; +begin + DC := GetDC(Handle); + LastFont := SelectObject(DC, Font.Handle); + try + // Read needed space for the current text. + GetTextExtentPoint32(DC, PChar(Text+'yG'), Length(Text)+2, Result); + finally + SelectObject(DC, LastFont); + ReleaseDC(Handle, DC); + end; +end; + +procedure TVTEdit.KeyPress(var Key: Char); +begin + if (Key = #13) and Assigned(FLink) and not (vsMultiline in FLink.Node.States) then + Key := #0; // Filter out return keys as they will be added to the text, avoids #895 + inherited; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVTEdit.Release; + +begin + if HandleAllocated then + PostMessage(Handle, CM_RELEASE, 0, 0); +end; + +//----------------- TStringEditLink ------------------------------------------------------------------------------------ + +constructor TStringEditLink.Create; + +begin + inherited; + FEdit := TVTEdit.Create(Self); + with FEdit do + begin + Visible := False; + BorderStyle := bsSingle; + AutoSize := False; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +destructor TStringEditLink.Destroy; + +begin + if Assigned(FEdit) then + FEdit.Release; + inherited; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TStringEditLink.BeginEdit: Boolean; + +// Notifies the edit link that editing can start now. descendants may cancel node edit +// by returning False. + +begin + Result := not FStopping; + if Result then + begin + FEdit.Show; + FEdit.SelectAll; + FEdit.SetFocus; + FEdit.AutoAdjustSize; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TStringEditLink.SetEdit(const Value: TVTEdit); + +begin + if Assigned(FEdit) then + FEdit.Free; + FEdit := Value; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TStringEditLink.CancelEdit: Boolean; + +begin + Result := not FStopping; + if Result then + begin + FStopping := True; + FEdit.Hide; + FTree.CancelEditNode; + FEdit.ClearLink; + FEdit.ClearRefLink; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TStringEditLink.EndEdit: Boolean; + +begin + Result := not FStopping; + if Result then + try + FStopping := True; + if FEdit.Modified then + FTree.Text[FNode, FColumn] := FEdit.Text; + FEdit.Hide; + FEdit.ClearLink; + FEdit.ClearRefLink; + except + FStopping := False; + raise; + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TStringEditLink.GetBounds: TRect; + +begin + Result := FEdit.BoundsRect; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TStringEditLink.PrepareEdit(Tree: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex): Boolean; + +// Retrieves the true text bounds from the owner tree. + +var + Text: string; + +begin + Result := Tree is TCustomVirtualStringTree; + if Result then + begin + if not Assigned(FEdit) then + begin + FEdit := TVTEdit.Create(Self); + FEdit.Visible := False; + FEdit.BorderStyle := bsSingle; + end; + FEdit.AutoSize := True; + FTree := Tree as TCustomVirtualStringTree; + FNode := Node; + FColumn := Column; + FEdit.Parent := Tree; + // Initial size, font and text of the node. + FTree.GetTextInfo(Node, Column, FEdit.Font, FTextBounds, Text); + FEdit.Font.Color := clWindowText; + FEdit.RecreateWnd; + FEdit.AutoSize := False; + FEdit.Text := Text; + + if Column <= NoColumn then + begin + FEdit.BidiMode := FTree.BidiMode; + FAlignment := FTree.Alignment; + end + else + begin + FEdit.BidiMode := FTree.Header.Columns[Column].BidiMode; + FAlignment := FTree.Header.Columns[Column].Alignment; + end; + + if FEdit.BidiMode <> bdLeftToRight then + ChangeBidiModeAlignment(FAlignment); + end; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TStringEditLink.ProcessMessage(var Message: TMessage); + +begin + FEdit.WindowProc(Message); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TStringEditLink.SetBounds(R: TRect); + +// Sets the outer bounds of the edit control and the actual edit area in the control. + +var + lOffset, tOffset, height: Integer; + offsets : TVTOffsets; +begin + if not FStopping then + begin + // Check if the provided rect height is smaller than the edit control height. + height := R.Bottom - R.Top; + if height < FEdit.ClientHeight then + begin + // If the height is smaller than the minimal height we must correct it, otherwise the caret will be invisible. + tOffset := FEdit.CalcMinHeight - height; + if tOffset > 0 then + Inc(R.Bottom, tOffset); + end; + + // Set the edit's bounds but make sure there's a minimum width and the right border does not + // extend beyond the parent's left/right border. + if R.Left < 0 then + R.Left := 0; + if R.Right - R.Left < 30 then + begin + if FAlignment = taRightJustify then + R.Left := R.Right - 30 + else + R.Right := R.Left + 30; + end; + if R.Right > FTree.ClientWidth then + R.Right := FTree.ClientWidth; + FEdit.BoundsRect := R; + + // The selected text shall exclude the text margins and be centered vertically. + // We have to take out the two pixel border of the edit control as well as a one pixel "edit border" the + // control leaves around the (selected) text. + R := FEdit.ClientRect; + + // If toGridExtensions are turned on, we can fine tune the left margin (or the right margin if RTL is on) + // of the text to exactly match the text in the tree cell. + if (toGridExtensions in FTree.TreeOptions.MiscOptions) and + ((FAlignment = taLeftJustify) and (FEdit.BidiMode = bdLeftToRight) or + (FAlignment = taRightJustify) and (FEdit.BidiMode <> bdLeftToRight)) then + begin + // Calculate needed text area offset. + FTree.GetOffsets(FNode, offsets, ofsText, FColumn); + if FColumn = FTree.Header.MainColumn then + begin + if offsets[ofsToggleButton] < 0 then + lOffset := -(offsets[ofsToggleButton] + 2) + else + lOffset := 0; + end + else + lOffset := offsets[ofsText] - offsets[ofsMargin] + 1; + // Apply the offset. + if FEdit.BidiMode = bdLeftToRight then + Inc(R.Left, lOffset) + else + Dec(R.Right, lOffset); + end; + + lOffset := IfThen(vsMultiline in FNode.States, 0, 2); + if tsUseThemes in FTree.TreeStates then + Inc(lOffset); + InflateRect(R, -FTree.TextMargin + lOffset, lOffset); + if not (vsMultiline in FNode.States) then + begin + tOffset := FTextBounds.Top - FEdit.Top; + // Do not apply a negative offset, the cursor will disappear. + if tOffset > 0 then + OffsetRect(R, 0, tOffset); + end; + R.Top := Max(-1, R.Top); // A value smaller than -1 will prevent the edit cursor from being shown by Windows, see issue #159 + R.Left := Max(-1, R.Left); + SendMessage(FEdit.Handle, EM_SETRECTNP, 0, LPARAM(@R)); + end; +end; //----------------- TCustomVirtualString ------------------------------------------------------------------------------- @@ -24625,7 +33769,7 @@ begin else if vsSelected in Node.States then begin - Canvas.Font.Color := FColors.GetSelectedNodeFontColor(Focused or (toPopupMode in FOptions.PaintOptions)); + Canvas.Font.Color := FColors.GetSelectedNodeFontColor(Focused); end; end; end; @@ -24740,7 +33884,7 @@ begin if Node = FDropTargetNode then begin if (FLastDropMode = dmOnNode) or (vsSelected in Node.States) then - Canvas.Font.Color := FColors.GetSelectedNodeFontColor(Focused or (toPopupMode in FOptions.PaintOptions)) + Canvas.Font.Color := FColors.GetSelectedNodeFontColor(Focused) else Canvas.Font.Color := FColors.NodeFontColor; end @@ -24748,7 +33892,7 @@ begin if vsSelected in Node.States then begin if Focused or (toPopupMode in FOptions.PaintOptions) then - Canvas.Font.Color := FColors.GetSelectedNodeFontColor(Focused or (toPopupMode in FOptions.PaintOptions)) + Canvas.Font.Color := FColors.GetSelectedNodeFontColor(Focused) else Canvas.Font.Color := FColors.NodeFontColor; end; @@ -25803,6 +34947,72 @@ begin Result := TStringTreeOptions; end; +//---------------------------------------------------------------------------------------------------------------------- + +function TCustomVirtualDrawTree.DoGetCellContentMargin(Node: PVirtualNode; Column: TColumnIndex; + CellContentMarginType: TVTCellContentMarginType = ccmtAllSides; Canvas: TCanvas = nil): TPoint; + +begin + Result := Point(0, 0); + if Canvas = nil then + Canvas := Self.Canvas; + + if Assigned(FOnGetCellContentMargin) then + FOnGetCellContentMargin(Self, Canvas, Node, Column, CellContentMarginType, Result); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TCustomVirtualDrawTree.DoGetNodeWidth(Node: PVirtualNode; Column: TColumnIndex; Canvas: TCanvas = nil): Integer; + +begin + Result := 2 * FTextMargin; + if Canvas = nil then + Canvas := Self.Canvas; + + if Assigned(FOnGetNodeWidth) then + FOnGetNodeWidth(Self, Canvas, Node, Column, Result); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TCustomVirtualDrawTree.DoPaintNode(var PaintInfo: TVTPaintInfo); + +begin + if Assigned(FOnDrawNode) then + FOnDrawNode(Self, PaintInfo); +end; + +function TCustomVirtualDrawTree.GetDefaultHintKind: TVTHintKind; + +begin + Result := vhkOwnerDraw; +end; + +//----------------- TVirtualDrawTree ----------------------------------------------------------------------------------- + +function TVirtualDrawTree.GetOptions: TVirtualTreeOptions; + +begin + Result := FOptions as TVirtualTreeOptions; +end; + +//---------------------------------------------------------------------------------------------------------------------- + +procedure TVirtualDrawTree.SetOptions(const Value: TVirtualTreeOptions); + +begin + FOptions.Assign(Value); +end; + +//---------------------------------------------------------------------------------------------------------------------- + +function TVirtualDrawTree.GetOptionsClass: TTreeOptionsClass; + +begin + Result := TVirtualTreeOptions; +end; + //---------------------------------------------------------------------------------------------------------------------- @@ -25887,6 +35097,56 @@ begin Self.ExportType := pExportType; end; +{ TCheckStateHelper } + +function TCheckStateHelper.IsDisabled: Boolean; +begin + Result := Self >= TCheckState.csUncheckedDisabled; +end; + +function TCheckStateHelper.IsChecked: Boolean; +begin + Result := Self in [csCheckedNormal, csCheckedPressed, csCheckedDisabled]; +end; + +function TCheckStateHelper.IsUnChecked: Boolean; +begin + Result := Self in [csUnCheckedNormal, csUnCheckedPressed, csUnCheckedDisabled]; +end; + +function TCheckStateHelper.IsMixed: Boolean; +begin + Result := Self in [csMixedNormal, csMixedPressed, csMixedDisabled]; +end; + +function TCheckStateHelper.GetEnabled: TCheckState; +begin + Result := cEnabledState[Self]; +end; + +function TCheckStateHelper.GetPressed(): TCheckState; +begin + Result := cPressedState[Self]; +end; + +function TCheckStateHelper.GetUnpressed(): TCheckState; +begin + Result := cUnpressedState[Self]; +end; + +function TCheckStateHelper.GetToggled(): TCheckState; +begin + Result := cToggledState[Self]; +end; + +{ TSortDirectionHelper } + +function TSortDirectionHelper.ToInt(): Integer; +begin + Result := cSortDirectionToInt[Self]; +end; + + { TVTPaintInfo } procedure TVTPaintInfo.AdjustImageCoordinates(); @@ -25916,10 +35176,36 @@ begin ImageInfo[iiCheck].YPos := CellRect.Top + VAlign - ImageInfo[iiCheck].Images.Height div 2; end; +{ THeaderPaintInfo } + +procedure THeaderPaintInfo.DrawDropMark(); +var + Y: Integer; + lArrowWidth: Integer; +begin + lArrowWidth := Self.Column.Owner.Header.Treeview.ScaledPixels(5); + Y := (PaintRectangle.Top + PaintRectangle.Bottom - 3 * lArrowWidth) div 2; + if DropMark = dmmLeft then + DrawArrow(TargetCanvas, TScrollDirection.sdLeft, Point(PaintRectangle.Left, Y), lArrowWidth) + else + DrawArrow(TargetCanvas, TScrollDirection.sdRight, Point(PaintRectangle.Right - lArrowWidth - (lArrowWidth div 2) {spacing}, Y), lArrowWidth); +end; + +procedure THeaderPaintInfo.DrawSortArrow(pDirection: TSortDirection); +const + cDirection: array[TSortDirection] of TScrollDirection = (TScrollDirection.sdUp, TScrollDirection.sdDown); +var + lOldColor: TColor; +begin + lOldColor := TargetCanvas.Pen.Color; + TargetCanvas.Pen.Color := clDkGray; + DrawArrow(TargetCanvas, cDirection[pDirection], Point(SortGlyphPos.X, SortGlyphPos.Y), SortGlyphSize.cy); + TargetCanvas.Pen.Color := lOldColor; +end; + initialization finalization FinalizeGlobalStructures(); end. - diff --git a/components/virtualtreeview/Source/VirtualTrees.res b/components/virtualtreeview/Source/VirtualTrees.res index 558fd1ef..deb671eb 100644 Binary files a/components/virtualtreeview/Source/VirtualTrees.res and b/components/virtualtreeview/Source/VirtualTrees.res differ diff --git a/components/virtualtreeview/packages/Delphi11.2/VirtualTreesR.dpk b/components/virtualtreeview/packages/Delphi11.2/VirtualTreesR.dpk index bae6130d..ec3458cb 100644 --- a/components/virtualtreeview/packages/Delphi11.2/VirtualTreesR.dpk +++ b/components/virtualtreeview/packages/Delphi11.2/VirtualTreesR.dpk @@ -33,24 +33,16 @@ requires vclx; contains - VirtualTrees.Accessibility in '..\..\Source\VirtualTrees.Accessibility.pas', - VirtualTrees.AccessibilityFactory in '..\..\Source\VirtualTrees.AccessibilityFactory.pas', - VirtualTrees.Actions in '..\..\Source\VirtualTrees.Actions.pas', - VirtualTrees.Classes in '..\..\Source\VirtualTrees.Classes.pas', - VirtualTrees.ClipBoard in '..\..\Source\VirtualTrees.ClipBoard.pas', - VirtualTrees.Colors in '..\..\Source\VirtualTrees.Colors.pas', - VirtualTrees.DataObject in '..\..\Source\VirtualTrees.DataObject.pas', - VirtualTrees.DragImage in '..\..\Source\VirtualTrees.DragImage.pas', - VirtualTrees.DragnDrop in '..\..\Source\VirtualTrees.DragnDrop.pas', - VirtualTrees.DrawTree in '..\..\Source\VirtualTrees.DrawTree.pas', - VirtualTrees.EditLink in '..\..\Source\VirtualTrees.EditLink.pas', - VirtualTrees.Export in '..\..\Source\VirtualTrees.Export.pas', - VirtualTrees.Header in '..\..\Source\VirtualTrees.Header.pas', + VirtualTrees in '..\..\Source\VirtualTrees.pas', VirtualTrees.HeaderPopup in '..\..\Source\VirtualTrees.HeaderPopup.pas', - VirtualTrees in '..\..\source\VirtualTrees.pas', + VirtualTrees.AccessibilityFactory in '..\..\Source\VirtualTrees.AccessibilityFactory.pas', + VirtualTrees.Accessibility in '..\..\Source\VirtualTrees.Accessibility.pas', VirtualTrees.StyleHooks in '..\..\Source\VirtualTrees.StyleHooks.pas', - VirtualTrees.Types in '..\..\Source\VirtualTrees.Types.pas', - VirtualTrees.Utils in '..\..\Source\VirtualTrees.Utils.pas', - VirtualTrees.WorkerThread in '..\..\Source\VirtualTrees.WorkerThread.pas'; + VirtualTrees.Classes in '..\..\Source\VirtualTrees.Classes.pas', + VirtualTrees.WorkerThread in '..\..\Source\VirtualTrees.WorkerThread.pas', + VirtualTrees.ClipBoard in '..\..\Source\VirtualTrees.ClipBoard.pas', + VirtualTrees.Actions in '..\..\Source\VirtualTrees.Actions.pas', + VirtualTrees.Export in '..\..\Source\VirtualTrees.Export.pas', + VirtualTrees.Utils in '..\..\Source\VirtualTrees.Utils.pas'; end. diff --git a/components/virtualtreeview/packages/Delphi11.2/VirtualTreesR.dproj b/components/virtualtreeview/packages/Delphi11.2/VirtualTreesR.dproj index 3a4624a5..3664bb4b 100644 --- a/components/virtualtreeview/packages/Delphi11.2/VirtualTreesR.dproj +++ b/components/virtualtreeview/packages/Delphi11.2/VirtualTreesR.dproj @@ -64,25 +64,17 @@ - - - - - - - - - - - - - + - + + - - + + + + + Base @@ -141,5 +133,4 @@ - diff --git a/source/main.pas b/source/main.pas index 2bfcc989..84831609 100644 --- a/source/main.pas +++ b/source/main.pas @@ -17,7 +17,7 @@ uses routine_editor, trigger_editor, event_editor, preferences, EditVar, apphelpers, createdatabase, table_editor, TableTools, View, Usermanager, SelectDBObject, connections, sqlhelp, dbconnection, insertfiles, searchreplace, loaddata, copytable, csv_detector, Cromis.DirectoryWatch, SyncDB, gnugettext, - VirtualTrees, VirtualTrees.Header, VirtualTrees.HeaderPopup, VirtualTrees.Utils, VirtualTrees.Types, + VirtualTrees, VirtualTrees.HeaderPopup, VirtualTrees.Utils, VirtualTrees.Types, JumpList, System.Actions, System.UITypes, Vcl.Imaging.pngimage, System.ImageList, Vcl.Styles.UxTheme, Vcl.Styles.Utils.Menus, Vcl.Styles.Utils.Forms, Vcl.VirtualImageList, Vcl.BaseImageCollection, Vcl.ImageCollection, System.IniFiles, extra_controls, diff --git a/source/routine_editor.pas b/source/routine_editor.pas index ef895538..e9ce7485 100644 --- a/source/routine_editor.pas +++ b/source/routine_editor.pas @@ -4,7 +4,7 @@ interface uses Winapi.Windows, System.SysUtils, System.Classes, Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs, SynEdit, SynMemo, Vcl.StdCtrls, - Vcl.ComCtrls, Vcl.ToolWin, VirtualTrees, VirtualTrees.EditLink, SynRegExpr, extra_controls, + Vcl.ComCtrls, Vcl.ToolWin, VirtualTrees, SynRegExpr, extra_controls, dbconnection, apphelpers, gnugettext, Vcl.Menus, Vcl.ExtCtrls; type diff --git a/source/tabletools.pas b/source/tabletools.pas index 21cf32bb..5a6de1cc 100644 --- a/source/tabletools.pas +++ b/source/tabletools.pas @@ -10,7 +10,7 @@ interface uses Winapi.Windows, System.SysUtils, System.Classes, Vcl.Controls, Vcl.Forms, Vcl.StdCtrls, Vcl.ComCtrls, Vcl.Buttons, Vcl.Dialogs, Vcl.StdActns, - VirtualTrees, VirtualTrees.Header, Vcl.ExtCtrls, Vcl.Graphics, SynRegExpr, System.Math, Generics.Collections, extra_controls, + VirtualTrees, Vcl.ExtCtrls, Vcl.Graphics, SynRegExpr, System.Math, Generics.Collections, extra_controls, dbconnection, apphelpers, Vcl.Menus, gnugettext, System.DateUtils, System.Zip, System.UITypes, System.StrUtils, Winapi.Messages, SynEdit, SynMemo, Vcl.ClipBrd, generic_types;