diff --git a/components/virtualtreeview/Compilers.inc b/components/virtualtreeview/Compilers.inc deleted file mode 100644 index 519ddbe36..000000000 --- a/components/virtualtreeview/Compilers.inc +++ /dev/null @@ -1,444 +0,0 @@ -//---------------------------------------------------------------------------------------------------------------------- -// Include file to determine which compiler is currently being used to build the project/component. -// This file uses ideas from Brad Stowers DFS.inc file. -// -// Portions created by Mike Lischke are -// Copyright (C) 1999-2005 Mike Lischke. All Rights Reserved. -// Portions created by Jim Kueneman are -// Copyright (C) 2005 Jim Kueneman. All Rights Reserved. -// -//---------------------------------------------------------------------------------------------------------------------- -// -// This unit is released under the MIT license: -// Copyright (c) 1999-2005 Mike Lischke (support@soft-gems.net, www.soft-gems.net). -// -// Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated -// documentation files (the "Software"), to deal in the Software without restriction, including without limitation the -// rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to -// permit persons to whom the Software is furnished to do so, subject to the following conditions: -// -// The above copyright notice and this permission notice shall be included in all copies or substantial portions of the -// Software. -// -// THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE -// WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS -// OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR -// OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -// -// You are asked to give the author(s) the due credit. This means that you acknowledge the work of the author(s) -// in the product documentation, about box, help or wherever a prominent place is. -// -//---------------------------------------------------------------------------------------------------------------------- -// -// The following symbols are defined: -// -// - COMPILER_1 : Kylix/Delphi/BCB 1.x is the compiler. -// - COMPILER_1_UP : Kylix/Delphi/BCB 1.x or higher is the compiler. -// - COMPILER_2 : Kylix/Delphi 2.x or BCB 1.x is the compiler. -// - COMPILER_2_UP : Kylix/Delphi 2.x or higher, or BCB 1.x or higher is the compiler. -// - COMPILER_3 : Kylix/Delphi/BCB 3.x is the compiler. -// - COMPILER_3_UP : Kylix/Delphi/BCB 3.x or higher is the compiler. -// - COMPILER_4 : Kylix/Delphi/BCB 4.x is the compiler. -// - COMPILER_4_UP : Kylix/Delphi/BCB 4.x or higher is the compiler. -// - COMPILER_5 : Kylix/Delphi/BCB 5.x is the compiler. -// - COMPILER_5_UP : Kylix/Delphi/BCB 5.x or higher is the compiler. -// - COMPILER_6 : Kylix/Delphi/BCB 6.x is the compiler. -// - COMPILER_6_UP : Kylix/Delphi/BCB 6.x or higher is the compiler. -// - COMPILER_7 : Kylix/Delphi/BCB 7.x is the compiler. -// - COMPILER_7_UP : Kylix/Delphi/BCB 7.x or higher is the compiler. -// - COMPILER_8 : Kylix/Delphi/BCB 8.x is the compiler. -// - COMPILER_8_UP : Kylix/Delphi/BCB 8.x or higher is the compiler. -// - COMPILER_9 : Kylix/Delphi/BCB 9.x is the compiler. -// - COMPILER_9_UP : Kylix/Delphi/BCB 9.x or higher is the compiler. -// - COMPILER_10 : Kylix/Delphi/BCB 10.x is the compiler. -// - COMPILER_10_UP : Kylix/Delphi/BCB 10.x or higher is the compiler. -// -// Only defined if Windows is the target: -// - CPPB : Any version of BCB is being used. -// - CPPB_1 : BCB v1.x is being used. -// - CPPB_3 : BCB v3.x is being used. -// - CPPB_3_UP : BCB v3.x or higher is being used. -// - CPPB_4 : BCB v4.x is being used. -// - CPPB_4_UP : BCB v4.x or higher is being used. -// - CPPB_5 : BCB v5.x is being used. -// - CPPB_5_UP : BCB v5.x or higher is being used. -// - CPPB_6 : BCB v6.x is being used. -// - CPPB_6_UP : BCB v6.x or higher is being used. -// -// Only defined if Windows is the target: -// - DELPHI : Any version of Delphi is being used. -// - DELPHI_1 : Delphi v1.x is being used. -// - DELPHI_2 : Delphi v2.x is being used. -// - DELPHI_2_UP : Delphi v2.x or higher is being used. -// - DELPHI_3 : Delphi v3.x is being used. -// - DELPHI_3_UP : Delphi v3.x or higher is being used. -// - DELPHI_4 : Delphi v4.x is being used. -// - DELPHI_4_UP : Delphi v4.x or higher is being used. -// - DELPHI_5 : Delphi v5.x is being used. -// - DELPHI_5_UP : Delphi v5.x or higher is being used. -// - DELPHI_6 : Delphi v6.x is being used. -// - DELPHI_6_UP : Delphi v6.x or higher is being used. -// - DELPHI_7 : Delphi v7.x is being used. -// - DELPHI_7_UP : Delphi v7.x or higher is being used. -// - DELPHI_8 : Delphi v8.x is being used. -// - DELPHI_8_UP : Delphi v8.x or higher is being used. -// - DELPHI_9 : Delphi v9.x is being used. -// - DELPHI_9_UP : Delphi v9.x or higher is being used. -// - DELPHI_XXX is not used any more, use the COMPILER_XXX defines -// -// Only defined if Linux is the target: -// - KYLIX : Any version of Kylix is being used. -// - KYLIX_1 : Kylix 1.x is being used. -// - KYLIX_1_UP : Kylix 1.x or higher is being used. -// - KYLIX_2 : Kylix 2.x is being used. -// - KYLIX_2_UP : Kylix 2.x or higher is being used. -// - KYLIX_3 : Kylix 3.x is being used. -// - KYLIX_3_UP : Kylix 3.x or higher is being used. -// -// Only defined if Linux is the target: -// - QT_CLX : Trolltech's QT library is being used. -// -// Only defined if Delphi.NET is the target: -// - DELPHI.NET : Any version of Delphi.NET is being used. -// - DELPHI.NET_1 : Delphi.NET version 1.x is being used. -// - DELPHI.NET_1_UP : Delphi.NET version 1.x is being used. -//---------------------------------------------------------------------------------------------------------------------- - -{$ifdef CLR} // The common language runtime symbol is only defined for the .NET platform. - {$define DELPHI.NET} - {$ifdef VER160} - {$define DELPHI.NET_1} - {$endif VER160} - - // Compiler defines common to all .NET versions. - {$ifdef DELPHI.NET_1} - {$define DELHI.NET_1_UP} - {$endif DELPHI.NET_1} -{$endif CLR} - -{$ifdef Win32} - - // DELPHI and BCB are no longer defined, only COMPILER - {$ifdef VER180} - {$define COMPILER_10} - {$endif VER180} - - {$ifdef VER170} - {$define COMPILER_9} - {$define DELPHI} - {$define DELPHI_9} - {$endif VER170} - - {$ifdef VER160} - {$define COMPILER_8} - {$define DELPHI} - {$define DELPHI_8} - {$endif VER160} - - {$ifdef VER150} - {$define COMPILER_7} - {$define DELPHI} - {$define DELPHI_7} - {$endif} - - {$ifdef VER140} - {$define COMPILER_6} - {$ifdef BCB} - {$define CPPB} - {$define CPPB_6} - {$else} - {$define DELPHI} - {$define DELPHI_6} - {$endif} - {$endif} - - {$ifdef VER130} - {$define COMPILER_5} - {$ifdef BCB} - {$define CPPB} - {$define CPPB_5} - {$else} - {$define DELPHI} - {$define DELPHI_5} - {$endif} - {$endif} - - {$ifdef VER125} - {$define COMPILER_4} - {$define CPPB} - {$define CPPB_4} - {$endif} - - {$ifdef VER120} - {$define COMPILER_4} - {$define DELPHI} - {$define DELPHI_4} - {$endif} - - {$ifdef VER110} - {$define COMPILER_3} - {$define CPPB} - {$define CPPB_3} - {$endif} - - {$ifdef VER100} - {$define COMPILER_3} - {$define DELPHI} - {$define DELPHI_3} - {$endif} - - {$ifdef VER93} - {$define COMPILER_2} // C++ Builder v1 compiler is really v2 - {$define CPPB} - {$define CPPB_1} - {$endif} - - {$ifdef VER90} - {$define COMPILER_2} - {$define DELPHI} - {$define DELPHI_2} - {$endif} - - {$ifdef VER80} - {$define COMPILER_1} - {$define DELPHI} - {$define DELPHI_1} - {$endif} - - {$ifdef DELPHI_2} - {$define DELPHI_2_UP} - {$endif} - - {$ifdef DELPHI_3} - {$define DELPHI_2_UP} - {$define DELPHI_3_UP} - {$endif} - - {$ifdef DELPHI_4} - {$define DELPHI_2_UP} - {$define DELPHI_3_UP} - {$define DELPHI_4_UP} - {$endif} - - {$ifdef DELPHI_5} - {$define DELPHI_2_UP} - {$define DELPHI_3_UP} - {$define DELPHI_4_UP} - {$define DELPHI_5_UP} - {$endif} - - {$ifdef DELPHI_6} - {$define DELPHI_2_UP} - {$define DELPHI_3_UP} - {$define DELPHI_4_UP} - {$define DELPHI_5_UP} - {$define DELPHI_6_UP} - {$endif} - - {$ifdef DELPHI_7} - {$define DELPHI_2_UP} - {$define DELPHI_3_UP} - {$define DELPHI_4_UP} - {$define DELPHI_5_UP} - {$define DELPHI_6_UP} - {$define DELPHI_7_UP} - {$endif} - - {$ifdef DELPHI_8} - {$define DELPHI_2_UP} - {$define DELPHI_3_UP} - {$define DELPHI_4_UP} - {$define DELPHI_5_UP} - {$define DELPHI_6_UP} - {$define DELPHI_7_UP} - {$define DELPHI_8_UP} - {$endif} - - {$ifdef DELPHI_9} - {$define DELPHI_2_UP} - {$define DELPHI_3_UP} - {$define DELPHI_4_UP} - {$define DELPHI_5_UP} - {$define DELPHI_6_UP} - {$define DELPHI_7_UP} - {$define DELPHI_8_UP} - {$define DELPHI_9_UP} - {$endif} - - {$ifdef CPPB_3} - {$define CPPB_3_UP} - {$endif} - - {$ifdef CPPB_4} - {$define CPPB_3_UP} - {$define CPPB_4_UP} - {$endif} - - {$ifdef CPPB_5} - {$define CPPB_3_UP} - {$define CPPB_4_UP} - {$define CPPB_5_UP} - {$endif} - - {$ifdef CPPB_6} - {$define CPPB_3_UP} - {$define CPPB_4_UP} - {$define CPPB_5_UP} - {$define CPPB_6_UP} - {$endif} - - {$ifdef CPPB_3_UP} - // C++ Builder requires this if you use Delphi components in run-time packages. - {$ObjExportAll On} - {$endif} - -{$else (not Windows)} - // Linux is the target - {$define QT_CLX} - - {$define KYLIX} - - {$ifdef VER140} - {$define COMPILER_6} - {$ifdef conditionalexpressions} - {$if Declared(RTLVersion) and (RTLVersion = 14)} - {$define KYLIX_1} - {$ifend} - - {$if Declared(RTLVersion) and (RTLVersion = 14.2)} - {$define KYLIX_2} - {$ifend} - - {$if Declared(RTLVersion) and (RTLVersion = 14.5)} - {$define KYLIX_3} - {$ifend} - {$endif} - {$endif} - - {$ifdef VER150} - {$define COMPILER_7} - {$define KYLIX_3} - {$endif} - - {$ifdef VER140} - {$define COMPILER_6} - {$define KYLIX_2} - {$endif} - - {$ifdef KYLIX_1} - {$define KYLIX_1_UP} - {$endif} - - {$ifdef KYLIX_2} - {$define KYLIX_2_UP} - {$endif} - - {$ifdef KYLIX_3} - {$define KYLIX_2_UP} - {$define KYLIX_3_UP} - {$endif} - -{$endif Win32} - -// Compiler defines not specific to a particlular platform. - -{$ifdef COMPILER_1} - {$define COMPILER_1_UP} -{$endif} - -{$ifdef COMPILER_2} - {$define COMPILER_1_UP} - {$define COMPILER_2_UP} -{$endif} - -{$ifdef COMPILER_3} - {$define COMPILER_1_UP} - {$define COMPILER_2_UP} - {$define COMPILER_3_UP} -{$endif} - -{$ifdef COMPILER_4} - {$define COMPILER_1_UP} - {$define COMPILER_2_UP} - {$define COMPILER_3_UP} - {$define COMPILER_4_UP} -{$endif} - -{$ifdef COMPILER_5} - {$define COMPILER_1_UP} - {$define COMPILER_2_UP} - {$define COMPILER_3_UP} - {$define COMPILER_4_UP} - {$define COMPILER_5_UP} -{$endif} - -{$ifdef COMPILER_6} - {$define COMPILER_1_UP} - {$define COMPILER_2_UP} - {$define COMPILER_3_UP} - {$define COMPILER_4_UP} - {$define COMPILER_5_UP} - {$define COMPILER_6_UP} -{$endif} - -{$ifdef COMPILER_7} - {$define COMPILER_1_UP} - {$define COMPILER_2_UP} - {$define COMPILER_3_UP} - {$define COMPILER_4_UP} - {$define COMPILER_5_UP} - {$define COMPILER_6_UP} - {$define COMPILER_7_UP} -{$endif} - -{$ifdef COMPILER_8} - {$define COMPILER_1_UP} - {$define COMPILER_2_UP} - {$define COMPILER_3_UP} - {$define COMPILER_4_UP} - {$define COMPILER_5_UP} - {$define COMPILER_6_UP} - {$define COMPILER_7_UP} - {$define COMPILER_8_UP} -{$endif} - -{$ifdef COMPILER_9} - {$define COMPILER_1_UP} - {$define COMPILER_2_UP} - {$define COMPILER_3_UP} - {$define COMPILER_4_UP} - {$define COMPILER_5_UP} - {$define COMPILER_6_UP} - {$define COMPILER_7_UP} - {$define COMPILER_8_UP} - {$define COMPILER_9_UP} -{$endif} - -{$ifdef COMPILER_10} - {$define COMPILER_1_UP} - {$define COMPILER_2_UP} - {$define COMPILER_3_UP} - {$define COMPILER_4_UP} - {$define COMPILER_5_UP} - {$define COMPILER_6_UP} - {$define COMPILER_7_UP} - {$define COMPILER_8_UP} - {$define COMPILER_9_UP} - {$define COMPILER_10_UP} - // Backwards compatibility - {$define DELPHI_2_UP} - {$define DELPHI_3_UP} - {$define DELPHI_4_UP} - {$define DELPHI_5_UP} - {$define DELPHI_6_UP} - {$define DELPHI_7_UP} - {$define DELPHI_8_UP} - {$define DELPHI_9_UP} - {$define CPPB_3_UP} - {$define CPPB_4_UP} - {$define CPPB_5_UP} - {$define CPPB_6_UP} -{$endif} - -//---------------------------------------------------------------------------------------------------------------------- - diff --git a/components/virtualtreeview/VTAccessibility.pas b/components/virtualtreeview/VTAccessibility.pas deleted file mode 100644 index 9dd312d45..000000000 --- a/components/virtualtreeview/VTAccessibility.pas +++ /dev/null @@ -1,674 +0,0 @@ -unit VTAccessibility; - -// This unit implements iAccessible interfaces for the VirtualTree visual components -// and the currently focused node. -// -// Written by Marco Zehe. (c) 2007 - -interface - -uses Windows, Classes, ActiveX, oleacc, VirtualTrees, VTAccessibilityFactory, Controls; - -type - TVirtualTreeAccessibility = class(TInterfacedObject, IDispatch, IAccessible) - private - FVirtualTree: TVirtualStringTree; - public - { IAccessibility } - function Get_accParent(out ppdispParent: IDispatch): HResult; stdcall; - function Get_accChildCount(out pcountChildren: Integer): HResult; stdcall; - function Get_accChild(varChild: OleVariant; out ppdispChild: IDispatch): HResult; stdcall; - function Get_accName(varChild: OleVariant; out pszName: WideString): HResult; stdcall; - function Get_accValue(varChild: OleVariant; out pszValue: WideString): HResult; stdcall; - function Get_accDescription(varChild: OleVariant; out pszDescription: WideString): HResult; stdcall; - function Get_accRole(varChild: OleVariant; out pvarRole: OleVariant): HResult; stdcall; - function Get_accState(varChild: OleVariant; out pvarState: OleVariant): HResult; stdcall; - function Get_accHelp(varChild: OleVariant; out pszHelp: WideString): HResult; stdcall; - function Get_accHelpTopic(out pszHelpFile: WideString; varChild: OleVariant; - out pidTopic: Integer): HResult; stdcall; - function Get_accKeyboardShortcut(varChild: OleVariant; out pszKeyboardShortcut: WideString): HResult; stdcall; - function Get_accFocus(out pvarChild: OleVariant): HResult; stdcall; - function Get_accSelection(out pvarChildren: OleVariant): HResult; stdcall; - function Get_accDefaultAction(varChild: OleVariant; out pszDefaultAction: WideString): HResult; stdcall; - function accSelect(flagsSelect: Integer; varChild: OleVariant): HResult; stdcall; - function accLocation(out pxLeft: Integer; out pyTop: Integer; out pcxWidth: Integer; - out pcyHeight: Integer; varChild: OleVariant): HResult; stdcall; - function accNavigate(navDir: Integer; varStart: OleVariant; out pvarEndUpAt: OleVariant): HResult; stdcall; - function accHitTest(xLeft: Integer; yTop: Integer; out pvarChild: OleVariant): HResult; stdcall; - function accDoDefaultAction(varChild: OleVariant): HResult; stdcall; - function Set_accName(varChild: OleVariant; const pszName: WideString): HResult; stdcall; - function Set_accValue(varChild: OleVariant; const pszValue: WideString): HResult; stdcall; - {IDispatch} - function GetIDsOfNames(const IID: TGUID; Names: Pointer; - NameCount: Integer; LocaleID: Integer; DispIDs: Pointer): HRESULT; stdcall; - function GetTypeInfo(Index: Integer; LocaleID: Integer; - out TypeInfo): HRESULT; stdcall; - function GetTypeInfoCount(out Count: Integer): HRESULT; stdcall; - function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer; - Flags: Word; var Params; VarResult: Pointer; ExcepInfo: Pointer; - ArgErr: Pointer): HRESULT; stdcall; - constructor Create(VirtualTree: TVirtualStringTree); - end; - - TVirtualTreeItemAccessibility = class(TVirtualTreeAccessibility, IAccessible) - public - { IAccessibility } - function Get_accParent(out ppdispParent: IDispatch): HResult; stdcall; - function Get_accChildCount(out pcountChildren: Integer): HResult; stdcall; - function Get_accChild(varChild: OleVariant; out ppdispChild: IDispatch): HResult; stdcall; - function Get_accName(varChild: OleVariant; out pszName: WideString): HResult; stdcall; - function Get_accValue(varChild: OleVariant; out pszValue: WideString): HResult; stdcall; - function Get_accDescription(varChild: OleVariant; out pszDescription: WideString): HResult; stdcall; - function Get_accRole(varChild: OleVariant; out pvarRole: OleVariant): HResult; stdcall; - function Get_accState(varChild: OleVariant; out pvarState: OleVariant): HResult; stdcall; - function accLocation(out pxLeft: Integer; - out pyTop: Integer; out pcxWidth: Integer; - out pcyHeight: Integer; varChild: OleVariant): HResult; stdcall; - constructor Create(VirtualTree: TVirtualStringTree); - end; - - TVTMultiColumnItemAccessibility = class(TVirtualTreeItemAccessibility, IAccessible) - private - function GetItemDescription(varChild: OleVariant; out pszDescription: WideString; IncludeMainColumn: boolean): HResult; stdcall; - public - { IAccessibility } - function Get_accName(varChild: OleVariant; out pszName: WideString): HResult; stdcall; - function Get_accDescription(varChild: OleVariant; out pszDescription: WideString): HResult; stdcall; - end; - - TVTDefaultAccessibleProvider = class(TInterfacedObject, IVTAccessibleProvider) - function CreateIAccessible(ATree: TBaseVirtualTree): IAccessible; - end; - - TVTDefaultAccessibleItemProvider = class(TInterfacedObject, IVTAccessibleProvider) - function CreateIAccessible(ATree: TBaseVirtualTree): IAccessible; - end; - - TVTMultiColumnAccessibleItemProvider = class(TInterfacedObject, IVTAccessibleProvider) - function CreateIAccessible(ATree: TBaseVirtualTree): IAccessible; - end; - -implementation - -uses Variants, SysUtils, Types, Forms; - -{ TVirtualTreeAccessibility } -//---------------------------------------------------------------------------------------------------------------------- - -function TVirtualTreeAccessibility.accDoDefaultAction(varChild: OleVariant): HResult; -// a default action is not supported. -begin - Result := DISP_E_MEMBERNOTFOUND; -end; -//---------------------------------------------------------------------------------------------------------------------- - -function TVirtualTreeAccessibility.accHitTest(xLeft: Integer; yTop: Integer; out pvarChild: OleVariant): HResult; -// returns the iAccessible object at the given point, if applicable. -var - Pt: TPoint; - HitInfo: THitInfo; -begin - Result := S_FALSE; - if FVirtualTree <> nil then - begin -// VariantInit(pvarChild); -// TVarData(pvarChild).VType := VT_I4; - Pt := fVirtualTree.ScreenToClient(Point(xLeft, yTop)); - if fVirtualTree.FocusedNode <> nil then - begin - fVirtualTree.GetHitTestInfoAt(xLeft, yTop, false, HitInfo); - if FVirtualTree.FocusedNode = HitInfo.HitNode then - begin - pvarChild := FVirtualTree.AccessibleItem; - Result := S_OK; - exit; - end; - end; - if PtInRect(FVirtualTree.BoundsRect, Pt) then - begin - pvarChild := CHILDID_SELF; - Result := S_OK; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- -function TVirtualTreeAccessibility.accLocation(out pxLeft: Integer; - out pyTop: Integer; out pcxWidth: Integer; - out pcyHeight: Integer; varChild: OleVariant): HResult; -// returns the location of the VirtualStringTree object. -var - P: TPoint; -begin - Result := S_FALSE; - if varChild = CHILDID_SELF then - begin - if FVirtualTree <> nil then - begin - P := FVirtualTree.ClientToScreen(FVirtualTree.ClientRect.TopLeft); - pxLeft := P.X; - pyTop := P.Y; - pcxWidth := FVirtualTree.Width; - pcyHeight := FVirtualTree.Height; - Result := S_OK; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- -function TVirtualTreeAccessibility.accNavigate(navDir: Integer; varStart: OleVariant; - out pvarEndUpAt: OleVariant): HResult; -// This is not supported. -begin - Result := DISP_E_MEMBERNOTFOUND; -end; - -//---------------------------------------------------------------------------------------------------------------------- -function TVirtualTreeAccessibility.Get_accSelection(out pvarChildren: OleVariant): HResult; -// returns the selected child ID, if any. -begin - Result := s_false; - if FVirtualTree <> nil then - if fVirtualTree.FocusedNode <> nil then - begin - pvarChildren := 1; - result := s_OK; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- -constructor TVirtualTreeAccessibility.Create(VirtualTree: TVirtualStringTree); -// assigns the parent and current fields, and lets the control's iAccessible object know its address. -begin - fVirtualTree := VirtualTree; -end; - -//---------------------------------------------------------------------------------------------------------------------- -function TVirtualTreeAccessibility.GetIDsOfNames(const IID: TGUID; - Names: Pointer; NameCount, LocaleID: Integer; DispIDs: Pointer): HRESULT; -// Not supported. -begin - Result := E_NOTIMPL; -end; - -//---------------------------------------------------------------------------------------------------------------------- -function TVirtualTreeAccessibility.GetTypeInfo(Index, LocaleID: Integer; - out TypeInfo): HRESULT; -// not supported. -begin - Result := E_NOTIMPL; -end; - -//---------------------------------------------------------------------------------------------------------------------- -function TVirtualTreeAccessibility.GetTypeInfoCount( - out Count: Integer): HRESULT; -// not supported. -begin - Result := E_NOTIMPL; -end; - -//---------------------------------------------------------------------------------------------------------------------- -function TVirtualTreeAccessibility.Get_accChild(varChild: OleVariant; out ppdispChild: IDispatch): HResult; -// returns the iAccessible child, whicfh represents the focused item. -begin - if varChild = CHILDID_SELF then - begin - ppdispChild := FVirtualTree.AccessibleItem; - Result := S_OK; - end - else - Result := E_INVALIDARG -end; - -//---------------------------------------------------------------------------------------------------------------------- -function TVirtualTreeAccessibility.Get_accChildCount(out pcountChildren: Integer): HResult; -// Returns the number 1 for the one child: The focused item. -begin - pcountChildren := 1; - Result := S_OK; -end; - -//---------------------------------------------------------------------------------------------------------------------- -function TVirtualTreeAccessibility.Get_accDefaultAction(varChild: OleVariant; out pszDefaultAction: WideString): HResult; -// Not supported. -begin - Result := DISP_E_MEMBERNOTFOUND; -end; - -//---------------------------------------------------------------------------------------------------------------------- -function TVirtualTreeAccessibility.Get_accDescription(varChild: OleVariant; out pszDescription: WideString): HResult; -// returns the hint of the control, if assigned. -begin - pszDescription := ''; - Result := S_FALSE; - if varChild = CHILDID_SELF then - begin - if FVirtualTree <> nil then - pszDescription := GetLongHint(fVirtualTree.Hint); - end; - if Length(pszDescription) > 0 then - Result := S_OK; -end; - -//---------------------------------------------------------------------------------------------------------------------- -function TVirtualTreeAccessibility.Get_accFocus(out pvarChild: OleVariant): HResult; -// returns the child ID of 1, if assigned. -begin - Result := s_false; - if fVirtualTree <> nil then - begin - if FVirtualTree.FocusedNode <> nil then - begin - pvarChild := fVirtualTree.AccessibleItem; - result := s_OK; - end - else begin - pvarChild := childid_self; - result := S_OK; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- -function TVirtualTreeAccessibility.Get_accHelp(varChild: OleVariant; out pszHelp: WideString): HResult; -// Not supported. -begin - Result := DISP_E_MEMBERNOTFOUND; -end; - -//---------------------------------------------------------------------------------------------------------------------- -function TVirtualTreeAccessibility.Get_accHelpTopic(out pszHelpFile: WideString; varChild: OleVariant; - out pidTopic: Integer): HResult; -// Returns the HelpContext ID, if present. -begin - pszHelpFile := ''; - pidTopic := 0; - Result := S_OK; - if varChild = CHILDID_SELF then - if FVirtualTree <> nil then - begin - pszHelpFile := Application.HelpFile; - pidTopic := FVirtualTree.HelpContext; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- -function TVirtualTreeAccessibility.Get_accKeyboardShortcut(varChild: OleVariant; out pszKeyboardShortcut: WideString): HResult; -// Not supported. -begin - pszKeyboardShortcut := ''; - Result := S_FALSE; -end; - -//---------------------------------------------------------------------------------------------------------------------- -function TVirtualTreeAccessibility.Get_accName(varChild: OleVariant; out pszName: WideString): HResult; -// if set, returns the new published AccessibleName property. -// otherwise, returns the default text. -begin - pszName := ''; - Result := S_FALSE; - if varChild = CHILDID_SELF then - begin - if FVirtualTree <> nil then - begin - if FVirtualTree.AccessibleName <> '' then - pszName := FVirtualTree.AccessibleName - else - PSZName := FVirtualTree.DefaultText; - result := S_OK; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- -function TVirtualTreeAccessibility.Get_accParent(out ppdispParent: IDispatch): HResult; -// Returns false, the tree itself does not have a parent. -begin - ppdispParent := nil; - Result := S_FALSE; -end; - -//---------------------------------------------------------------------------------------------------------------------- -function TVirtualTreeAccessibility.Get_accRole(varChild: OleVariant; out pvarRole: OleVariant): HResult; -// tells MSAA that it is a TreeView. -begin - Result := S_OK; -// VariantInit(pvarRole); -// TVarData(pvarRole).VType := VT_I4; - if varChild = CHILDID_SELF then - begin - if FVirtualTree <> nil then - pvarRole := ROLE_SYSTEM_OUTLINE - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- -function TVirtualTreeAccessibility.accSelect(flagsSelect: Integer; varChild: OleVariant): HResult; -// since we're not supporting more than one item, this is not supported currently. -begin - Result := DISP_E_MEMBERNOTFOUND; -end; - -//---------------------------------------------------------------------------------------------------------------------- -function TVirtualTreeAccessibility.Get_accState(varChild: OleVariant; out pvarState: OleVariant): HResult; -// returns the state of the control. -const - IsEnabled: array[Boolean] of Integer = (STATE_SYSTEM_UNAVAILABLE, 0); - HasPopup: array[Boolean] of Integer = (0, STATE_SYSTEM_HASPOPUP); - IsVisible: array[Boolean] of Integer = (STATE_SYSTEM_INVISIBLE, 0); -begin - Result := S_OK; -// VariantInit(pvarState); -// TVarData(pvarState).VType := VT_I4; - if varChild = CHILDID_SELF then - begin - if FVirtualTree <> nil then - begin - pvarState := STATE_SYSTEM_FOCUSED or STATE_SYSTEM_FOCUSABLE or STATE_SYSTEM_HOTTRACKED; - pvarState := pvarState or IsVisible[FVirtualTree.Visible]; - pvarState := pvarState or IsEnabled[FVirtualTree.Enabled]; - end - else - Result := E_INVALIDARG; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- -function TVirtualTreeAccessibility.Get_accValue(varChild: OleVariant; out pszValue: WideString): HResult; -// the TreeView control itself does not have a value, returning false here. -begin - pszValue := ''; - Result := S_FALSE;//DISP_E_MEMBERNOTFOUND; -end; - -//---------------------------------------------------------------------------------------------------------------------- -function TVirtualTreeAccessibility.Invoke(DispID: Integer; const IID: TGUID; - LocaleID: Integer; Flags: Word; var Params; VarResult, ExcepInfo, - ArgErr: Pointer): HRESULT; -// not supported. -begin - Result := E_NOTIMPL; -end; - -//---------------------------------------------------------------------------------------------------------------------- -function TVirtualTreeAccessibility.Set_accName(varChild: OleVariant; const pszName: WideString): HResult; stdcall; -// not supported. -begin - Result := DISP_E_MEMBERNOTFOUND -end; - -//---------------------------------------------------------------------------------------------------------------------- -function TVirtualTreeAccessibility.Set_accValue(varChild: OleVariant; const pszValue: WideString): HResult; -// not supported. -begin - Result := DISP_E_MEMBERNOTFOUND -end; - -{ TVirtualTreeItemAccessibility } - -//---------------------------------------------------------------------------------------------------------------------- -function TVirtualTreeItemAccessibility.accLocation(out pxLeft, pyTop, pcxWidth, - pcyHeight: Integer; varChild: OleVariant): HResult; -// returns the location of the current accessible item. -var - P: TPoint; - DisplayRect: TRect; -begin - Result := S_FALSE; - if varChild = CHILDID_SELF then - begin - if FVirtualTree.FocusedNode <> nil then - begin - DisplayRect := FVirtualTree.GetDisplayRect(FVirtualTree.FocusedNode, -1, TRUE, FALSE); - P := FVirtualTree.ClientToScreen(DisplayRect.TopLeft); - pxLeft := P.X; - pyTop := P.Y; - pcxWidth := DisplayRect.Right - DisplayRect.Left; - pcyHeight := DisplayRect.Bottom - DisplayRect.Top; - Result := S_OK; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- -constructor TVirtualTreeItemAccessibility.Create(VirtualTree: TVirtualStringTree); -// sets up the parent/child relationship. -begin - fVirtualTree := VirtualTree; -end; - -//---------------------------------------------------------------------------------------------------------------------- -function TVirtualTreeItemAccessibility.Get_accChild(varChild: OleVariant; out ppdispChild: IDispatch): HResult; -// the item does not have children. Returning false. -begin - ppdispChild := nil; - Result := S_FALSE; -end; - -//---------------------------------------------------------------------------------------------------------------------- -function TVirtualTreeItemAccessibility.Get_accChildCount(out pcountChildren: Integer): HResult; -// the item itself does not have children, returning 0. -begin - pcountChildren := 0; - Result := S_OK; -end; - -//---------------------------------------------------------------------------------------------------------------------- -function TVirtualTreeItemAccessibility.Get_accDescription(varChild: OleVariant; out pszDescription: WideString): HResult; -// not supported for an item. -begin - Result := DISP_E_MEMBERNOTFOUND; -end; - -//---------------------------------------------------------------------------------------------------------------------- -function TVirtualTreeItemAccessibility.Get_accName(varChild: OleVariant; out pszName: WideString): HResult; -// the name is the node's caption. -begin - pszName := ''; - Result := S_FALSE; - if varChild = childid_self then - begin - if FVirtualTree <> nil then - if FVirtualTree.FocusedNode <> nil then - begin - pszName := FVirtualTree.Text[FVirtualTree.FocusedNode, FVirtualTree.Header.MainColumn]; - result := S_OK; - end - else begin - PSZName := FVirtualTree.DefaultText; - result := S_OK; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- -function TVirtualTreeItemAccessibility.Get_accParent(out ppdispParent: IDispatch): HResult; -// tells MSAA that the VritualStringTree is its parent. -begin - result := S_FALSE; - if FVirtualTree <> nil then - begin - ppdispParent := FVirtualTree.Accessible; - Result := S_OK; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- -function TVirtualTreeItemAccessibility.Get_accRole(varChild: OleVariant; out pvarRole: OleVariant): HResult; -// tells MSAA that it is a TreeView item as opposed to the TreeView itself. -begin - Result := S_OK; -// VariantInit(pvarRole); -// TVarData(pvarRole).VType := VT_I4; - if varChild = childid_self then - begin - if FVirtualTree <> nil then - pvarRole := ROLE_SYSTEM_OUTLINEITEM - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- -function TVirtualTreeItemAccessibility.Get_accState(varChild: OleVariant; out pvarState: OleVariant): HResult; -// Tells MSAA the state the item is in. -const - IsEnabled: array[Boolean] of Integer = (STATE_SYSTEM_UNAVAILABLE, 0); - HasPopup: array[Boolean] of Integer = (0, STATE_SYSTEM_HASPOPUP); - IsVisible: array[Boolean] of Integer = (STATE_SYSTEM_INVISIBLE, 0); - IsChecked: array[Boolean] of Integer = (0, STATE_SYSTEM_CHECKED); - IsExpanded: array[Boolean] of Integer = (0, STATE_SYSTEM_EXPANDED); - IsCollapsed: array[Boolean] of Integer = (0, STATE_SYSTEM_COLLAPSED); -begin - Result := S_OK; -// VariantInit(pvarState); -// TVarData(pvarState).VType := VT_I4; - if varChild = childid_self then - begin - if FVirtualTree <> nil then - begin - pvarState := STATE_SYSTEM_FOCUSED or STATE_SYSTEM_FOCUSABLE or STATE_SYSTEM_HOTTRACKED; - pvarState := pvarState or IsVisible[FVirtualTree.Visible]; - pvarState := pvarState or IsEnabled[FVirtualTree.Enabled]; - if fVirtualTree.FocusedNode <> nil then - begin - pvarState := pvarState or IsChecked[csCheckedNormal = FVirtualTree.FocusedNode.CheckState]; - pvarState := pvarState or IsExpanded[VSExpanded in FVirtualTree.FocusedNode.States]; - if not (vsExpanded in FVirtualTree.FocusedNode.States) then - pvarState:= PvarState or IsCollapsed[vsHasChildren in FVirtualTree.FocusedNode.States]; - end; - end - else - Result := E_INVALIDARG; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- -function TVirtualTreeItemAccessibility.Get_accValue(varChild: OleVariant; out pszValue: WideString): HResult; -// for a TreeView item, the value is the nesting level number, 0-based. -begin - pszValue := ''; - Result := S_FALSE;//DISP_E_MEMBERNOTFOUND; - if varChild = childid_self then - if FVirtualTree <> nil then - if FVirtualTree.FocusedNode <> nil then - begin - PSZValue := IntToStr(FVirtualTree.GetNodeLevel(FVirtualTree.FocusedNode)); - result := S_OK; - end; -end; - -{ TVTMultiColumnItemAccessibility } - -function TVTMultiColumnItemAccessibility.GetItemDescription( - varChild: OleVariant; out pszDescription: WideString; - IncludeMainColumn: boolean): HResult; -var - I: Integer; - sTemp: WideString; -begin - pszDescription := ''; - Result := S_FALSE; - if varChild = childid_self then - begin - if FVirtualTree <> nil then - if FVirtualTree.FocusedNode <> nil then - begin - if IncludeMainColumn then - pszDescription := FVirtualTree.Text[FVirtualTree.FocusedNode, FVirtualTree.Header.MainColumn] - +'; '; - for I := 0 to FVirtualTree.Header.Columns.Count - 1 do - if FVirtualTree.Header.MainColumn <> I then - begin - sTemp := FVirtualTree.Text[FVirtualTree.FocusedNode, I]; - if sTemp <> '' then - pszDescription := pszDescription - +FVirtualTree.Header.Columns[I].Text - +': ' - +sTemp - +'; '; - end; - if pszDescription <> '' then - if pszDescription[Length(pszDescription)-1] = ';' then - Delete(pszDescription, length(pszDescription)-1, 2); - result := S_OK; - end - else begin - PSZDescription := FVirtualTree.DefaultText; - result := S_OK; - end; - end; -end; - -function TVTMultiColumnItemAccessibility.Get_accDescription( - varChild: OleVariant; out pszDescription: WideString): HResult; -begin - result := GetItemDescription(varChild, pszDescription, false) -end; - -function TVTMultiColumnItemAccessibility.Get_accName(varChild: OleVariant; - out pszName: WideString): HResult; -begin - result := GetItemDescription(varChild, pszName, true) -end; - -{ TVTDefaultAccessibleProvider } - -function TVTDefaultAccessibleProvider.CreateIAccessible( - ATree: TBaseVirtualTree): IAccessible; -begin - result := TVirtualTreeAccessibility.Create(TVirtualStringTree(ATree)); -end; - -{ TVTDefaultAccessibleItemProvider } - -function TVTDefaultAccessibleItemProvider.CreateIAccessible( - ATree: TBaseVirtualTree): IAccessible; -begin - result := TVirtualTreeItemAccessibility.Create(TVirtualStringTree(ATree)); -end; - -{ TVTMultiColumnAccessibleItemProvider } - -function TVTMultiColumnAccessibleItemProvider.CreateIAccessible( - ATree: TBaseVirtualTree): IAccessible; -begin - result := nil; - if TVirtualStringTree(ATree).Header.UseColumns then - result := TVTMultiColumnItemAccessibility.Create(TVirtualStringTree(ATree)); -end; - -var - IDefaultAccessibleProvider: TVTDefaultAccessibleProvider; - IDefaultAccessibleItemProvider: TVTDefaultAccessibleItemProvider; - IMultiColumnAccessibleProvider: TVTMultiColumnAccessibleItemProvider; - -initialization - if VTAccessibleFactory = nil then - VTAccessibleFactory := TVTAccessibilityFactory.Create; - if IDefaultAccessibleProvider = nil then - begin - IDefaultAccessibleProvider := TVTDefaultAccessibleProvider.Create; - VTAccessibleFactory.RegisterAccessibleProvider(IDefaultAccessibleProvider); - end; - if IDefaultAccessibleItemProvider = nil then - begin - IDefaultAccessibleItemProvider := TVTDefaultAccessibleItemProvider.Create; - VTAccessibleFactory.RegisterAccessibleProvider(IDefaultAccessibleItemProvider); - end; - if IMultiColumnAccessibleProvider = nil then - begin - IMultiColumnAccessibleProvider := TVTMultiColumnAccessibleItemProvider.Create; - VTAccessibleFactory.RegisterAccessibleProvider(IMultiColumnAccessibleProvider); - end; -finalization - if VTAccessibleFactory <> nil then - begin - VTAccessibleFactory.UnRegisterAccessibleProvider(IMultiColumnAccessibleProvider); - IMultiColumnAccessibleProvider := nil; - VTAccessibleFactory.UnRegisterAccessibleProvider(IDefaultAccessibleItemProvider); - IDefaultAccessibleItemProvider := nil; - VTAccessibleFactory.UnRegisterAccessibleProvider(IDefaultAccessibleProvider); - IDefaultAccessibleProvider := nil; - end; - -end. - diff --git a/components/virtualtreeview/VTAccessibilityFactory.pas b/components/virtualtreeview/VTAccessibilityFactory.pas deleted file mode 100644 index 1b582a3d2..000000000 --- a/components/virtualtreeview/VTAccessibilityFactory.pas +++ /dev/null @@ -1,123 +0,0 @@ -unit VTAccessibilityFactory; - -// 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 tthe 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 - Classes, oleacc, VirtualTrees; - -type - IVTAccessibleProvider = interface - function CreateIAccessible(ATree: TBaseVirtualTree): IAccessible; - end; - - TVTAccessibilityFactory = class(TObject) - private - FAccessibleProviders: TInterfaceList; - public - constructor Create; - destructor Destroy; override; - function CreateIAccessible(ATree: TBaseVirtualTree): IAccessible; - procedure RegisterAccessibleProvider(AProvider: IVTAccessibleProvider); - procedure UnRegisterAccessibleProvider(AProvider: IVTAccessibleProvider); - end; - -var - VTAccessibleFactory: TVTAccessibilityFactory; - -implementation - -{ TVTAccessibilityFactory } - -constructor TVTAccessibilityFactory.Create; -begin - inherited; - 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 begin - result := ATree.AccessibleItem; - end; - end; -end; - -destructor TVTAccessibilityFactory.Destroy; -begin - FAccessibleProviders.Free; - FAccessibleProviders := nil; - inherited; -end; - -procedure TVTAccessibilityFactory.RegisterAccessibleProvider( - 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( - AProvider: IVTAccessibleProvider); -// Unregisters/removes an IAccessible provider if it is present -begin - if FAccessibleProviders.IndexOf(AProvider) >= 0 then - FAccessibleProviders.Remove(AProvider); -end; - -end. diff --git a/components/virtualtreeview/VTConfig.inc b/components/virtualtreeview/VTConfig.inc deleted file mode 100644 index 94b4c9cf0..000000000 --- a/components/virtualtreeview/VTConfig.inc +++ /dev/null @@ -1,36 +0,0 @@ -// Configuration file for VirtualTrees.pas (see www.soft-gems.net). -// -// The content of this file is public domain. You may do with it whatever you like, provided the header stays fully intact -// in all version and derivative work. -// -// The original code is VTConfig.inc, released October 5, 2004. -// -// The initial developer of the original code is Mike Lischke (public@soft-gems.net, www.soft-gems.net). -//---------------------------------------------------------------------------------------------------------------------- - -{.$define UseFlatScrollbars} -{.$define ReverseFullExpandHotKey} // Used to define Ctrl+'+' instead of Ctrl+Shift+'+' for full expand (and similar for collapsing). - -// Enable this switch for Windows XP theme support. If you compile with Delphi 6 or lower you must download and install -// the Soft Gems Theme Manager package. -{.$define ThemeSupport} - -// Virtual Treeview can use a tiny but very effective local memory manager for node allocation. -// The local memory manager was implemented by David Clark from Caelo Software Inc. -// See below for more info about it. -{.$define UseLocalMemoryManager} - -{.$define TntSupport} // Added by Igor Afanasyev to support unicode-aware inplace editors. This implementation uses - // Troy Wolbrink's TNT controls, which can be found at: - // http://home.ccci.org/wolbrink/tnt/delphi_unicode_controls.htm. - -//Lazarus port options -{$define EnableOLE} -{.$define EnableNativeTVM} -{.$define EnablePrint} -{$define NeedWindows} -{.$define EnableNCFunctions} -{.$define EnableAdvancedGraphics} -{.$define EnableHeader} -{.$define EnableTimer} -{.$define EnableAccessible} diff --git a/components/virtualtreeview/VTHeaderPopup.pas b/components/virtualtreeview/VTHeaderPopup.pas deleted file mode 100644 index d2b7751f9..000000000 --- a/components/virtualtreeview/VTHeaderPopup.pas +++ /dev/null @@ -1,251 +0,0 @@ -unit VTHeaderPopup; - -//---------------------------------------------------------------------------------------------------------------------- -// 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. -// -// September 2004: -// - Bug fix: TVTHeaderPopupMenu.OnMenuItemClick used the wrong Tag member for the event. -// -// Modified 12 Dec 2003 by Ralf Junker . -// - Added missing default storage specifier for Options property. -// - To avoid mixing up image lists of different trees sharing the same header -// popup, set the popup's image list to nil if hoShowImages is not in the -// tree's header options. -// - Added an additional check for the PopupComponent property before casting -// it hardly to a Virtual Treeview in OnMenuItemClick. See entry 31 Mar 2003. -// -// 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. -// -// 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. -//---------------------------------------------------------------------------------------------------------------------- - -{$I Compilers.inc} - -interface - -uses - {$ifdef TNT} - TntMenus, - {$else} - Menus, - {$endif TNT} - VirtualTrees; - -type - TVTHeaderPopupOption = ( - poOriginalOrder, // Show menu items in original column order as they were added to the tree. - poAllowHideAll // Allows to hide all columns, including the last one. - ); - TVTHeaderPopupOptions = set of TVTHeaderPopupOption; - - TAddPopupItemType = ( - apNormal, - apDisabled, - apHidden - ); - - TAddHeaderPopupItemEvent = procedure(const Sender: TBaseVirtualTree; const Column: TColumnIndex; - var Cmd: TAddPopupItemType) of object; - TColumnChangeEvent = procedure(const Sender: TBaseVirtualTree; const Column: TColumnIndex; Visible: Boolean) of object; - - {$ifdef TNT} - TVTMenuItem = TTntMenuItem; - {$else} - TVTMenuItem = TMenuItem; - {$endif} - - {$ifdef TNT} - TVTHeaderPopupMenu = class(TTntPopupMenu) - {$else} - TVTHeaderPopupMenu = class(TPopupMenu) - {$endif} - private - FOptions: TVTHeaderPopupOptions; - - FOnAddHeaderPopupItem: TAddHeaderPopupItemEvent; - FOnColumnChange: TColumnChangeEvent; - protected - procedure DoAddHeaderPopupItem(const Column: TColumnIndex; out Cmd: TAddPopupItemType); virtual; - procedure DoColumnChange(Column: TColumnIndex; Visible: Boolean); virtual; - procedure OnMenuItemClick(Sender: TObject); - public - procedure Popup(x, y: Integer); override; - published - property Options: TVTHeaderPopupOptions read FOptions write FOptions default []; - - property OnAddHeaderPopupItem: TAddHeaderPopupItemEvent read FOnAddHeaderPopupItem write FOnAddHeaderPopupItem; - property OnColumnChange: TColumnChangeEvent read FOnColumnChange write FOnColumnChange; - end; - -//---------------------------------------------------------------------------------------------------------------------- - -implementation - -uses - {$ifdef TNT} - TnTClasses - {$else} - Classes - {$endif TNT}; - -type - TVirtualTreeCast = class(TBaseVirtualTree); // Necessary to make the header accessible. - -//----------------- TVTHeaderPopupMenu --------------------------------------------------------------------------------- - -procedure TVTHeaderPopupMenu.DoAddHeaderPopupItem(const Column: TColumnIndex; out Cmd: TAddPopupItemType); - -begin - Cmd := apNormal; - if Assigned(FOnAddHeaderPopupItem) then - FOnAddHeaderPopupItem(TVirtualTreeCast(PopupComponent), Column, Cmd); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTHeaderPopupMenu.DoColumnChange(Column: TColumnIndex; Visible: Boolean); - -begin - if Assigned(FOnColumnChange) then - FOnColumnChange(TVirtualTreeCast(PopupComponent), Column, Visible); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTHeaderPopupMenu.OnMenuItemClick(Sender: TObject); - -begin - if Assigned(PopupComponent) and (PopupComponent is TBaseVirtualTree) then - with TVTMenuItem(Sender), - TVirtualTreeCast(PopupComponent).Header.Columns.Items[Tag] do - begin - if Checked then - Options := Options - [coVisible] - else - Options := Options + [coVisible]; - - DoColumnChange(TVTMenuItem(Sender).Tag, not Checked); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTHeaderPopupMenu.Popup(x, y: Integer); - -var - I: Integer; - ColPos: TColumnPosition; - ColIdx: TColumnIndex; - - NewMenuItem: TVTMenuItem; - Cmd: TAddPopupItemType; - - VisibleCounter: Cardinal; - VisibleItem: TVTMenuItem; - -begin - if Assigned(PopupComponent) and (PopupComponent is TBaseVirtualTree) then - begin - // Delete existing menu items. - I := Items.Count; - while I > 0 do - begin - Dec(I); - Items[I].Free; - end; - - // Add column menu items. - with TVirtualTreeCast(PopupComponent).Header do - begin - if hoShowImages in Options then - Self.Images := Images - else - // Remove a possible reference to image list of another tree previously assigned. - Self.Images := nil; - VisibleItem := nil; - VisibleCounter := 0; - for ColPos := 0 to Columns.Count - 1 do - begin - if poOriginalOrder in FOptions then - ColIdx := ColPos - else - ColIdx := Columns.ColumnFromPosition(ColPos); - - with Columns[ColIdx] do - begin - if coVisible in Options then - Inc(VisibleCounter); - DoAddHeaderPopupItem(ColIdx, Cmd); - if Cmd <> apHidden then - begin - NewMenuItem := TVTMenuItem.Create(Self); - NewMenuItem.Tag := ColIdx; - NewMenuItem.Caption := Text; - NewMenuItem.Hint := Hint; - NewMenuItem.ImageIndex := ImageIndex; - NewMenuItem.Checked := coVisible in Options; - NewMenuItem.OnClick := OnMenuItemClick; - if Cmd = apDisabled then - NewMenuItem.Enabled := False - else - if coVisible in Options then - VisibleItem := NewMenuItem; - Items.Add(NewMenuItem); - end; - end; - end; - - // Conditionally disable menu item of last enabled column. - if (VisibleCounter = 1) and (VisibleItem <> nil) and not (poAllowHideAll in FOptions) then - VisibleItem.Enabled := False; - end; - end; - - inherited; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -end. - diff --git a/components/virtualtreeview/VirtualTrees.pas b/components/virtualtreeview/VirtualTrees.pas deleted file mode 100644 index c4a2408f1..000000000 --- a/components/virtualtreeview/VirtualTrees.pas +++ /dev/null @@ -1,32122 +0,0 @@ -unit VirtualTrees; - -{$mode delphi}{$H+} - -// Version 4.5.1 -// -// 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. -//---------------------------------------------------------------------------------------------------------------------- -// -// January 2007 -// - Improvement: added code donation from Marco Zehe (with help from Sebastian Modersohn) which implements the -// MS accessability interface for Virtual Treeview. -// December 2006 -// - Improvement: bidi mode implementation finished (toAutoBidiColumnOrdering introduced) -// - Change: right-to-left flag removed from shorten string methods/events (not necessary) -// - Version is now 4.5.0 -// November 2006 -// - Bug fix: Total height is wrong on reading from stream -// September 2006 -// - Bug fix: Mantis issue #326 -// July 2006 -// - Change: value for crHeaderSplit cursor conflicts with other resource IDs, so I changed it. -// - Published OnStartDrag in VirtualDrawTree. -// April 2006 -// - Bug fix: check for MMX availabiltiy is missing in some places before calling MMX code -// - Bug fix: flag for VCL dragging was removed too late causing all kind of problems with mouse up code in VCL drag mode. -// - Bug fix: If the past mode in ProcessOLEData is amInsertAfter then nodes where inserted in the wrong order. -// March 2006 -// - Bug fix: total count and total height is wrong after loading from stream -// - Bug fix: variable node height computation -// - Bug fix: FLastChangedNode was not reset in DoFreeNode -// February 2006 -// - Improvement: GetFirstChecked now also has a default value for its state parameter. -// - Improvement: avoid potential reentrancy problems in paint code by checking for the paint state there. -// January 2006 -// - Bug fix: disabled images are now drawn like enabled ones (with respect to position, indices etc.). -// - Improvement: New property BottomSpace, allows to specify an additional area below the last node in the tree. -// - Bug fix: VT.EndUpdate did not invalidate the cache so the cache was never used again after that. -// - Improvement: tree states for double clicks (left, middle, right). -// December 2005 -// - Bug fix: check for column index for auto setting main column if the current one is deleted. -// -// For full document history see help file. -// -// Credits for their valuable assistance and code donations go to: -// Freddy Ertl, Marian Aldenhövel, Thomas Bogenrieder, Jim Kuenemann, Werner Lehmann, Jens Treichler, -// Paul Gallagher (IBO tree), Ondrej Kelle, Ronaldo Melo Ferraz, Heri Bender, Roland Bedürftig (BCB) -// 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 -// Beta testers: -// Freddy Ertl, Hans-Jürgen Schnorrenberg, Werner Lehmann, Jim Kueneman, Vadim Sedulin, Moritz Franckenstein, -// Wim van der Vegt, Franc v/d Westelaken -// Indirect contribution (via publicly accessible work of those persons): -// Alex Denissov, Hiroyuki Hori (MMXAsm expert) -// Documentation: -// Markus Spoettl and toolsfactory GbR (http://www.doc-o-matic.com/, sponsoring Soft Gems development -// with a free copy of the Doc-O-Matic help authoring system), Sven H. (Step by step tutorial) -// CLX: -// Dmitri Dmitrienko (initial developer) -// Source repository: -// Subversion (server), TortoiseSVN (client tools), Fisheye (Web interface) -// Accessability implementation: -// Marco Zehe (with help from Sebastian Modersohn) -// LCL Port (version 4.5.1): -// Luiz Américo Pereira Câmara -//---------------------------------------------------------------------------------------------------------------------- - -interface - -{$booleval off} // Use fastest possible boolean evaluation. - -{$I Compilers.inc} -{$I VTConfig.inc} - -{$ifdef COMPILER_7_UP} - // 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} -{$endif COMPILER_7_UP} - -{$HPPEMIT '#include '} -{$HPPEMIT '#include '} // Necessary for BCB 6 SP 2. - -uses - {$ifdef NeedWindows} - - {$endif} - Windows, vtlogger, LCLType, LResources, LCLIntf, LMessages, Types, - SysUtils, Classes, Graphics, Controls, Forms, ImgList, StdCtrls, Menus, Printers, - CommCtrl, // image lists, common controls tree structures - SyncObjs // Thread support - //Clipbrd // Clipboard support - {$ifdef ThemeSupport} - {$ifndef COMPILER_7_UP} - , ThemeSrv, TMSchema, UxTheme // Windows XP themes support. Get these units from www.soft-gems.net - {$else} - , Themes, UxTheme - {$endif COMPILE_7_UP} - {$endif ThemeSupport} - {$ifdef TntSupport} - , TntStdCtrls // Unicode aware inplace editor. - {$endif TntSupport} - {$ifdef EnableAccessible} - , oleacc // for MSAA IAccessible support - {$endif} - {$ifdef EnableOLE} - , ActiveX, - OleUtils - {$endif} - ; - -const - {$I lclconstants.inc} - - VTVersion = '4.5.1'; - VTTreeStreamVersion = 2; - VTHeaderStreamVersion = 3; // 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. - - // 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; - - // Need to use this message to release the edit link interface asynchronously. - WM_CHANGESTATE = WM_APP + 32; - - // 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)); - CLSID_DragDropHelper: TGUID = (D1: $4657278A; D2: $411B; D3: $11D2; D4: ($83, $9A, $00, $C0, $4F, $D9, $18, $D0)); - - SID_IDropTargetHelper = '{4657278B-411B-11D2-839A-00C04FD918D0}'; - SID_IDragSourceHelper = '{DE5BF786-477A-11D2-839D-00C04FD918D0}'; - SID_IDropTarget = '{00000122-0000-0000-C000-000000000046}'; - - // 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); - - UtilityImageSize = 16; // Needed by descendants for hittests. - -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; - - MMXAvailable: Boolean; // necessary to know because the blend code uses MMX instructions - - IsWinNT: Boolean; // Necessary to fix bugs in Win95/WinME (non-client area region intersection, edit resize) - // and to allow for check of system dependent hint animation. - - {$MinEnumSize 1, make enumerations as small as possible} - -type - {$I lcltypes.inc} - // The exception used by the trees. - EVirtualTreeError = class(Exception); - - PCardinal = ^Cardinal; - - // Limits the speed interval which can be used for auto scrolling (milliseconds). - TAutoScrollInterval = 1..1000; - - // Need to declare the correct WMNCPaint record as the VCL (D5-) doesn't. - TRealWMNCPaint = packed record - Msg: Cardinal; - Rgn: HRGN; - lParam: Integer; - Result: Integer; - end; - - // The next two message records are not declared in Delphi 6 and lower. - TWMPrint = packed record - Msg: Cardinal; - DC: HDC; - Flags: Cardinal; - Result: Integer; - end; - - TWMPrintClient = TWMPrint; - - { .$ifndef COMPILER_5_UP} - TLMContextMenu = TLMMouse; - { .$endif COMPILER_5_UP} - - // 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. - // Do not reorder the states and always add new states at the end of this enumeration in order to avoid - // breaking existing code. - TVirtualNodeState = ( - vsInitialized, // Set after the node has been initialized. - vsChecking, // Node's check state is changing, avoid propagation. - vsCutOrCopy, // Node is selected as cut or copy and paste source. - vsDisabled, // Set if node is disabled. - vsDeleting, // Set when the node is about to be freed. - vsExpanded, // Set if the node is expanded. - vsHasChildren, // Indicates the presence of child nodes without actually setting them. - vsVisible, // Indicate whether the node is visible or not (independant of the expand states of its parents). - vsSelected, // Set if the node is in the current selection. - vsInitialUserData, // Set if (via AddChild or InsertNode) initial user data has been set which requires OnFreeNode. - vsAllChildrenHidden, // Set if vsHasChildren is set and no child node has the vsVisible flag set. - vsClearing, // A node's children are being deleted. Don't register structure change event. - vsMultiline, // Node text is wrapped at the cell boundaries instead of being shorted. - vsHeightMeasured, // Node height has been determined and does not need a recalculation. - vsToggling // Set when a node is expanded/collapsed to prevent recursive calls. - ); - TVirtualNodeStates = set of TVirtualNodeState; - - // States used in InitNode to indicate states a node shall initially have. - TVirtualNodeInitState = ( - ivsDisabled, - ivsExpanded, - ivsHasChildren, - ivsMultiline, - ivsSelected - ); - TVirtualNodeInitStates = set of TVirtualNodeInitState; - - TScrollBarStyle = ( - sbmRegular, - sbmFlat, - 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. - ); - TVTColumnOptions = set of TVTColumnOption; - - // These flags are returned by the hit test method. - THitPosition = ( - hiAbove, // above the client area (if relative) or the absolute tree area - hiBelow, // below the client area (if relative) or the absolute tree area - hiNowhere, // no node is involved (possible only if the tree is not as tall as the client area) - hiOnItem, // on the bitmaps/buttons or label associated with an item - hiOnItemButton, // on the button associated with an item - hiOnItemCheckbox, // on the checkbox if enabled - hiOnItemIndent, // in the indentation area in front of a node - hiOnItemLabel, // on the normal text area associated with an item - hiOnItemLeft, // in the area to the left of a node's text area (e.g. when right aligned or centered) - hiOnItemRight, // in the area to the right of a node's text area (e.g. if left aligned or centered) - hiOnNormalIcon, // on the "normal" image - hiOnStateIcon, // on the state image - hiToLeft, // to the left of the client area (if relative) or the absolute tree area - hiToRight // to the right of the client area (if relative) or the absolute tree area - ); - 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 - ); - - TCheckImageKind = ( - ckLightCheck, // gray cross - ckDarkCheck, // black cross - ckLightTick, // gray tick mark - ckDarkTick, // black tick mark - ckFlat, // flat images (no 3D border) - ckXP, // Windows XP style - ckCustom, // application defined check images - ckSystem, // System defined check images. - ckSystemFlat // Flat system defined check images. - ); - - // mode to describe a move action - TVTNodeAttachMode = ( - amNoWhere, // just for simplified tests, means to ignore the Add/Insert command - amInsertBefore, // insert node just before destination (as sibling of destination) - amInsertAfter, // insert node just after destionation (as sibling of destination) - amAddChildFirst, // add node as first child of destination - amAddChildLast // add node as last child of destination - ); - - // modes to determine drop position further - TDropMode = ( - dmNowhere, - dmAbove, - dmOnNode, - dmBelow - ); - - // operations basically allowed during drag'n drop - TDragOperation = ( - doCopy, - doMove, - doLink - ); - TDragOperations = set of TDragOperation; - - TVTImageKind = ( - ikNormal, - ikSelected, - ikState, - ikOverlay - ); - - TVTHintMode = ( - hmDefault, // show the hint of the control - hmHint, // show node specific hint string returned by the application - hmHintAndDefault, // same as hmHint but show the control's hint if no node is concerned - hmTooltip // show the text of the node if it isn't already fully shown - ); - - // Indicates how to format a tooltip. - TVTTooltipLineBreakStyle = ( - hlbDefault, // Use multi-line style of the node. - hlbForceSingleLine, // Use single line hint. - hlbForceMultiLine // Use multi line hint. - ); - - TMouseButtons = set of TMouseButton; - - // Used to describe the action to do when using the OnBeforeItemErase event. - TItemEraseAction = ( - eaColor, // Use the provided color to erase the background instead the one of the tree. - eaDefault, // The tree should erase the item's background (bitmap or solid). - eaNone // Do nothing. Let the application paint the background. - ); - - - // 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. - ); - TVTPaintOptions = set of TVTPaintOption; - - // Options to toggle animation support: - TVTAnimationOption = ( - toAnimatedToggle // Expanding and collapsing a node is animated (quick window scroll). - ); - 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. - 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 column entirely 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. - ); - TVTSelectionOptions = set of TVTSelectionOption; - - // 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. - ); - TVTMiscOptions = set of TVTMiscOption; - -const - DefaultPaintOptions = [toShowButtons, toShowDropmark, toShowTreeLines, toShowRoot, toThemeAware, - toUseBlendedImages]; - DefaultAnimationOptions = []; - DefaultAutoOptions = [toAutoDropExpand, toAutoTristateTracking, toAutoScrollOnExpand, toAutoDeleteMovedNodes]; - DefaultSelectionOptions = []; - DefaultMiscOptions = [toAcceptOLEDrop, toFullRepaintOnResize, toInitOnSave, toToggleOnDblClick, toWheelPanning]; - DefaultColumnOptions = [coAllowClick, coDraggable, coEnabled, coParentColor, coParentBidiMode, coResizable, - coShowDropmark, coVisible]; - -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 - Node: PVirtualNode; - AbsoluteTop: Cardinal; - end; - - TCache = array of TCacheEntry; - TNodeArray = array of PVirtualNode; - - TCustomVirtualTreeOptions = class(TPersistent) - private - FOwner: TBaseVirtualTree; - FPaintOptions: TVTPaintOptions; - FAnimationOptions: TVTAnimationOptions; - FAutoOptions: TVTAutoOptions; - FSelectionOptions: TVTSelectionOptions; - FMiscOptions: TVTMiscOptions; - 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 - property AnimationOptions: TVTAnimationOptions read FAnimationOptions write SetAnimationOptions - default DefaultAnimationOptions; - property AutoOptions: TVTAutoOptions read FAutoOptions write SetAutoOptions default DefaultAutoOptions; - 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; - public - constructor Create(AOwner: TBaseVirtualTree); virtual; - - procedure AssignTo(Dest: TPersistent); override; - - property Owner: TBaseVirtualTree read FOwner; - end; - - TTreeOptionsClass = class of TCustomVirtualTreeOptions; - - TVirtualTreeOptions = class(TCustomVirtualTreeOptions) - published - property AnimationOptions; - property AutoOptions; - property MiscOptions; - property PaintOptions; - property SelectionOptions; - end; - - // Used in the CF_VTREFERENCE clipboard format. - PVTReference = ^TVTReference; - TVTReference = record - Process: Cardinal; - Tree: TBaseVirtualTree; - end; - - TVirtualNode = packed record - Index, // index of node with regard to its parent - ChildCount: Cardinal; // number of child nodes - NodeHeight: Word; // height in pixels - States: TVirtualNodeStates; // states describing various properties of the node (expanded, initialized etc.) - Align: Byte; // line/button alignment - CheckState: TCheckState; // indicates the current check state (e.g. checked, pressed etc.) - CheckType: TCheckType; // indicates which check type shall be used for this node - Dummy: Byte; // dummy value to fill DWORD boundary - TotalCount, // sum of this node, all of its child nodes and their child nodes etc. - TotalHeight: Cardinal; // height in pixels this node covers on screen including the height of all of its - // children - Dummy2: Word; // FPC: Sets need 4 bytes / in Delphi only 2 bytes - // Note: Some copy routines require that all pointers (as well as the data area) in a node are - // located at the end of the node! Hence if you want to add new member fields (except pointers to internal - // data) then put them before field Parent. - Parent, // reference to the node's parent (for the root this contains the treeview) - PrevSibling, // link to the node's previous sibling or nil if it is the first node - NextSibling, // link to the node's next sibling or nil if it is the last node - FirstChild, // link to the node's first child... - LastChild: PVirtualNode; // link to the node's last child... - Data: record end; // this is a placeholder, each node gets extra data determined by NodeDataSize - end; - - // TVTNodeMemoryManager is a high-performance local memory manager for allocating TVirtualNode structures. - // It is not thread-safe in itself, because it assumes that the virtual tree is being used within a single - // thread. The local memory manager supports only fixed-length allocation requests - all requests must be of - // the same size. The performance improvements are a result of TVTNodeMemoryManager getting 16K blocks - // of memory from the Delphi memory manager and then managing them in a highly efficient manner. - // A consequence is that node memory allocations/deallocations are not visible to memory debugging tools. - // - // The local memory manager is disabled by default - to enable it {$define UseLocalMemoryManager}. For smaller trees, - // say less than 10,000 nodes, there is really no major performance benefit in using the local memory manager. - {$ifdef UseLocalMemoryManager} - TVTNodeMemoryManager = class - private - FAllocSize: Cardinal; // The memory allocated for each node - FBlockList: TList; // List of allocated blocks - FBytesAvailable: Cardinal; // Bytes available in current block - FNext: PVirtualNode; // Pointer to next available node in current block - FFreeSpace: PVirtualNode; // Pointer to free space chain - public - constructor Create; - destructor Destroy; override; - - function AllocNode(const Size: Cardinal): PVirtualNode; - procedure FreeNode(const Node: PVirtualNode); - procedure Clear; - end; - {$endif UseLocalMemoryManager} - - // structure used when info about a certain position in the tree is needed - THitInfo = record - HitNode: PVirtualNode; - HitPositions: THitPositions; - HitColumn: TColumnIndex; - end; - - // auto scroll directions - TScrollDirections = set of ( - sdLeft, - sdUp, - sdRight, - sdDown - ); - - {$ifdef EnableOLE} - - // 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; AFormatEtcArray: TFormatEtcArray); - - function Clone(out Enum: IEnumFormatEtc): HResult; stdcall; - function Next(celt: LongWord; out elt: FormatEtc; out pceltFetched: LongWord): HResult; stdcall; - function Reset: HResult; stdcall; - function Skip(celt: LongWord): HResult; stdcall; - end; - - // ----- OLE drag'n drop handling - - { 01.05.2006 Jim - Problem with BDS2006 C++ compiler and ambiguous defines} - {$EXTERNALSYM IDropTargetHelper} - - IDropTargetHelper = interface(IUnknown) - [SID_IDropTargetHelper] - function DragEnter(hwndTarget: HWND; pDataObject: IDataObject; var ppt: TPoint; dwEffect: Integer): HRESULT; stdcall; - function DragLeave: HRESULT; stdcall; - function DragOver(var ppt: TPoint; dwEffect: Integer): HRESULT; stdcall; - function Drop(pDataObject: IDataObject; var ppt: TPoint; dwEffect: Integer): HRESULT; stdcall; - function Show(fShow: Boolean): HRESULT; stdcall; - end; - - PSHDragImage = ^TSHDragImage; - TSHDragImage = packed record - sizeDragImage: TSize; - ptOffset: TPoint; - hbmpDragImage: HBITMAP; - ColorRef: TColorRef; - end; - - IDragSourceHelper = interface(IUnknown) - [SID_IDragSourceHelper] - function InitializeFromBitmap(var SHDragImage: TSHDragImage; pDataObject: IDataObject): HRESULT; stdcall; - function InitializeFromWindow(Window: HWND; var ppt: TPoint; pDataObject: IDataObject): HRESULT; stdcall; - end; - - 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; - - // 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(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; 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: DWord; const advSink: IAdviseSink; out dwConnection: DWord): - HResult; virtual; stdcall; - function DUnadvise(dwConnection: DWord): HResult; virtual; stdcall; - Function EnumDAvise(Out enumAdvise : IEnumStatData):HResult;virtual;StdCall; - function EnumFormatEtc(Direction: DWord; out EnumFormatEtc: IEnumFormatEtc): HResult; virtual; stdcall; - Function GetCanonicalFormatTEtc(const pformatetcIn : FORMATETC;Out pformatetcOut : FORMATETC):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: LongWord; Pt: TPoint; - var Effect: LongWord): HResult; stdcall; - function DragLeave: HResult; stdcall; - function DragOver(KeyState: LongWord; Pt: TPoint; var Effect: LongWord): HResult; stdcall; - function Drop(const DataObject: IDataObject; KeyState: LongWord; Pt: TPoint; var Effect: LongWord): HResult; stdcall; - procedure ForceDragLeave; stdcall; - function GiveFeedback(Effect: Integer): HResult; stdcall; - function QueryContinueDrag(EscapePressed: BOOL; KeyState: Integer): HResult; stdcall; - end; - - {$endif}//enableOLE - - PVTHintData = ^TVTHintData; - TVTHintData = record - Tree: TBaseVirtualTree; - Node: PVirtualNode; - Column: TColumnIndex; - HintRect: TRect; // used for draw trees only, string trees get the size from the hint string - DefaultHint: WideString; // used only if there is no node specific hint string available - // or a header hint is about to appear - HintText: WideString; // set when size of the hint window is calculated - BidiMode: TBidiMode; - Alignment: TAlignment; - LineBreakStyle: TVTToolTipLineBreakStyle; - end; - - // Determines the kind of animation when a hint is activated. - THintAnimationType = ( - hatNone, // no animation at all, just display hint/tooltip - hatFade, // fade in the hint/tooltip, like in Windows 2000 - hatSlide, // slide in the hint/tooltip, like in Windows 98 - hatSystemDefault // use what the system is using (slide for Win9x, slide/fade for Win2K+, depends on settings) - ); - - // The trees need an own hint window class because of Unicode output and adjusted font. - TVirtualTreeHintWindow = class(THintWindow) - private - FHintData: TVTHintData; - FBackground, - FDrawBuffer, - FTarget: TBitmap; - FTextHeight: Integer; - FBidiMode: TBidiMode; - function AnimationCallback(Step, StepSize: Integer; Data: Pointer): Boolean; - procedure InternalPaint(Step, StepSize: Integer); - procedure CMTextChanged(var Message: TLMessage); message CM_TEXTCHANGED; - procedure WMEraseBkgnd(var Message: TLMEraseBkgnd); message LM_ERASEBKGND; - procedure WMNCPaint(var Message: TLMessage); message LM_NCPAINT; - procedure WMShowWindow(var Message: TLMShowWindow); message LM_SHOWWINDOW; - protected - procedure CreateParams(var Params: TCreateParams); override; - - procedure Paint; override; - public - constructor Create(AOwner: TComponent); override; - destructor Destroy; override; - - procedure ActivateHint(Rect: TRect; const AHint: string); override; - function CalcHintRect(MaxWidth: Integer; const AHint: string; AData: Pointer): TRect; override; - function IsHintMsg(var Msg: TMsg): Boolean; {override;} - property BidiMode: TBidiMode read FBidiMode write FBidiMode; - 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) - protected - procedure InternalShowDragImage(ScreenDC: HDC); - procedure MakeAlphaChannel(Source, Target: TBitmap); - 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 RecaptureBackground(Tree: TBaseVirtualTree; 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 MoveRestriction: TVTDragMoveRestriction read FRestriction write FRestriction default dmrNone; - property PostBlendBias: TVTBias read FPostBlendBias write FPostBlendBias default 0; - property PreBlendBias: TVTBias read FPreBlendBias write FPreBlendBias default 0; - property Transparency: TVTTransparency read FTransparency write FTransparency default 128; - property Visible: Boolean read GetVisible; - end; - - // tree columns implementation - TVirtualTreeColumns = class; - TVTHeader = class; - - TVirtualTreeColumnStyle = ( - vsText, - vsOwnerDraw - ); - - {$ifndef COMPILER_5_UP} - TImageIndex = Integer; - {$endif COMPILER_5_UP} - - TVTHeaderColumnLayout = ( - blGlyphLeft, - blGlyphRight, - blGlyphTop, - blGlyphBottom - ); - - TVirtualTreeColumn = class(TCollectionItem) - private - FText, - FHint: WideString; - FLeft, - FWidth: Integer; - FPosition: TColumnPosition; - FMinWidth: Integer; - FMaxWidth: Integer; - FStyle: TVirtualTreeColumnStyle; - FImageIndex: TImageIndex; - FBiDiMode: TBiDiMode; - FLayout: TVTHeaderColumnLayout; - FMargin, - FSpacing: Integer; - FOptions: TVTColumnOptions; - FTag: Integer; - FAlignment: TAlignment; - FLastWidth: Integer; - FColor: TColor; - FSpringRest: Single; // Accumulator for width adjustment when auto spring option is enabled. - function GetLeft: Integer; - function IsBiDiModeStored: Boolean; - function IsColorStored: Boolean; - procedure SetAlignment(const Value: TAlignment); - procedure SetBiDiMode(Value: TBiDiMode); - procedure SetColor(const Value: TColor); - procedure SetImageIndex(Value: TImageIndex); - procedure SetLayout(Value: TVTHeaderColumnLayout); - procedure SetMargin(Value: Integer); - procedure SetMaxWidth(Value: Integer); - procedure SetMinWidth(Value: Integer); - procedure SetOptions(Value: TVTColumnOptions); - procedure SetPosition(Value: TColumnPosition); - procedure SetSpacing(Value: Integer); - procedure SetStyle(Value: TVirtualTreeColumnStyle); - procedure SetText(const Value: WideString); - procedure SetWidth(Value: Integer); - protected - procedure ComputeHeaderLayout(DC: HDC; const Client: TRect; UseHeaderGlyph, UseSortGlyph: Boolean; - var HeaderGlyphPos, SortGlyphPos: TPoint; var TextBounds: TRect); virtual; - procedure DefineProperties(Filer: TFiler); override; - procedure GetAbsoluteBounds(var Left, Right: Integer); - function GetDisplayName: string; override; - function GetOwner: TVirtualTreeColumns; reintroduce; - procedure ReadHint(Reader: TReader); - procedure ReadText(Reader: TReader); - procedure WriteHint(Writer: TWriter); - procedure WriteText(Writer: TWriter); - public - constructor Create(Collection: TCollection); override; - destructor Destroy; override; - - procedure Assign(Source: TPersistent); override; - function Equals(OtherColumn: TVirtualTreeColumn): Boolean; virtual; - function GetRect: TRect; virtual; - procedure LoadFromStream(const Stream: TStream; Version: Integer); - procedure ParentBiDiModeChanged; - procedure ParentColorChanged; - procedure RestoreLastWidth; - procedure SaveToStream(const Stream: TStream); - function UseRightToLeftReading: Boolean; - - property Left: Integer read GetLeft; - property Owner: TVirtualTreeColumns read GetOwner; - published - property Alignment: TAlignment read FAlignment write SetAlignment default taLeftJustify; - property BiDiMode: TBiDiMode read FBiDiMode write SetBiDiMode stored IsBiDiModeStored default bdLeftToRight; - property Color: TColor read FColor write SetColor stored IsColorStored default clWindow; - property Hint: WideString read FHint write FHint stored False; - property ImageIndex: TImageIndex read FImageIndex write SetImageIndex default -1; - property Layout: TVTHeaderColumnLayout read FLayout write SetLayout default blGlyphLeft; - property Margin: Integer read FMargin write SetMargin default 4; - property MaxWidth: Integer read FMaxWidth write SetMaxWidth default 10000; - property MinWidth: Integer read FMinWidth write SetMinWidth default 10; - property Options: TVTColumnOptions read FOptions write SetOptions default DefaultColumnOptions; - property Position: TColumnPosition read FPosition write SetPosition; - property Spacing: Integer read FSpacing write SetSpacing default 4; - property Style: TVirtualTreeColumnStyle read FStyle write SetStyle default vsText; - property Tag: Integer read FTag write FTag default 0; - property Text: WideString read FText write SetText stored False; // Never let the VCL store the wide string, - // it is simply unable to write it correctly. - // We use DefineProperties here. - property Width: Integer 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; // last clicked column - FPositionToIndex: TIndexArray; - 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. - - // 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 - function GetItem(Index: TColumnIndex): TVirtualTreeColumn; - function GetNewIndex(P: TPoint; var OldIndex: TColumnIndex): Boolean; - procedure SetItem(Index: TColumnIndex; Value: TVirtualTreeColumn); - protected - procedure AdjustAutoSize(CurrentIndex: TColumnIndex; Force: Boolean = False); - function AdjustDownColumn(P: TPoint): TColumnIndex; - function AdjustHoverColumn(P: TPoint): Boolean; - procedure AdjustPosition(Column: TVirtualTreeColumn; Position: Cardinal); - procedure DrawButtonText(DC: HDC; Caption: WideString; Bounds: TRect; Enabled, Hot: Boolean; DrawFormat: Cardinal); - procedure DrawXPButton(DC: HDC; ButtonR: TRect; DrawSplitter, Down, Hover: Boolean); - procedure FixPositions; - function GetColumnAndBounds(P: TPoint; var ColumnLeft, ColumnRight: Integer; Relative: Boolean = True): Integer; - function GetOwner: TPersistent; override; - procedure HandleClick(P: TPoint; Button: TMouseButton; Force, DblClick: Boolean); - procedure IndexChanged(OldIndex, NewIndex: Integer); - procedure InitializePositionArray; - procedure ReorderColumns(RTL: Boolean); - procedure Update(Item: TCollectionItem); override; - procedure UpdatePositions(Force: Boolean = False); - - property HeaderBitmap: TBitmap read FHeaderBitmap; - property PositionToIndex: TIndexArray read FPositionToIndex; - public - constructor Create(AOwner: TVTHeader); - destructor Destroy; override; - - function Add: TVirtualTreeColumn; virtual; - procedure AnimatedResize(Column: TColumnIndex; NewWidth: Integer); - 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(OtherColumns: TVirtualTreeColumns): Boolean; - procedure GetColumnBounds(Column: TColumnIndex; var Left, Right: Integer); - function GetFirstVisibleColumn: TColumnIndex; - function GetLastVisibleColumn: TColumnIndex; - function GetNextColumn(Column: TColumnIndex): TColumnIndex; - function GetNextVisibleColumn(Column: TColumnIndex): TColumnIndex; - function GetPreviousColumn(Column: TColumnIndex): TColumnIndex; - function GetPreviousVisibleColumn(Column: TColumnIndex): TColumnIndex; - function GetVisibleColumns: TColumnsArray; - function GetVisibleFixedWidth: Integer; - function IsValidColumn(Column: TColumnIndex): Boolean; - procedure LoadFromStream(const Stream: TStream; Version: Integer); - procedure PaintHeader(DC: HDC; R: TRect; HOffset: Integer); virtual; - procedure SaveToStream(const Stream: TStream); - function TotalWidth: Integer; - - property ClickIndex: TColumnIndex read FClickIndex; - property Items[Index: TColumnIndex]: TVirtualTreeColumn read GetItem write SetItem; default; - property Header: TVTHeader read FHeader; - property TrackIndex: TColumnIndex read FTrackIndex; - end; - - TVirtualTreeColumnsClass = class of TVirtualTreeColumns; - - 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.) - hsXPStyle // Windows XP style - ); - - 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. hoAutoResize must be enabled too. - ); - 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. - hsTracking, // column resizing is in progress - hsTrackPending // left button is down, user might want to start resize a column - ); - THeaderStates = set of THeaderState; - - TSortDirection = ( - sdAscending, - sdDescending - ); - - // desribes what made a structure change event happen - TChangeReason = ( - crIgnore, // used as placeholder - crAccumulated, // used for delayed changes - crChildAdded, // one or more child nodes have been added - crChildDeleted, // one or more child nodes have been deleted - crNodeAdded, // a node has been added - crNodeCopied, // a node has been duplicated - crNodeMoved // a node has been moved to a new place - ); - - TVTHeader = class(TPersistent) - private - FOwner: TBaseVirtualTree; - FColumns: TVirtualTreeColumns; - FHeight: Cardinal; - FFont: TFont; - FParentFont: Boolean; - FOptions: TVTHeaderOptions; - FStates: THeaderStates; // Used to keep track of internal states the header can enter. - FTrackPos: Integer; // Left/right border of this column to quickly calculate its width on resize. - FStyle: TVTHeaderStyle; // button style - FBackground: TColor; - FAutoSizeIndex: TColumnIndex; - FPopupMenu: TPopupMenu; - FMainColumn: TColumnIndex; // the column which holds the tree - FImages: TCustomImageList; - FImageChangeLink: TChangeLink; // connections to the image list to get notified about changes - FSortColumn: TColumnIndex; - FSortDirection: TSortDirection; - FTrackStart: TPoint; // client coordinates of the tracking start point - FDragStart: TPoint; // initial mouse drag position - FDragImage: TVTDragImage; // drag image management during header drag - FLastWidth: Integer; // Used to adjust spring columns. This is the width of all visible columns, - // not the header rectangle. - procedure FontChanged(Sender: TObject); - function GetMainColumn: TColumnIndex; - function GetUseColumns: Boolean; - procedure SetAutoSizeIndex(Value: TColumnIndex); - procedure SetBackground(Value: TColor); - procedure SetColumns(Value: TVirtualTreeColumns); - procedure SetFont(const Value: TFont); - procedure SetHeight(Value: Cardinal); - procedure SetImages(const Value: TCustomImageList); - procedure SetMainColumn(Value: TColumnIndex); - procedure SetOptions(Value: TVTHeaderOptions); - procedure SetParentFont(Value: Boolean); - procedure SetSortColumn(Value: TColumnIndex); - procedure SetSortDirection(const Value: TSortDirection); - procedure SetStyle(Value: TVTHeaderStyle); - protected - function CanWriteColumns: Boolean; virtual; - procedure ChangeScale(M, D: Integer); virtual; - function DetermineSplitterIndex(P: TPoint): Boolean; virtual; - procedure DragTo(P: TPoint); - function GetColumnsClass: TVirtualTreeColumnsClass; virtual; - function GetOwner: TPersistent; override; - function GetShiftState: TShiftState; - function HandleHeaderMouseMove(var Message: TLMMouseMove): Boolean; - function HandleMessage(var Message: TLMessage): Boolean; virtual; - procedure ImageListChange(Sender: TObject); - procedure PrepareDrag(P, Start: TPoint); - procedure ReadColumns(Reader: TReader); - procedure RecalculateHeader; virtual; - procedure UpdateMainColumn; - procedure UpdateSpringColumns; - procedure WriteColumns(Writer: TWriter); - public - constructor Create(AOwner: TBaseVirtualTree); virtual; - destructor Destroy; override; - - procedure Assign(Source: TPersistent); override; - procedure AutoFitColumns(Animated: Boolean = True); - function InHeader(P: TPoint): Boolean; virtual; - procedure Invalidate(Column: TVirtualTreeColumn; ExpandToBorder: Boolean = False); - procedure LoadFromStream(const Stream: TStream); virtual; - procedure RestoreColumns; - procedure SaveToStream(const Stream: TStream); virtual; - - property DragImage: TVTDragImage read FDragImage; - property States: THeaderStates read FStates; - property Treeview: TBaseVirtualTree read FOwner; - property UseColumns: Boolean read GetUseColumns; - published - property AutoSizeIndex: TColumnIndex read FAutoSizeIndex write SetAutoSizeIndex; - property Background: TColor read FBackground write SetBackground default clBtnFace; - property Columns: TVirtualTreeColumns read FColumns write SetColumns stored False; // Stored by the owner tree to - // support VFI. - property Font: TFont read FFont write SetFont; - property Height: Cardinal read FHeight write SetHeight default 17; - property Images: TCustomImageList read FImages write SetImages; - property MainColumn: TColumnIndex read GetMainColumn write SetMainColumn default 0; - property Options: TVTHeaderOptions read FOptions write SetOptions default [hoColumnResize, hoDrag, hoShowSortGlyphs]; - property ParentFont: Boolean read FParentFont write SetParentFont default False; - 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 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. - IVTEditLink = interface - ['{2BE3EAFA-5ACB-45B4-9D9A-B58BCC496E17}'] - function BeginEdit: Boolean; stdcall; // Called when editing actually starts. - function CancelEdit: Boolean; stdcall; // Called when editing has been cancelled by the tree. - function EndEdit: Boolean; stdcall; // Called when editing has been finished by the tree. - function PrepareEdit(Tree: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex): Boolean; stdcall; - // Called after creation to allow a setup. - function GetBounds: TRect; stdcall; // Called to get the current size of the edit window - // (only important if the edit resizes itself). - procedure ProcessMessage(var Message: TLMessage); stdcall; - // Used to forward messages to the edit window(s)- - procedure SetBounds(R: TRect); stdcall; // Called to place the editor. - end; - - // Indicates in the OnUpdating event what state the tree is currently in. - TVTUpdateState = ( - usBegin, // The tree just entered the update state (BeginUpdate call for the first time). - usBeginSynch, // The tree just entered the synch update state (BeginSynch call for the first time). - usSynch, // Begin/EndSynch has been called but the tree did not change the update state. - usUpdate, // Begin/EndUpdate has been called but the tree did not change the update state. - usEnd, // The tree just left the update state (EndUpdate called for the last level). - usEndSynch // The tree just left the synch update state (EndSynch called for the last level). - ); - - // Used during owner draw of the header to indicate which drop mark for the column must be drawn. - TVTDropMarkMode = ( - dmmNone, - dmmLeft, - dmmRight - ); - - // 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; - end; - - // These elements are used both to query the application, which of them it wants to draw itself and to tell it during - // painting, which elements must be drawn during the advanced custom draw events. - THeaderPaintElements = set of ( - hpeBackground, - hpeDropMark, - hpeHeaderGlyph, - hpeSortGlyph, - hpeText - ); - - // Various events must be handled at different places than they were initiated or need - // a persistent storage until they are reset. - TVirtualTreeStates = set of ( - tsCancelHintAnimation, // Set when a new hint is about to show but an old hint is still being animated. - tsChangePending, // A selection change is pending. - tsCheckPropagation, // Set during automatic check state propagation. - tsCollapsing, // A full collapse operation is in progress. - tsToggleFocusedSelection, // Node selection was modifed using Ctrl-click. Change selection state on next mouse up. - tsClearPending, // Need to clear the current selection on next mouse move. - tsClipboardFlushing, // Set during flushing the clipboard to avoid freeing the content. - tsCopyPending, // Indicates a pending copy operation which needs to be finished. - tsCutPending, // Indicates a pending cut operation which needs to be finished. - tsDrawSelPending, // Multiselection only. User held down the left mouse button on a free - // area and might want to start draw selection. - tsDrawSelecting, // Multiselection only. Draw selection has actually started. - tsEditing, // Indicates that an edit operation is currently in progress. - tsEditPending, // An mouse up start edit if dragging has not started. - tsExpanding, // A full expand operation is in progress. - tsHint, // Set when our hint is visible or soon will be. - tsInAnimation, // Set if the tree is currently in an animation loop. - tsIncrementalSearching, // Set when the user starts incremental search. - tsIncrementalSearchPending, // Set in WM_KEYDOWN to tell to use the char in WM_CHAR for incremental search. - tsIterating, // Set when IterateSubtree is currently in progress. - tsKeyCheckPending, // A check operation is under way, initiated by a key press (space key). Ignore mouse. - tsLeftButtonDown, // Set when the left mouse button is down. - tsLeftDblClick, // Set when the left mouse button was doubly clicked. - tsMouseCheckPending, // A check operation is under way, initiated by a mouse click. Ignore space key. - tsMiddleButtonDown, // Set when the middle mouse button is down. - tsMiddleDblClick, // Set when the middle mouse button was doubly clicked. - tsNeedScale, // On next ChangeScale scale the default node height. - tsNeedRootCountUpdate, // Set if while loading a root node count is set. - tsOLEDragging, // OLE dragging in progress. - tsOLEDragPending, // User has requested to start delayed dragging. - tsPainting, // The tree is currently painting itself. - tsRightButtonDown, // Set when the right mouse button is down. - tsRightDblClick, // Set when the right mouse button was doubly clicked. - tsPopupMenuShown, // The user clicked the right mouse button, which might cause a popup menu to appear. - tsScrolling, // Set when autoscrolling is active. - tsScrollPending, // Set when waiting for the scroll delay time to elapse. - tsSizing, // Set when the tree window is being resized. This is used to prevent recursive calls - // due to setting the scrollbars when sizing. - tsStopValidation, // Cache validation can be stopped (usually because a change has occured meanwhile). - tsStructureChangePending, // The structure of the tree has been changed while the update was locked. - tsSynchMode, // Set when the tree is in synch mode, where no timer events are triggered. - tsThumbTracking, // Stop updating the horizontal scroll bar while dragging the vertical thumb and vice versa. - tsUpdateHiddenChildrenNeeded, // Pending update for the hidden children flag after massive visibility changes. - tsUpdating, // The tree does currently not update its window because a BeginUpdate has not yet ended. - tsUseCache, // The tree's node caches are validated and non-empty. - tsUserDragObject, // Signals that the application created an own drag object in OnStartDrag. - tsUseThemes, // The tree runs under WinXP+, is theme aware and themes are enabled. - tsValidating, // The tree's node caches are currently validated. - tsValidationNeeded, // Something in the structure of the tree has changed. The cache needs validation. - tsVCLDragging, // VCL drag'n drop in progress. - tsVCLDragPending, // One-shot flag to avoid clearing the current selection on implicit mouse up for VCL drag. - tsWheelPanning, // Wheel mouse panning is active or soon will be. - tsWheelScrolling, // Wheel mouse scrolling is active or soon will be. - tsWindowCreating // Set during window handle creation to avoid frequent unnecessary updates. - ); - - TChangeStates = set of ( - csStopValidation, // Cache validation can be stopped (usually because a change has occured meanwhile). - csUseCache, // The tree's node caches are validated and non-empty. - csValidating, // The tree's node caches are currently validated. - csValidationNeeded // Something in the structure of the tree has changed. The cache needs validation. - ); - - // determines whether and how the drag image is to show - TVTDragImageKind = ( - diComplete, // show a complete drag image with all columns, only visible columns are shown - diMainColumnOnly, // show only the main column (the tree column) - diNoImage // don't show a drag image at all - ); - - // Switch for OLE and VCL drag'n drop. Because it is not possible to have both simultanously. - TVTDragType = ( - dtOLE, - dtVCL - ); - - // options which determine what to draw in PaintTree - TVTInternalPaintOption = ( - poBackground, // draw background image if there is any and it is enabled - poColumnColor, // erase node's background with the column's color - poDrawFocusRect, // draw focus rectangle around the focused node - poDrawSelection, // draw selected nodes with the normal selection color - poDrawDropMark, // draw drop mark if a node is currently the drop target - poGridLines, // draw grid lines if enabled - poMainOnly, // draw only the main column - poSelectedOnly // draw only selected nodes - ); - TVTInternalPaintOptions = set of TVTInternalPaintOption; - - // Determines the look of a tree's lines. - TVTLineStyle = ( - lsCustomStyle, // application provides a line pattern - lsDotted, // usual dotted lines (default) - lsSolid // simple solid lines - ); - - // TVTLineType is used during painting a tree - TVTLineType = ( - ltNone, // no line at all - ltBottomRight, // a line from bottom to the center and from there to the right - ltTopDown, // a line from top to bottom - ltTopDownRight, // a line from top to bottom and from center to the right - ltRight, // a line from center to the right - ltTopRight, // a line from bottom to center and from there to the right - // special styles for alternative drawings of tree lines - ltLeft, // a line from top to bottom at the left - ltLeftBottom // a combination of ltLeft and a line at the bottom from left to right - ); - - // Determines how to draw tree lines. - TVTLineMode = ( - lmNormal, // usual tree lines (as in TTreeview) - lmBands // looks similar to a Nassi-Schneidermann diagram - ); - - // A collection of line type IDs which is used while painting a node. - TLineImage = array of TVTLineType; - - TVTScrollIncrement = 1..10000; - - // 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 - FOwner: TBaseVirtualTree; - FColors: array[0..14] of TColor; - function GetColor(const Index: Integer): TColor; - procedure SetColor(const Index: Integer; const Value: TColor); - public - constructor Create(AOwner: TBaseVirtualTree); - - procedure Assign(Source: TPersistent); override; - published - property BorderColor: TColor index 7 read GetColor write SetColor default clBtnFace; - property DisabledColor: TColor index 0 read GetColor write SetColor default clBtnShadow; - property DropMarkColor: TColor index 1 read GetColor write SetColor default clHighlight; - property DropTargetColor: TColor index 2 read GetColor write SetColor default clHighLight; - property DropTargetBorderColor: TColor index 11 read GetColor write SetColor default clHighLight; - property FocusedSelectionColor: TColor index 3 read GetColor write SetColor default clHighLight; - property FocusedSelectionBorderColor: TColor index 9 read GetColor write SetColor default clHighLight; - property GridLineColor: TColor index 4 read GetColor write SetColor default clBtnFace; - property HeaderHotColor: TColor index 14 read GetColor write SetColor default clBtnShadow; - property HotColor: TColor index 8 read GetColor write SetColor default clWindowText; - property SelectionRectangleBlendColor: TColor index 12 read GetColor write SetColor default clHighlight; - property SelectionRectangleBorderColor: TColor index 13 read GetColor write SetColor default clHighlight; - property TreeLineColor: TColor index 5 read GetColor write SetColor default clBtnShadow; - property UnfocusedSelectionColor: TColor index 6 read GetColor write SetColor default clBtnFace; - property UnfocusedSelectionBorderColor: TColor index 10 read GetColor write SetColor default clBtnFace; - end; - - // For painting a node and its columns/cells a lot of information must be passed frequently around. - TVTImageInfo = record - Index: Integer; // Index in the associated image list. - XPos, // Horizontal position in the current target canvas. - YPos: Integer; // Vertical position in the current target canvas. - Ghosted: Boolean; // Flag to indicate that the image must be drawn slightly lighter. - Images: TCustomImageList; // The image list to be used for painting. - end; - - TVTImageInfoIndex = ( - iiNormal, - iiState, - iiCheck, - iiOverlay - ); - - // Options which are used when modifying the scroll offsets. - TScrollUpdateOptions = set of ( - suoRepaintHeader, // if suoUpdateNCArea is also set then invalidate the header - suoRepaintScrollbars, // if suoUpdateNCArea is also set then repaint both scrollbars after updating them - suoScrollClientArea, // scroll and invalidate the proper part of the client area - suoUpdateNCArea // update non-client area (scrollbars, header) - ); - - // Determines the look of a tree's buttons. - TVTButtonStyle = ( - bsRectangle, // traditional Windows look (plus/minus buttons) - bsTriangle // traditional Macintosh look - ); - - // TButtonFillMode is only used when the button style is bsRectangle and determines how to fill the interior. - TVTButtonFillMode = ( - fmTreeColor, // solid color, uses the tree's background color - fmWindowColor, // solid color, uses clWindow - fmShaded, // color gradient, Windows XP style (legacy code, use toThemeAware on Windows XP instead) - fmTransparent // transparent color, use the item's background color - ); - - TVTPaintInfo = record - Canvas: TCanvas; // the canvas to paint on - PaintOptions: TVTInternalPaintOptions; // a copy of the paint options passed to PaintTree - Node: PVirtualNode; // the node to paint - Column: TColumnIndex; // the node's column index to paint - Position: TColumnPosition; // the column position of the node - CellRect, // the node cell - ContentRect: TRect; // the area of the cell used for the node's content - NodeWidth: Integer; // the actual node width - Alignment: TAlignment; // how to align within the node rectangle - BidiMode: TBidiMode; // directionality to be used for painting - BrushOrigin: TPoint; // the alignment for the brush used to draw dotted lines - ImageInfo: array[TVTImageInfoIndex] of TVTImageInfo; // info about each possible node image - end; - - // Method called by the Animate routine for each animation step. - TVTAnimationCallback = function(Step, StepSize: Integer; Data: Pointer): Boolean of object; - - TVTIncrementalSearch = ( - isAll, // search every node in tree, initialize if necessary - isNone, // disable incremental search - isInitializedOnly, // search only initialized nodes, skip others - isVisibleOnly // search only visible nodes, initialize if necessary - ); - - // Determines which direction to use when advancing nodes during an incremental search. - TVTSearchDirection = ( - sdForward, - sdBackward - ); - - // Determines where to start incremental searching for each key press. - TVTSearchStart = ( - ssAlwaysStartOver, // always use the first/last node (depending on direction) to search from - ssLastHit, // use the last found node - ssFocusedNode // use the currently focused node - ); - - // Determines how to use the align member of a node. - TVTNodeAlignment = ( - naFromBottom, // the align member specifies amount of units (usually pixels) from top border of the node - naFromTop, // align is to be measured from bottom - naProportional // align is to be measure in percent of the entire node height and relative to top - ); - - // Determines how to draw the selection rectangle used for draw selection. - TVTDrawSelectionMode = ( - smDottedRectangle, // same as DrawFocusRect - smBlendedRectangle // alpha blending, uses special colors (see TVTColors) - ); - - TClipboardFormats = class(TStringList) - private - FOwner: TBaseVirtualTree; - public - constructor Create(AOwner: TBaseVirtualTree); virtual; - - function Add(const S: string): Integer; override; - procedure Insert(Index: Integer; const S: string); override; - property Owner: TBaseVirtualTree read FOwner; - end; - - // ----- Event prototypes: - - // node enumeration - TVTGetNodeProc = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Data: Pointer; var Abort: Boolean) of object; - - // node events - TVTChangingEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; var Allowed: Boolean) of object; - TVTCheckChangingEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; var NewState: TCheckState; - var Allowed: Boolean) of object; - TVTChangeEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode) of object; - TVTStructureChangeEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Reason: TChangeReason) of object; - TVTEditCancelEvent = procedure(Sender: TBaseVirtualTree; Column: TColumnIndex) of object; - TVTEditChangingEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; - var Allowed: Boolean) of object; - TVTEditChangeEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex) of object; - TVTFreeNodeEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode) of object; - TVTFocusChangingEvent = procedure(Sender: TBaseVirtualTree; OldNode, NewNode: PVirtualNode; OldColumn, - NewColumn: TColumnIndex; var Allowed: Boolean) of object; - TVTFocusChangeEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex) of object; - TVTGetImageEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Kind: TVTImageKind; Column: TColumnIndex; - var Ghosted: Boolean; var ImageIndex: Integer) of object; - TVTGetImageExEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Kind: TVTImageKind; Column: TColumnIndex; - var Ghosted: Boolean; var ImageIndex: Integer; var ImageList: TCustomImageList) of object; - TVTHotNodeChangeEvent = procedure(Sender: TBaseVirtualTree; OldNode, NewNode: PVirtualNode) of object; - TVTInitChildrenEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; var ChildCount: Cardinal) of object; - TVTInitNodeEvent = procedure(Sender: TBaseVirtualTree; ParentNode, Node: PVirtualNode; - var InitialStates: TVirtualNodeInitStates) of object; - TVTPopupEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; const P: TPoint; - var AskParent: Boolean; var PopupMenu: TPopupMenu) of object; - TVTHelpContextEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; - var HelpContext: Integer) of object; - TVTCreateEditorEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; - out EditLink: IVTEditLink) of object; - TVTSaveNodeEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Stream: TStream) of object; - - // header/column events - TVTHeaderClickEvent = procedure(Sender: TVTHeader; Column: TColumnIndex; Button: TMouseButton; Shift: TShiftState; X, - Y: Integer) 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; - TVTHeaderNotifyEvent = procedure(Sender: TVTHeader; Column: TColumnIndex) of object; - TVTHeaderDraggingEvent = procedure(Sender: TVTHeader; Column: TColumnIndex; var Allowed: Boolean) of object; - TVTHeaderDraggedEvent = procedure(Sender: TVTHeader; Column: TColumnIndex; OldPosition: Integer) of object; - TVTHeaderDraggedOutEvent = procedure(Sender: TVTHeader; Column: TColumnIndex; DropPosition: TPoint) of object; - TVTHeaderPaintEvent = procedure(Sender: TVTHeader; HeaderCanvas: TCanvas; Column: TVirtualTreeColumn; R: TRect; Hover, - Pressed: Boolean; DropMark: TVTDropMarkMode) of object; - TVTHeaderPaintQueryElementsEvent = procedure(Sender: TVTHeader; var PaintInfo: THeaderPaintInfo; - var Elements: THeaderPaintElements) of object; - TVTAdvancedHeaderPaintEvent = procedure(Sender: TVTHeader; var PaintInfo: THeaderPaintInfo; - const Elements: THeaderPaintElements) of object; - TVTColumnClickEvent = procedure (Sender: TBaseVirtualTree; Column: TColumnIndex; Shift: TShiftState) of object; - TVTColumnDblClickEvent = procedure (Sender: TBaseVirtualTree; Column: TColumnIndex; Shift: TShiftState) of object; - TVTGetHeaderCursorEvent = procedure(Sender: TVTHeader; var Cursor: HCURSOR) of object; - - // move and copy events - TVTNodeMovedEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode) of object; - TVTNodeMovingEvent = procedure(Sender: TBaseVirtualTree; Node, Target: PVirtualNode; - var Allowed: Boolean) of object; - TVTNodeCopiedEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode) of object; - TVTNodeCopyingEvent = procedure(Sender: TBaseVirtualTree; Node, Target: PVirtualNode; - var Allowed: Boolean) of object; - - // drag'n drop/OLE events - TVTCreateDragManagerEvent = procedure(Sender: TBaseVirtualTree; out DragManager: IVTDragManager) of object; - TVTCreateDataObjectEvent = procedure(Sender: TBaseVirtualTree; out IDataObject: IDataObject) of object; - TVTDragAllowedEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; - var Allowed: Boolean) of object; - TVTDragOverEvent = procedure(Sender: TBaseVirtualTree; Source: TObject; Shift: TShiftState; State: TDragState; - Pt: TPoint; Mode: TDropMode; var Effect: Integer; var Accept: Boolean) of object; - TVTDragDropEvent = procedure(Sender: TBaseVirtualTree; Source: TObject; DataObject: IDataObject; - Formats: TFormatArray; Shift: TShiftState; Pt: TPoint; var Effect: Integer; Mode: TDropMode) of object; - TVTRenderOLEDataEvent = procedure(Sender: TBaseVirtualTree; const FormatEtcIn: TFormatEtc; out Medium: TStgMedium; - ForClipboard: Boolean; var Result: HRESULT) of object; - TVTGetUserClipboardFormatsEvent = procedure(Sender: TBaseVirtualTree; var Formats: TFormatEtcArray) of object; - - // paint events - TVTBeforeItemEraseEvent = procedure(Sender: TBaseVirtualTree; TargetCanvas: TCanvas; Node: PVirtualNode; ItemRect: TRect; - var ItemColor: TColor; var EraseAction: TItemEraseAction) of object; - TVTAfterItemEraseEvent = procedure(Sender: TBaseVirtualTree; TargetCanvas: TCanvas; Node: PVirtualNode; - ItemRect: TRect) of object; - TVTBeforeItemPaintEvent = procedure(Sender: TBaseVirtualTree; TargetCanvas: TCanvas; Node: PVirtualNode; - ItemRect: TRect; var CustomDraw: Boolean) of object; - TVTAfterItemPaintEvent = procedure(Sender: TBaseVirtualTree; TargetCanvas: TCanvas; Node: PVirtualNode; - ItemRect: TRect) of object; - TVTBeforeCellPaintEvent = procedure(Sender: TBaseVirtualTree; TargetCanvas: TCanvas; Node: PVirtualNode; - Column: TColumnIndex; CellRect: TRect) of object; - TVTAfterCellPaintEvent = procedure(Sender: TBaseVirtualTree; TargetCanvas: TCanvas; Node: PVirtualNode; - Column: TColumnIndex; CellRect: TRect) of object; - TVTPaintEvent = procedure(Sender: TBaseVirtualTree; TargetCanvas: TCanvas) of object; - TVTBackgroundPaintEvent = procedure(Sender: TBaseVirtualTree; TargetCanvas: TCanvas; R: TRect; - var Handled: Boolean) of object; - TVTGetLineStyleEvent = procedure(Sender: TBaseVirtualTree; var Bits: Pointer) of object; - TVTMeasureItemEvent = procedure(Sender: TBaseVirtualTree; TargetCanvas: TCanvas; Node: PVirtualNode; - var NodeHeight: Integer) of object; - - // search, sort - TVTCompareEvent = procedure(Sender: TBaseVirtualTree; Node1, Node2: PVirtualNode; Column: TColumnIndex; - var Result: Integer) of object; - TVTIncrementalSearchEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; const SearchText: WideString; - var Result: Integer) of object; - - // miscellaneous - TVTGetNodeDataSizeEvent = procedure(Sender: TBaseVirtualTree; var NodeDataSize: Integer) of object; - TVTKeyActionEvent = procedure(Sender: TBaseVirtualTree; var CharCode: Word; var Shift: TShiftState; - var DoDefault: Boolean) of object; - TVTScrollEvent = procedure(Sender: TBaseVirtualTree; DeltaX, DeltaY: Integer) of object; - TVTUpdatingEvent = procedure(Sender: TBaseVirtualTree; State: TVTUpdateState) of object; - TVTGetCursorEvent = procedure(Sender: TBaseVirtualTree; var Cursor: TCursor) of object; - TVTStateChangeEvent = procedure(Sender: TBaseVirtualTree; Enter, Leave: TVirtualTreeStates) of object; - TVTGetCellIsEmptyEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; - var IsEmpty: Boolean) of object; - TVTScrollbarShowEvent = procedure(Sender: TBaseVirtualTree; Bar: Integer; Show: Boolean) of object; - - // Helper types for node iterations. - TGetFirstNodeProc = function: PVirtualNode of object; - TGetNextNodeProc = function(Node: PVirtualNode): PVirtualNode of object; - - // ----- TBaseVirtualTree -TBaseVirtualTree = class(TCustomControl) - private - FBidiMode: TBidiMode; - FBorderStyle: TBorderStyle; - FHeader: TVTHeader; - FRoot: PVirtualNode; - FDefaultNodeHeight, - FIndent: Cardinal; - FOptions: TCustomVirtualTreeOptions; - FUpdateCount: Cardinal; // update stopper, updates of the tree control are only done if = 0 - FSynchUpdateCount: Cardinal; // synchronizer, causes all events which are usually done via timers - // to happen immediately, regardless of the normal update state - FNodeDataSize: Integer; // number of bytes to allocate with each node (in addition to its base - // structure and the internal data), if -1 then do callback - {$ifdef UseLocalMemoryManager} - FNodeMemoryManager: TVTNodeMemoryManager; // High-performance local memory manager. - {$endif UseLocalMemoryManager} - FStates: TVirtualTreeStates; // various active/pending states the tree needs to consider - FLastSelected, - FFocusedNode: PVirtualNode; - FEditColumn, // column to be edited (focused node) - FFocusedColumn: TColumnIndex; // NoColumn if no columns are active otherwise the last hit column of - // the currently focused node - FScrollDirections: TScrollDirections; // directions to scroll client area into depending on mouse position - FLastStructureChangeReason: TChangeReason; // Used for delayed structure change event. - FLastStructureChangeNode, // dito - FLastChangedNode, // used for delayed change event - FCurrentHotNode: PVirtualNode; // Node over which the mouse is hovering. - FLastSelRect, - FNewSelRect: TRect; // used while doing draw selection - FHotCursor: TCursor; // can be set to additionally indicate the current hot node - FAnimationType: THintAnimationType; // none, fade in, slide in animation (just like those animations used - // in Win98 (slide) and Windows 2000 (fade)) - FHintMode: TVTHintMode; // determines the kind of the hint window - FHintData: TVTHintData; // used while preparing the hint window - FChangeDelay: Cardinal; // used to delay OnChange event - FEditDelay: Cardinal; // determines time to elapse before a node goes into edit mode - FPositionCache: TCache; // array which stores node references ordered by vertical positions - // (see also DoValidateCache for more information) - FVisibleCount: Cardinal; // number of currently visible nodes - FStartIndex: Cardinal; // index to start validating cache from - FSelection: TNodeArray; // list of currently selected nodes - FSelectionCount: Integer; // number of currently selected nodes (size of FSelection might differ) - FRangeAnchor: PVirtualNode; // anchor node for selection with the keyboard, determines start of a - // selection range - FCheckNode: PVirtualNode; // node which "captures" a check event - FPendingCheckState: TCheckState; // the new state the check node will get if all went fine - FCheckPropagationCount: Cardinal; // nesting level of check propagation (WL, 05.02.2004) - FLastSelectionLevel: Integer; // keeps the last node level for constrained multiselection - FDrawSelShiftState: TShiftState; // keeps the initial shift state when the user starts selection with - // the mouse - FEditLink: IVTEditLink; // used to comunicate with an application defined editor - FTempNodeCache: TNodeArray; // used at various places to hold temporarily a bunch of node refs. - FTempNodeCount: Cardinal; // number of nodes in FTempNodeCache - FBackground: TPicture; // A background image loadable at design and runtime. - FMargin: Integer; // horizontal border distance - FTextMargin: Integer; // space between the node's text and its horizontal bounds - FBackgroundOffsetX, - FBackgroundOffsetY: Integer; // used to fine tune the position of the background image - FAnimationDuration: Cardinal; // specifies how long an animation shall take (expanding, hint) - FWantTabs: Boolean; // If True then the tree also consumes the tab key. - FNodeAlignment: TVTNodeAlignment; // determines how to interpret the align member of a node - FHeaderRect: TRect; // Space which the header currently uses in the control (window coords). - FLastHintRect: TRect; // Area which the mouse must leave to reshow a hint. - FUpdateRect: TRect; - - // paint support and images - FPlusBM, - FMinusBM: TBitmap; // small bitmaps used for tree buttons - FImages, // normal images in the tree - FStateImages, // state images in the tree - FCustomCheckImages: TCustomImageList; // application defined check images - FCheckImageKind: TCheckImageKind; // light or dark, cross marks or tick marks - FCheckImages: TCustomImageList; // Reference to global image list to be used for the check images. - FImageChangeLink, - FStateChangeLink, - FCustomCheckChangeLink: TChangeLink; // connections to the image lists - FOldFontChange: TNotifyEvent; // helper method pointer for tracking font changes in the off screen buffer - FFontChanged: Boolean; // flag for keeping informed about font changes in the off screen buffer - FColors: TVTColors; // class comprising all customizable colors in the tree - FButtonStyle: TVTButtonStyle; // style of the tree buttons - FButtonFillMode: TVTButtonFillMode; // for rectangular tree buttons only: how to fill them - FLineStyle: TVTLineStyle; // style of the tree lines - FLineMode: TVTLineMode; // tree lines or bands etc. - FDottedBrush: HBRUSH; // used to paint dotted lines without special pens - FSelectionCurveRadius: Cardinal; // radius for rounded selection rectangles - FSelectionBlendFactor: Byte; // Determines the factor by which the selection rectangle is to be - // faded if enabled. - FDrawSelectionMode: TVTDrawSelectionMode; // determines the paint mode for draw selection - - // alignment and directionality support - FAlignment: TAlignment; // default alignment of the tree if no columns are shown - - // drag'n drop and clipboard support - FDragImageKind: TVTDragImageKind; // determines whether or not and what to show in the drag image - FDragOperations: TDragOperations; // determines which operations are allowed during drag'n drop - FDragThreshold: Integer; // used to determine when to actually start a drag'n drop operation - FDragManager: IVTDragManager; // drag'n drop, cut'n paste - FDropTargetNode: PVirtualNode; // node currently selected as drop target - FLastDropMode: TDropMode; // set while dragging and used to track changes - FDragSelection: TNodeArray; // temporary copy of FSelection used during drag'n drop - FDragType: TVTDragType; // used to switch between OLE and VCL drag'n drop - FDragImage: TVTDragImage; // drag image management - FDragWidth, - FDragHeight: Integer; // size of the drag image, the larger the more CPU power is needed - FClipboardFormats: TClipboardFormats; // a list of clipboard format descriptions enabled for this tree - FLastVCLDragTarget: PVirtualNode; // A node cache for VCL drag'n drop (keywords: DragLeave on DragDrop). - FVCLDragEffect: LongWord; // A cache for VCL drag'n drop to keep the current drop effect. - - // scroll support - FScrollBarOptions: TScrollBarOptions; // common properties of horizontal and vertical scrollbar - FAutoScrollInterval: TAutoScrollInterval; // determines speed of auto scrolling - FAutoScrollDelay: Cardinal; // amount of milliseconds to wait until autoscrolling becomes active - FAutoExpandDelay: Cardinal; // amount of milliseconds to wait until a node is expanded if it is the - // drop target - FOffsetX: Integer; - FOffsetY: Integer; // Determines left and top scroll offset. - FEffectiveOffsetX: Integer; // Actual position of the horizontal scroll bar (varies depending on bidi mode). - FRangeX, - FRangeY: Cardinal; // current virtual width and height of the tree - FBottomSpace: Cardinal; // Extra space below the last node. - - FDefaultPasteMode: TVTNodeAttachMode; // Used to determine where to add pasted nodes to. - FSingletonNodeArray: TNodeArray; // Contains only one element for quick addition of single nodes - // to the selection. - FDragScrollStart: Cardinal; // Contains the start time when a tree does auto scrolling as drop target. - - // search - FIncrementalSearch: TVTIncrementalSearch; // Used to determine whether and how incremental search is to be used. - FSearchTimeout: Cardinal; // Number of milliseconds after which to stop incremental searching. - FSearchBuffer: WideString; // Collects a sequence of keypresses used to do incremental searching. - FLastSearchNode: PVirtualNode; // Reference to node which was last found as search fit. - FSearchDirection: TVTSearchDirection; // Direction to incrementally search the tree. - FSearchStart: TVTSearchStart; // Where to start iteration on each key press. - - // miscellanous - FTotalInternalDataSize: Cardinal; // Cache of the sum of the necessary internal data size for all tree - // classes derived from this base class. - FPanningWindow: HWND; // Helper window for wheel panning - FPanningCursor: HCURSOR; // Current wheel panning cursor. - FPanningImage: TBitmap; // A little 32x32 bitmap to indicate the panning reference point. - FLastClickPos: TPoint; // Used for retained drag start and wheel mouse scrolling. - - {$ifdef EnableAccessible} - // MSAA support - FAccessible: IAccessible; // The IAccessible interface to the window itself. - FAccessibleItem: IAccessible; // The IAccessible to the item that currently has focus. - FAccessibleName: string; // The name the window is given for screen readers. - {$endif} - // common events - FOnChange: TVTChangeEvent; // selection change - FOnStructureChange: TVTStructureChangeEvent; // structural change like adding nodes etc. - FOnInitChildren: TVTInitChildrenEvent; // called when a node's children are needed (expanding etc.) - FOnInitNode: TVTInitNodeEvent; // called when a node needs to be initialized (child count etc.) - FOnFreeNode: TVTFreeNodeEvent; // called when a node is about to be destroyed, user data can and should - // be freed in this event - FOnGetImage: TVTGetImageEvent; // Used to retrieve the image index of a given node. - FOnGetImageEx: TVTGetImageExEvent; // Used to retrieve the image index of a given node along with a custom - // image list. - FOnHotChange: TVTHotNodeChangeEvent; // called when the current "hot" node (that is, the node under the mouse) - // changes and hot tracking is enabled - FOnExpanding, // called just before a node is expanded - FOnCollapsing: TVTChangingEvent; // called just before a node is collapsed - FOnChecking: TVTCheckChangingEvent; // called just before a node's check state is changed - FOnExpanded, // called after a node has been expanded - FOnCollapsed, // called after a node has been collapsed - FOnChecked: TVTChangeEvent; // called after a node's check state has been changed - FOnResetNode: TVTChangeEvent; // called when a node is set to be uninitialized - FOnNodeMoving: TVTNodeMovingEvent; // called just before a node is moved from one parent node to another - // (this can be cancelled) - FOnNodeMoved: TVTNodeMovedEvent; // called after a node and its children have been moved to another - // parent node (probably another tree, but within the same application) - FOnNodeCopying: TVTNodeCopyingEvent; // called when an node is copied to another parent node (probably in - // another tree, but within the same application, can be cancelled) - FOnNodeCopied: TVTNodeCopiedEvent; // call after a node has been copied - FOnEditing: TVTEditChangingEvent; // called just before a node goes into edit mode - FOnEditCancelled: TVTEditCancelEvent; // called when editing has been cancelled - FOnEdited: TVTEditChangeEvent; // called when editing has successfully been finished - FOnFocusChanging: TVTFocusChangingEvent; // called when the focus is about to go to a new node and/or column - // (can be cancelled) - FOnFocusChanged: TVTFocusChangeEvent; // called when the focus goes to a new node and/or column - FOnGetPopupMenu: TVTPopupEvent; // called when the popup for a node needs to be shown - FOnGetHelpContext: TVTHelpContextEvent; // called when a node specific help theme should be called - FOnCreateEditor: TVTCreateEditorEvent; // called when a node goes into edit mode, this allows applications - // to supply their own editor - FOnLoadNode, // called after a node has been loaded from a stream (file, clipboard, - // OLE drag'n drop) to allow an application to load their own data - // saved in OnSaveNode - FOnSaveNode: TVTSaveNodeEvent; // called when a node needs to be serialized into a stream - // (see OnLoadNode) to give the application the opportunity to save - // their node specific, persistent data (note: never save memory - // references) - - // header/column mouse events - FOnHeaderClick, // mouse events for the header, just like those for a control - FOnHeaderDblClick: TVTHeaderClickEvent; - FOnHeaderMouseDown, - FOnHeaderMouseUp: TVTHeaderMouseEvent; - FOnHeaderMouseMove: TVTHeaderMouseMoveEvent; - FOnColumnClick: TVTColumnClickEvent; - FOnColumnDblClick: TVTColumnDblClickEvent; - FOnColumnResize: TVTHeaderNotifyEvent; - FOnGetHeaderCursor: TVTGetHeaderCursorEvent; // triggered to allow the app. to use customized cursors for the header - - // paint events - FOnAfterPaint, // triggered when the tree has entirely been painted - FOnBeforePaint: TVTPaintEvent; // triggered when the tree is about to be painted - FOnAfterItemPaint: TVTAfterItemPaintEvent; // triggered after an item has been painted - FOnBeforeItemPaint: TVTBeforeItemPaintEvent; // triggered when an item is about to be painted - FOnBeforeItemErase: TVTBeforeItemEraseEvent; // triggered when an item's background is about to be erased - FOnAfterItemErase: TVTAfterItemEraseEvent; // triggered after an item's background has been erased - FOnAfterCellPaint: TVTAfterCellPaintEvent; // triggered after a column of an item has been painted - FOnBeforeCellPaint: TVTBeforeCellPaintEvent; // triggered when a column of an item is about to be painted - FOnHeaderDraw: TVTHeaderPaintEvent; // Used when owner draw is enabled for the header and a column is set - // to owner draw mode. - FOnHeaderDrawQueryElements: TVTHeaderPaintQueryElementsEvent; // Used for advanced header painting to query the - // application for the elements, which are drawn by it and which should - // be drawn by the tree. - FOnAdvancedHeaderDraw: TVTAdvancedHeaderPaintEvent; // Used when owner draw is enabled for the header and a column - // is set to owner draw mode. But only if OnHeaderDrawQueryElements - // returns at least one element to be drawn by the application. - // In this case OnHeaderDraw is not used. - FOnGetLineStyle: TVTGetLineStyleEvent; // triggered when a custom line style is used and the pattern brush - // needs to be build - FOnPaintBackground: TVTBackgroundPaintEvent; // triggered if a part of the tree's background must be erased which is - // not covered by any node - FOnMeasureItem: TVTMeasureItemEvent; // Triggered when a node is about to be drawn and its height was not yet - // determined by the application. - - // drag'n drop events - FOnCreateDragManager: TVTCreateDragManagerEvent; // called to allow for app./descendant defined drag managers - FOnCreateDataObject: TVTCreateDataObjectEvent; // called to allow for app./descendant defined data objects - FOnDragAllowed: TVTDragAllowedEvent; // used to get permission for manual drag in mouse down - FOnDragOver: TVTDragOverEvent; // called for every mouse move - FOnDragDrop: TVTDragDropEvent; // called on release of mouse button (if drop was allowed) - FOnHeaderDragged: TVTHeaderDraggedEvent; // header (column) drag'n drop - FOnHeaderDraggedOut: TVTHeaderDraggedOutEvent; // header (column) drag'n drop, which did not result in a valid drop. - FOnHeaderDragging: TVTHeaderDraggingEvent; // header (column) drag'n drop - FOnRenderOLEData: TVTRenderOLEDataEvent; // application/descendant defined clipboard formats - FOnGetUserClipboardFormats: TVTGetUserClipboardFormatsEvent; // gives application/descendants the opportunity to - // add own clipboard formats on the fly - - // miscellanous events - FOnGetNodeDataSize: TVTGetNodeDataSizeEvent; // Called if NodeDataSize is -1. - FOnKeyAction: TVTKeyActionEvent; // Used to selectively prevent key actions (full expand on Ctrl+'+' etc.). - FOnScroll: TVTScrollEvent; // Called when one or both paint offsets changed. - FOnUpdating: TVTUpdatingEvent; // Called from BeginUpdate, EndUpdate, BeginSynch and EndSynch. - FOnGetCursor: TVTGetCursorEvent; // Called to allow the app. to set individual cursors. - FOnStateChange: TVTStateChangeEvent; // Called whenever a state in the tree changes. - FOnGetCellIsEmpty: TVTGetCellIsEmptyEvent; // Called when the tree needs to know if a cell is empty. - FOnShowScrollbar: TVTScrollbarShowEvent; // Called when a scrollbar is changed in its visibility. - - // search, sort - FOnCompareNodes: TVTCompareEvent; // used during sort - FOnIncrementalSearch: TVTIncrementalSearchEvent; // triggered on every key press (not key down) - - procedure AdjustCoordinatesByIndent(var PaintInfo: TVTPaintInfo; Indent: Integer); - procedure AdjustImageBorder(Images: TCustomImageList; BidiMode: TBidiMode; VAlign: Integer; var R: TRect; - var ImageInfo: TVTImageInfo); - procedure AdjustTotalCount(Node: PVirtualNode; Value: Integer; relative: Boolean = False); - procedure AdjustTotalHeight(Node: PVirtualNode; Value: Integer; relative: Boolean = False); - function CalculateCacheEntryCount: Integer; - procedure CalculateVerticalAlignments(ShowImages, ShowStateImages: Boolean; Node: PVirtualNode; var VAlign, - VButtonAlign: Integer); - function ChangeCheckState(Node: PVirtualNode; Value: TCheckState): Boolean; - function CollectSelectedNodesLTR(MainColumn, NodeLeft, NodeRight: Integer; Alignment: TAlignment; OldRect, - NewRect: TRect): Boolean; - function CollectSelectedNodesRTL(MainColumn, NodeLeft, NodeRight: Integer; Alignment: TAlignment; OldRect, - NewRect: TRect): Boolean; - procedure ClearNodeBackground(const PaintInfo: TVTPaintInfo; UseBackground, Floating: Boolean; R: TRect); - function CompareNodePositions(Node1, Node2: PVirtualNode): Integer; - procedure DrawLineImage(const PaintInfo: TVTPaintInfo; X, Y, H, VAlign: Integer; Style: TVTLineType; Reverse: Boolean); - function FindInPositionCache(Node: PVirtualNode; var CurrentPos: Cardinal): PVirtualNode; overload; - function FindInPositionCache(Position: Cardinal; var CurrentPos: Cardinal): PVirtualNode; overload; - procedure FixupTotalCount(Node: PVirtualNode); - procedure FixupTotalHeight(Node: PVirtualNode); - function GetCheckState(Node: PVirtualNode): TCheckState; - function GetCheckType(Node: PVirtualNode): TCheckType; - function GetChildCount(Node: PVirtualNode): Cardinal; - function GetChildrenInitialized(Node: PVirtualNode): Boolean; - function GetDisabled(Node: PVirtualNode): Boolean; - function GetDragManager: IVTDragManager; - function GetExpanded(Node: PVirtualNode): Boolean; - function GetFullyVisible(Node: PVirtualNode): Boolean; - function GetHasChildren(Node: PVirtualNode): Boolean; - function GetMultiline(Node: PVirtualNode): Boolean; - function GetNodeHeight(Node: PVirtualNode): Cardinal; - function GetNodeParent(Node: PVirtualNode): PVirtualNode; - function GetOffsetXY: TPoint; - function GetRootNodeCount: Cardinal; - function GetSelected(Node: PVirtualNode): Boolean; - function GetTopNode: PVirtualNode; - function GetTotalCount: Cardinal; - function GetVerticalAlignment(Node: PVirtualNode): Byte; - function GetVisible(Node: PVirtualNode): Boolean; - function GetVisiblePath(Node: PVirtualNode): Boolean; - procedure HandleClickSelection(LastFocused, NewNode: PVirtualNode; Shift: TShiftState; DragPending: Boolean); - function HandleDrawSelection(X, Y: Integer): Boolean; - function HasVisibleNextSibling(Node: PVirtualNode): Boolean; - procedure ImageListChange(Sender: TObject); - procedure InitializeFirstColumnValues(var PaintInfo: TVTPaintInfo); - function InitializeLineImageAndSelectLevel(Node: PVirtualNode; var LineImage: TLineImage): Integer; - procedure InitRootNode(OldSize: Cardinal = 0); - procedure InterruptValidation; - function IsFirstVisibleChild(Parent, Node: PVirtualNode): Boolean; - function IsLastVisibleChild(Parent, Node: PVirtualNode): Boolean; - procedure LimitPaintingToArea(Canvas: TCanvas; ClipRect: TRect; VisibleRegion: HRGN = 0); - function MakeNewNode: PVirtualNode; - function PackArrayAsm(TheArray: TNodeArray; Count: Integer): Integer; - function PackArray(TheArray: TNodeArray; Count: Integer): Integer; - procedure PrepareBitmaps(NeedButtons, NeedLines: Boolean); - procedure PrepareCell(var PaintInfo: TVTPaintInfo; WindowOrgX, MaxWidth: Integer); - procedure ReadOldOptions(Reader: TReader); - procedure SetAlignment(const Value: TAlignment); - procedure SetAnimationDuration(const Value: Cardinal); - procedure SetBackground(const Value: TPicture); - procedure SetBackgroundOffset(const Index, Value: Integer); - procedure SetBorderStyle(Value: TBorderStyle); - procedure SetBottomSpace(const Value: Cardinal); - procedure SetButtonFillMode(const Value: TVTButtonFillMode); - procedure SetButtonStyle(const Value: TVTButtonStyle); - procedure SetCheckImageKind(Value: TCheckImageKind); - procedure SetCheckState(Node: PVirtualNode; Value: TCheckState); - procedure SetCheckType(Node: PVirtualNode; Value: TCheckType); - procedure SetChildCount(Node: PVirtualNode; NewChildCount: Cardinal); - procedure SetClipboardFormats(const Value: TClipboardFormats); - procedure SetColors(const Value: TVTColors); - procedure SetCustomCheckImages(const Value: TCustomImageList); - procedure SetDefaultNodeHeight(Value: Cardinal); - procedure SetDisabled(Node: PVirtualNode; Value: Boolean); - procedure SetExpanded(Node: PVirtualNode; Value: Boolean); - procedure SetFocusedColumn(Value: TColumnIndex); - procedure SetFocusedNode(Value: PVirtualNode); - procedure SetFullyVisible(Node: PVirtualNode; Value: Boolean); - procedure SetHasChildren(Node: PVirtualNode; Value: Boolean); - procedure SetHeader(const Value: TVTHeader); - procedure SetImages(const Value: TCustomImageList); - procedure SetIndent(Value: Cardinal); - procedure SetLineMode(const Value: TVTLineMode); - procedure SetLineStyle(const Value: TVTLineStyle); - procedure SetMargin(Value: Integer); - procedure SetMultiline(Node: PVirtualNode; const Value: Boolean); - procedure SetNodeAlignment(const Value: TVTNodeAlignment); - procedure SetNodeDataSize(Value: Integer); - procedure SetNodeHeight(Node: PVirtualNode; Value: Cardinal); - procedure SetNodeParent(Node: PVirtualNode; const Value: PVirtualNode); - procedure SetOffsetX(const Value: Integer); - procedure SetOffsetXY(const Value: TPoint); - procedure SetOffsetY(const Value: Integer); - procedure SetOptions(const Value: TCustomVirtualTreeOptions); - procedure SetRootNodeCount(Value: Cardinal); - procedure SetScrollBarOptions(Value: TScrollBarOptions); - procedure SetSearchOption(const Value: TVTIncrementalSearch); - procedure SetSelected(Node: PVirtualNode; Value: Boolean); - procedure SetSelectionCurveRadius(const Value: Cardinal); - procedure SetStateImages(const Value: TCustomImageList); - procedure SetTextMargin(Value: Integer); - procedure SetTopNode(Node: PVirtualNode); - procedure SetUpdateState(Updating: Boolean); - procedure SetVerticalAlignment(Node: PVirtualNode; Value: Byte); - procedure SetVisible(Node: PVirtualNode; Value: Boolean); - procedure SetVisiblePath(Node: PVirtualNode; Value: Boolean); - procedure StaticBackground(Source: TBitmap; Target: TCanvas; Offset: TPoint; R: TRect); - procedure StopTimer(ID: Integer); - procedure TileBackground(Source: TBitmap; Target: TCanvas; Offset: TPoint; R: TRect); - function ToggleCallback(Step, StepSize: Integer; Data: Pointer): Boolean; - - procedure CMColorChange(var Message: TLMessage); message CM_COLORCHANGED; - procedure CMCtl3DChanged(var Message: TLMessage); message CM_CTL3DCHANGED; - procedure CMBiDiModeChanged(var Message: TLMessage); message CM_BIDIMODECHANGED; - procedure CMDenySubclassing(var Message: TLMessage); message CM_DENYSUBCLASSING; - procedure CMDrag(var Message: TCMDrag); message CM_DRAG; - procedure CMEnabledChanged(var Message: TLMessage); message CM_ENABLEDCHANGED; - procedure CMFontChanged(var Message: TLMessage); message CM_FONTCHANGED; - procedure CMHintShow(var Message: TCMHintShow); message CM_HINTSHOW; - procedure CMHintShowPause(var Message: TCMHintShowPause); message CM_HINTSHOWPAUSE; - procedure CMMouseLeave(var Message: TLMessage); message CM_MOUSELEAVE; - procedure CMMouseWheel(var Message: TLMMouseEvent); message LM_MOUSEWHEEL; - procedure CMSysColorChange(var Message: TLMessage); message CM_SYSCOLORCHANGE; - {$ifdef EnableNativeTVM} - procedure TVMGetItem(var Message: TLMessage); message TVM_GETITEM; - procedure TVMGetItemRect(var Message: TLMessage); message TVM_GETITEMRECT; - procedure TVMGetNextItem(var Message: TLMessage); message TVM_GETNEXTITEM; - {$endif} - procedure WMCancelMode(var Message: TLMNoParams); message LM_CANCELMODE; - procedure WMChangeState(var Message: TLMessage); message WM_CHANGESTATE; - procedure WMChar(var Message: TLMChar); message LM_CHAR; - procedure WMContextMenu(var Message: TLMContextMenu); {message LM_CONTEXTMENU;} - procedure WMCopy(var Message: TLMNoParams); message LM_COPYTOCLIP; - procedure WMCut(var Message: TLMNoParams); message LM_CUTTOCLIP; - procedure WMEnable(var Message: TLMNoParams); message LM_ENABLE; - procedure WMEraseBkgnd(var Message: TLMEraseBkgnd); message LM_ERASEBKGND; - procedure WMGetDlgCode(var Message: TLMNoParams); message LM_GETDLGCODE; - procedure WMGetObject(var Message: TLMessage);{ message WM_GETOBJECT;} - procedure WMHScroll(var Message: TLMHScroll); message LM_HSCROLL; - procedure WMKeyDown(var Message: TLMKeyDown); message LM_KEYDOWN; - procedure WMKeyUp(var Message: TLMKeyUp); message LM_KEYUP; - procedure WMKillFocus(var Msg: TLMKillFocus); message LM_KILLFOCUS; - procedure WMLButtonDblClk(var Message: TLMLButtonDblClk); message LM_LBUTTONDBLCLK; - procedure WMLButtonDown(var Message: TLMLButtonDown); message LM_LBUTTONDOWN; - procedure WMLButtonUp(var Message: TLMLButtonUp); message LM_LBUTTONUP; - procedure WMMButtonDblClk(var Message: TLMMButtonDblClk); message LM_MBUTTONDBLCLK; - procedure WMMButtonDown(var Message: TLMMButtonDown); message LM_MBUTTONDOWN; - procedure WMMButtonUp(var Message: TLMMButtonUp); message LM_MBUTTONUP; - {$ifdef EnableNCFunctions} - procedure WMNCCalcSize(var Message: TWMNCCalcSize); message WM_NCCALCSIZE; - procedure WMNCDestroy(var Message: TWMNCDestroy); message WM_NCDESTROY; - procedure WMNCHitTest(var Message: TWMNCHitTest); message WM_NCHITTEST; - procedure WMNCPaint(var Message: TRealWMNCPaint); message WM_NCPAINT; - {$endif} - procedure WMPaint(var Message: TLMPaint); message LM_PAINT; - procedure WMPaste(var Message: TLMNoParams); message LM_PASTEFROMCLIP; - {$ifdef EnablePrintFunctions} - procedure WMPrint(var Message: TWMPrint); message WM_PRINT; - procedure WMPrintClient(var Message: TWMPrintClient); message WM_PRINTCLIENT; - {$endif} - procedure WMRButtonDblClk(var Message: TLMRButtonDblClk); message LM_RBUTTONDBLCLK; - procedure WMRButtonDown(var Message: TLMRButtonDown); message LM_RBUTTONDOWN; - procedure WMRButtonUp(var Message: TLMRButtonUp); message LM_RBUTTONUP; - procedure WMSetCursor(var Message: TLMessage); message LM_SETCURSOR; - procedure WMSetFocus(var Msg: TLMSetFocus); message LM_SETFOCUS; - procedure WMSize(var Message: TLMSize); message LM_SIZE; - procedure WMTimer(var Message: TLMessage); message LM_TIMER; - {$ifdef ThemeSupport} - procedure WMThemeChanged(var Message: TLMessage); message WM_THEMECHANGED; - {$endif ThemeSupport} - procedure WMVScroll(var Message: TLMVScroll); message LM_VSCROLL; - protected - procedure AddToSelection(Node: PVirtualNode); overload; virtual; - 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 AdviseChangeEvent(StructureChange: Boolean; Node: PVirtualNode; Reason: TChangeReason); virtual; - function AllocateInternalDataArea(Size: Cardinal): Cardinal; virtual; - procedure Animate(Steps, Duration: Cardinal; Callback: TVTAnimationCallback; Data: Pointer); virtual; - function CalculateSelectionRect(X, Y: Integer): Boolean; virtual; - function CanAutoScroll: Boolean; virtual; - function CanEdit(Node: PVirtualNode; Column: TColumnIndex): Boolean; virtual; - function CanShowDragImage: Boolean; virtual; - procedure Change(Node: PVirtualNode); virtual; - procedure ChangeScale(M, D: Integer); override; - function CheckParentCheckState(Node: PVirtualNode; NewCheckState: TCheckState): Boolean; virtual; - procedure ClearTempCache; virtual; - function ColumnIsEmpty(Node: PVirtualNode; Column: TColumnIndex): Boolean; virtual; - function ComputeRTLOffset(ExcludeScrollbar: Boolean = False): Integer; virtual; - function CountLevelDifference(Node1, Node2: PVirtualNode): Integer; virtual; - function CountVisibleChildren(Node: PVirtualNode): Cardinal; virtual; - procedure CreateParams(var Params: TCreateParams); override; - procedure CreateWnd; override; - procedure DefineProperties(Filer: TFiler); override; - procedure DetermineHiddenChildrenFlag(Node: PVirtualNode); virtual; - procedure DetermineHiddenChildrenFlagAllNodes; virtual; - procedure DetermineHitPositionLTR(var HitInfo: THitInfo; Offset, Right: Integer; Alignment: TAlignment); virtual; - procedure DetermineHitPositionRTL(var HitInfo: THitInfo; Offset, Right: Integer; Alignment: TAlignment); virtual; - function DetermineNextCheckState(CheckType: TCheckType; CheckState: TCheckState): TCheckState; virtual; - function DetermineScrollDirections(X, Y: Integer): TScrollDirections; virtual; - procedure DoAdvancedHeaderDraw(var PaintInfo: THeaderPaintInfo; const Elements: THeaderPaintElements); virtual; - procedure DoAfterCellPaint(Canvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex; CellRect: TRect); virtual; - procedure DoAfterItemErase(Canvas: TCanvas; Node: PVirtualNode; ItemRect: TRect); virtual; - procedure DoAfterItemPaint(Canvas: TCanvas; Node: PVirtualNode; ItemRect: TRect); virtual; - procedure DoAfterPaint(Canvas: TCanvas); virtual; - procedure DoAutoScroll(X, Y: Integer); virtual; - function DoBeforeDrag(Node: PVirtualNode; Column: TColumnIndex): Boolean; virtual; - procedure DoBeforeCellPaint(Canvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex; CellRect: TRect); virtual; - procedure DoBeforeItemErase(Canvas: TCanvas; Node: PVirtualNode; ItemRect: TRect; var Color: TColor; - var EraseAction: TItemEraseAction); virtual; - function DoBeforeItemPaint(Canvas: TCanvas; Node: PVirtualNode; ItemRect: TRect): Boolean; virtual; - procedure DoBeforePaint(Canvas: TCanvas); virtual; - function DoCancelEdit: Boolean; virtual; - procedure DoCanEdit(Node: PVirtualNode; Column: TColumnIndex; var Allowed: Boolean); virtual; - procedure DoChange(Node: PVirtualNode); virtual; - procedure DoCheckClick(Node: PVirtualNode; NewCheckState: TCheckState); virtual; - procedure DoChecked(Node: PVirtualNode); virtual; - function DoChecking(Node: PVirtualNode; var NewCheckState: TCheckState): Boolean; virtual; - procedure DoCollapsed(Node: PVirtualNode); virtual; - function DoCollapsing(Node: PVirtualNode): Boolean; virtual; - procedure DoColumnClick(Column: TColumnIndex; Shift: TShiftState); virtual; - procedure DoColumnDblClick(Column: TColumnIndex; Shift: TShiftState); virtual; - procedure DoColumnResize(Column: TColumnIndex); virtual; - function DoCompare(Node1, Node2: PVirtualNode; Column: TColumnIndex): Integer; virtual; - function DoCreateDataObject: IDataObject; virtual; - function DoCreateDragManager: IVTDragManager; virtual; - function DoCreateEditor(Node: PVirtualNode; Column: TColumnIndex): IVTEditLink; virtual; - procedure DoDragging(P: TPoint); virtual; - procedure DoDragExpand; virtual; - function DoDragOver(Source: TObject; Shift: TShiftState; State: TDragState; Pt: TPoint; Mode: TDropMode; - var Effect: LongWord): Boolean; virtual; - procedure DoDragDrop(Source: TObject; DataObject: IDataObject; Formats: TFormatArray; Shift: TShiftState; Pt: TPoint; - var Effect: LongWord; Mode: TDropMode); virtual; - procedure DoEdit; virtual; - procedure DoEndDrag(Target: TObject; X, Y: Integer); override; - function DoEndEdit: Boolean; virtual; - procedure DoExpanded(Node: PVirtualNode); virtual; - function DoExpanding(Node: PVirtualNode): Boolean; virtual; - procedure DoFocusChange(Node: PVirtualNode; Column: TColumnIndex); virtual; - function DoFocusChanging(OldNode, NewNode: PVirtualNode; OldColumn, NewColumn: TColumnIndex): Boolean; virtual; - procedure DoFocusNode(Node: PVirtualNode; Ask: Boolean); virtual; - procedure DoFreeNode(Node: PVirtualNode); virtual; - function DoGetAnimationType: THintAnimationType; virtual; - procedure DoGetCursor(var Cursor: TCursor); virtual; - procedure DoGetHeaderCursor(var Cursor: HCURSOR); virtual; - function DoGetImageIndex(Node: PVirtualNode; Kind: TVTImageKind; Column: TColumnIndex; - var Ghosted: Boolean; var Index: Integer): TCustomImageList; virtual; - procedure DoGetLineStyle(var Bits: Pointer); virtual; - function DoGetNodeHint(Node: PVirtualNode; Column: TColumnIndex; var LineBreakStyle: TVTTooltipLineBreakStyle): WideString; virtual; - function DoGetNodeTooltip(Node: PVirtualNode; Column: TColumnIndex; var LineBreakStyle: TVTTooltipLineBreakStyle): WideString; virtual; - function DoGetNodeWidth(Node: PVirtualNode; Column: TColumnIndex; Canvas: TCanvas = nil): Integer; virtual; - function DoGetPopupMenu(Node: PVirtualNode; Column: TColumnIndex; Position: TPoint): TPopupMenu; virtual; - procedure DoGetUserClipboardFormats(var Formats: TFormatEtcArray); virtual; - procedure DoHeaderClick(Column: TColumnIndex; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); virtual; - procedure DoHeaderDblClick(Column: TColumnIndex; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); virtual; - procedure DoHeaderDragged(Column: TColumnIndex; OldPosition: TColumnPosition); virtual; - procedure DoHeaderDraggedOut(Column: TColumnIndex; DropPosition: TPoint); virtual; - function DoHeaderDragging(Column: TColumnIndex): Boolean; virtual; - procedure DoHeaderDraw(Canvas: TCanvas; Column: TVirtualTreeColumn; R: TRect; Hover, Pressed: Boolean; - DropMark: TVTDropMarkMode); virtual; - procedure DoHeaderDrawQueryElements(var PaintInfo: THeaderPaintInfo; var Elements: THeaderPaintElements); virtual; - procedure DoHeaderMouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); virtual; - procedure DoHeaderMouseMove(Shift: TShiftState; X, Y: Integer); virtual; - procedure DoHeaderMouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); virtual; - procedure DoHotChange(Old, New: PVirtualNode); virtual; - function DoIncrementalSearch(Node: PVirtualNode; const Text: WideString): Integer; virtual; - procedure DoInitChildren(Node: PVirtualNode; var ChildCount: Cardinal); virtual; - procedure DoInitNode(Parent, Node: PVirtualNode; var InitStates: TVirtualNodeInitStates); virtual; - function DoKeyAction(var CharCode: Word; var Shift: TShiftState): Boolean; virtual; - procedure DoLoadUserData(Node: PVirtualNode; Stream: TStream); virtual; - procedure DoMeasureItem(TargetCanvas: TCanvas; Node: PVirtualNode; var NodeHeight: Integer); virtual; - procedure DoNodeCopied(Node: PVirtualNode); virtual; - function DoNodeCopying(Node, NewParent: PVirtualNode): Boolean; virtual; - procedure DoNodeMoved(Node: PVirtualNode); virtual; - function DoNodeMoving(Node, NewParent: PVirtualNode): Boolean; virtual; - function DoPaintBackground(Canvas: TCanvas; R: TRect): Boolean; virtual; - procedure DoPaintDropMark(Canvas: TCanvas; Node: PVirtualNode; R: TRect); virtual; - procedure DoPaintNode(var PaintInfo: TVTPaintInfo); virtual; - procedure DoPopupMenu(Node: PVirtualNode; Column: TColumnIndex; Position: TPoint); virtual; - function DoRenderOLEData(const FormatEtcIn: TFormatEtc; out Medium: TStgMedium; - ForClipboard: Boolean): HRESULT; virtual; - procedure DoReset(Node: PVirtualNode); virtual; - procedure DoSaveUserData(Node: PVirtualNode; Stream: TStream); virtual; - procedure DoScroll(DeltaX, DeltaY: Integer); virtual; - function DoSetOffsetXY(Value: TPoint; Options: TScrollUpdateOptions; ClipRect: PRect = nil): Boolean; virtual; - procedure DoShowScrollbar(Bar: Integer; Show: Boolean); virtual; - procedure DoStartDrag(var DragObject: TDragObject); override; - procedure DoStateChange(Enter: TVirtualTreeStates; Leave: TVirtualTreeStates = []); virtual; - procedure DoStructureChange(Node: PVirtualNode; Reason: TChangeReason); virtual; - procedure DoTimerScroll; virtual; - procedure DoUpdating(State: TVTUpdateState); virtual; - function DoValidateCache: Boolean; virtual; - procedure DragCanceled; override; - function DragDrop(const DataObject: IDataObject; KeyState: Integer; Pt: TPoint; - var Effect: LongWord): HResult; reintroduce; virtual; - function DragEnter(KeyState: Integer; Pt: TPoint; var Effect: LongWord): HResult; virtual; - procedure DragFinished; virtual; - procedure DragLeave; virtual; - function DragOver(Source: TObject; KeyState: Integer; DragState: TDragState; Pt: TPoint; - var Effect: LongWord): HResult; reintroduce; virtual; - procedure DrawDottedHLine(const PaintInfo: TVTPaintInfo; Left, Right, Top: Integer); virtual; - procedure DrawDottedVLine(const PaintInfo: TVTPaintInfo; Top, Bottom, Left: Integer); virtual; - function FindNodeInSelection(P: PVirtualNode; var Index: Integer; LowBound, HighBound: Integer): Boolean; virtual; - procedure FinishChunkHeader(Stream: TStream; StartPos, EndPos: Integer); virtual; - procedure FontChanged(AFont: TObject); virtual; - function GetBorderDimensions: TSize; virtual; - function GetCheckImage(Node: PVirtualNode): Integer; virtual; - class function GetCheckImageListFor(Kind: TCheckImageKind): TCustomImageList; virtual; - function GetColumnClass: TVirtualTreeColumnClass; virtual; - function GetHeaderClass: TVTHeaderClass; virtual; - function GetHintWindowClass: THintWindowClass; virtual; - procedure GetImageIndex(var Info: TVTPaintInfo; Kind: TVTImageKind; InfoIndex: TVTImageInfoIndex; - DefaultImages: TCustomImageList); virtual; - function GetMaxRightExtend: Cardinal; virtual; - procedure GetNativeClipboardFormats(var Formats: TFormatEtcArray); virtual; - function GetOptionsClass: TTreeOptionsClass; virtual; - function GetTreeFromDataObject(const DataObject: IDataObject): TBaseVirtualTree; virtual; - procedure HandleHotTrack(X, Y: Integer); virtual; - procedure HandleIncrementalSearch(CharCode: Word); virtual; - procedure HandleMouseDblClick(var Message: TLMMouse; const HitInfo: THitInfo); virtual; - procedure HandleMouseDown(var Message: TLMMouse; const HitInfo: THitInfo); virtual; - procedure HandleMouseUp(var Message: TLMMouse; const HitInfo: THitInfo); virtual; - function HasImage(Node: PVirtualNode; Kind: TVTImageKind; Column: TColumnIndex): Boolean; virtual; - function HasPopupMenu(Node: PVirtualNode; Column: TColumnIndex; Pos: TPoint): Boolean; virtual; - procedure InitChildren(Node: PVirtualNode); virtual; - procedure InitNode(Node: PVirtualNode); virtual; - procedure InternalAddFromStream(Stream: TStream; Version: Integer; Node: PVirtualNode); virtual; - function InternalAddToSelection(Node: PVirtualNode; ForceInsert: Boolean): Boolean; overload; - function InternalAddToSelection(const NewItems: TNodeArray; NewLength: Integer; - ForceInsert: Boolean): Boolean; overload; - procedure InternalCacheNode(Node: PVirtualNode); virtual; - procedure InternalClearSelection; virtual; - procedure InternalConnectNode(Node, Destination: PVirtualNode; Target: TBaseVirtualTree; Mode: TVTNodeAttachMode); virtual; - function InternalData(Node: PVirtualNode): Pointer; - procedure InternalDisconnectNode(Node: PVirtualNode; KeepFocus: Boolean; Reindex: Boolean = True); virtual; - procedure InternalRemoveFromSelection(Node: PVirtualNode); virtual; - procedure InvalidateCache; - procedure Loaded; override; - procedure MainColumnChanged; virtual; - procedure MarkCutCopyNodes; virtual; - procedure MouseMove(Shift: TShiftState; X, Y: Integer); override; - procedure Notification(AComponent: TComponent; Operation: TOperation); override; - {$ifdef EnableNCFunctions} - procedure OriginalWMNCPaint(DC: HDC); virtual; - {$endif} - procedure Paint; override; - procedure PaintCheckImage(const PaintInfo: TVTPaintInfo); virtual; - procedure PaintImage(var PaintInfo: TVTPaintInfo; ImageInfoIndex: TVTImageInfoIndex; DoOverlay: Boolean); virtual; - procedure PaintNodeButton(Canvas: TCanvas; Node: PVirtualNode; const R: TRect; ButtonX, ButtonY: Integer; - BidiMode: TBiDiMode); virtual; - procedure PaintTreeLines(const PaintInfo: TVTPaintInfo; VAlignment, IndentSize: Integer; - LineImage: TLineImage); virtual; - procedure PaintSelectionRectangle(Target: TCanvas; WindowOrgX: Integer; const SelectionRect: TRect; - TargetRect: TRect); virtual; - procedure PanningWindowProc(var Message: TLMessage); virtual; - function ReadChunk(Stream: TStream; Version: Integer; Node: PVirtualNode; ChunkType, - ChunkSize: Integer): Boolean; virtual; - procedure ReadNode(Stream: TStream; Version: Integer; Node: PVirtualNode); virtual; - procedure RedirectFontChangeEvent(Canvas: TCanvas); virtual; - procedure RemoveFromSelection(Node: PVirtualNode); virtual; - function RenderOLEData(const FormatEtcIn: TFormatEtc; out Medium: TStgMedium; ForClipboard: Boolean): HResult; virtual; - procedure ResetRangeAnchor; virtual; - procedure RestoreFontChangeEvent(Canvas: TCanvas); virtual; - procedure SelectNodes(StartNode, EndNode: PVirtualNode; AddOnly: Boolean); virtual; - procedure SetFocusedNodeAndColumn(Node: PVirtualNode; Column: TColumnIndex); virtual; - procedure SkipNode(Stream: TStream); virtual; - procedure StartWheelPanning(Position: TPoint); virtual; - procedure StopWheelPanning; virtual; - procedure StructureChange(Node: PVirtualNode; Reason: TChangeReason); virtual; - function SuggestDropEffect(Source: TObject; Shift: TShiftState; Pt: TPoint; AllowedEffects: Integer): Integer; virtual; - procedure ToggleSelection(StartNode, EndNode: PVirtualNode); virtual; - procedure UnselectNodes(StartNode, EndNode: PVirtualNode); virtual; - procedure UpdateDesigner; virtual; - procedure UpdateEditBounds; virtual; - procedure UpdateHeaderRect; virtual; - procedure UpdateWindowAndDragImage(const Tree: TBaseVirtualTree; TreeRect: TRect; UpdateNCArea, - ReshowDragImage: Boolean); virtual; - procedure ValidateCache; virtual; - procedure ValidateNodeDataSize(var Size: Integer); virtual; - procedure WndProc(var Message: TLMessage); override; - procedure WriteChunks(Stream: TStream; Node: PVirtualNode); virtual; - procedure WriteNode(Stream: TStream; Node: PVirtualNode); virtual; - - property Alignment: TAlignment read FAlignment write SetAlignment default taLeftJustify; - property AnimationDuration: Cardinal read FAnimationDuration write SetAnimationDuration default 200; - property AutoExpandDelay: Cardinal read FAutoExpandDelay write FAutoExpandDelay default 1000; - property AutoScrollDelay: Cardinal read FAutoScrollDelay write FAutoScrollDelay default 1000; - property AutoScrollInterval: TAutoScrollInterval read FAutoScrollInterval write FAutoScrollInterval default 1; - property Background: TPicture read FBackground write SetBackground; - property BackgroundOffsetX: Integer index 0 read FBackgroundOffsetX write SetBackgroundOffset default 0; - property BackgroundOffsetY: Integer index 1 read FBackgroundOffsetY write SetBackgroundOffset default 0; - property BidiMode: TBidiMode read FBidiMode write FBidiMode default bdLeftToRight; - property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle default bsSingle; - property BottomSpace: Cardinal read FBottomSpace write SetBottomSpace default 0; - property ButtonFillMode: TVTButtonFillMode read FButtonFillMode write SetButtonFillMode default fmTreeColor; - property ButtonStyle: TVTButtonStyle read FButtonStyle write SetButtonStyle default bsRectangle; - property ChangeDelay: Cardinal read FChangeDelay write FChangeDelay default 0; - property CheckImageKind: TCheckImageKind read FCheckImageKind write SetCheckImageKind default ckLightCheck; - property ClipboardFormats: TClipboardFormats read FClipboardFormats write SetClipboardFormats; - property Colors: TVTColors read FColors write SetColors; - property CustomCheckImages: TCustomImageList read FCustomCheckImages write SetCustomCheckImages; - property DefaultNodeHeight: Cardinal read FDefaultNodeHeight write SetDefaultNodeHeight default 18; - property DefaultPasteMode: TVTNodeAttachMode read FDefaultPasteMode write FDefaultPasteMode default amAddChildLast; - property DragHeight: Integer read FDragHeight write FDragHeight default 350; - property DragImageKind: TVTDragImageKind read FDragImageKind write FDragImageKind default diComplete; - property DragOperations: TDragOperations read FDragOperations write FDragOperations default [doCopy, doMove]; - property DragSelection: TNodeArray read FDragSelection; - property DragType: TVTDragType read FDragType write FDragType default dtOLE; - property DragWidth: Integer read FDragWidth write FDragWidth default 200; - property DrawSelectionMode: TVTDrawSelectionMode read FDrawSelectionMode write FDrawSelectionMode - default smDottedRectangle; - property EditColumn: TColumnIndex read FEditColumn write FEditColumn; - property EditDelay: Cardinal read FEditDelay write FEditDelay default 1000; - property Header: TVTHeader read FHeader write SetHeader; - property HeaderRect: TRect read FHeaderRect; - property HintAnimation: THintAnimationType read FAnimationType write FAnimationType default hatSystemDefault; - property HintMode: TVTHintMode read FHintMode write FHintMode default hmDefault; - property HotCursor: TCursor read FHotCursor write FHotCursor default crDefault; - property Images: TCustomImageList read FImages write SetImages; - property IncrementalSearch: TVTIncrementalSearch read FIncrementalSearch write SetSearchOption default isNone; - property IncrementalSearchDirection: TVTSearchDirection read FSearchDirection write FSearchDirection default sdForward; - property IncrementalSearchStart: TVTSearchStart read FSearchStart write FSearchStart default ssFocusedNode; - property IncrementalSearchTimeout: Cardinal read FSearchTimeout write FSearchTimeout default 1000; - property Indent: Cardinal read FIndent write SetIndent default 18; - property LastClickPos: TPoint read FLastClickPos write FLastClickPos; - property LastDropMode: TDropMode read FLastDropMode write FlastDropMode; - property LineMode: TVTLineMode read FLineMode write SetLineMode default lmNormal; - property LineStyle: TVTLineStyle read FLineStyle write SetLineStyle default lsDotted; - property Margin: Integer read FMargin write SetMargin default 4; - property NodeAlignment: TVTNodeAlignment read FNodeAlignment write SetNodeAlignment default naProportional; - property NodeDataSize: Integer read FNodeDataSize write SetNodeDataSize default -1; - property RootNodeCount: Cardinal read GetRootNodeCount write SetRootNodeCount default 0; - property ScrollBarOptions: TScrollBarOptions read FScrollBarOptions write SetScrollBarOptions; - property SelectionBlendFactor: Byte read FSelectionBlendFactor write FSelectionBlendFactor default 128; - property SelectionCurveRadius: Cardinal read FSelectionCurveRadius write SetSelectionCurveRadius default 0; - property StateImages: TCustomImageList read FStateImages write SetStateImages; - property TextMargin: Integer read FTextMargin write SetTextMargin default 4; - property TotalInternalDataSize: Cardinal read FTotalInternalDataSize; - property TreeOptions: TCustomVirtualTreeOptions read FOptions write SetOptions; - property WantTabs: Boolean read FWantTabs write FWantTabs default False; - - property OnAdvancedHeaderDraw: TVTAdvancedHeaderPaintEvent read FOnAdvancedHeaderDraw write FOnAdvancedHeaderDraw; - property OnAfterCellPaint: TVTAfterCellPaintEvent read FOnAfterCellPaint write FOnAfterCellPaint; - property OnAfterItemErase: TVTAfterItemEraseEvent read FOnAfterItemErase write FOnAfterItemErase; - property OnAfterItemPaint: TVTAfterItemPaintEvent read FOnAfterItemPaint write FOnAfterItemPaint; - property OnAfterPaint: TVTPaintEvent read FOnAfterPaint write FOnAfterPaint; - property OnBeforeCellPaint: TVTBeforeCellPaintEvent read FOnBeforeCellPaint write FOnBeforeCellPaint; - property OnBeforeItemErase: TVTBeforeItemEraseEvent read FOnBeforeItemErase write FOnBeforeItemErase; - property OnBeforeItemPaint: TVTBeforeItemPaintEvent read FOnBeforeItemPaint write FOnBeforeItemPaint; - property OnBeforePaint: TVTPaintEvent read FOnBeforePaint write FOnBeforePaint; - property OnChange: TVTChangeEvent read FOnChange write FOnChange; - property OnChecked: TVTChangeEvent read FOnChecked write FOnChecked; - property OnChecking: TVTCheckChangingEvent read FOnChecking write FOnChecking; - property OnCollapsed: TVTChangeEvent read FOnCollapsed write FOnCollapsed; - property OnCollapsing: TVTChangingEvent read FOnCollapsing write FOnCollapsing; - property OnColumnClick: TVTColumnClickEvent read FOnColumnClick write FOnColumnClick; - property OnColumnDblClick: TVTColumnDblClickEvent read FOnColumnDblClick write FOnColumnDblClick; - property OnColumnResize: TVTHeaderNotifyEvent read FOnColumnResize write FOnColumnResize; - property OnCompareNodes: TVTCompareEvent read FOnCompareNodes write FOnCompareNodes; - property OnCreateDataObject: TVTCreateDataObjectEvent read FOnCreateDataObject write FOnCreateDataObject; - property OnCreateDragManager: TVTCreateDragManagerEvent read FOnCreateDragManager write FOnCreateDragManager; - property OnCreateEditor: TVTCreateEditorEvent read FOnCreateEditor write FOnCreateEditor; - property OnDragAllowed: TVTDragAllowedEvent read FOnDragAllowed write FOnDragAllowed; - property OnDragOver: TVTDragOverEvent read FOnDragOver write FOnDragOver; - property OnDragDrop: TVTDragDropEvent read FOnDragDrop write FOnDragDrop; - property OnEditCancelled: TVTEditCancelEvent read FOnEditCancelled write FOnEditCancelled; - property OnEditing: TVTEditChangingEvent read FOnEditing write FOnEditing; - property OnEdited: TVTEditChangeEvent read FOnEdited write FOnEdited; - property OnExpanded: TVTChangeEvent read FOnExpanded write FOnExpanded; - property OnExpanding: TVTChangingEvent read FOnExpanding write FOnExpanding; - property OnFocusChanged: TVTFocusChangeEvent read FOnFocusChanged write FOnFocusChanged; - property OnFocusChanging: TVTFocusChangingEvent read FOnFocusChanging write FOnFocusChanging; - property OnFreeNode: TVTFreeNodeEvent read FOnFreeNode write FOnFreeNode; - property OnGetCellIsEmpty: TVTGetCellIsEmptyEvent read FOnGetCellIsEmpty write FOnGetCellIsEmpty; - property OnGetCursor: TVTGetCursorEvent read FOnGetCursor write FOnGetCursor; - property OnGetHeaderCursor: TVTGetHeaderCursorEvent read FOnGetHeaderCursor write FOnGetHeaderCursor; - property OnGetHelpContext: TVTHelpContextEvent read FOnGetHelpContext write FOnGetHelpContext; - property OnGetImageIndex: TVTGetImageEvent read FOnGetImage write FOnGetImage; - property OnGetImageIndexEx: TVTGetImageExEvent read FOnGetImageEx write FOnGetImageEx; - property OnGetLineStyle: TVTGetLineStyleEvent read FOnGetLineStyle write FOnGetLineStyle; - property OnGetNodeDataSize: TVTGetNodeDataSizeEvent read FOnGetNodeDataSize write FOnGetNodeDataSize; - property OnGetPopupMenu: TVTPopupEvent read FOnGetPopupMenu write FOnGetPopupMenu; - property OnGetUserClipboardFormats: TVTGetUserClipboardFormatsEvent read FOnGetUserClipboardFormats - write FOnGetUserClipboardFormats; - property OnHeaderClick: TVTHeaderClickEvent read FOnHeaderClick write FOnHeaderClick; - property OnHeaderDblClick: TVTHeaderClickEvent read FOnHeaderDblClick write FOnHeaderDblClick; - property OnHeaderDragged: TVTHeaderDraggedEvent read FOnHeaderDragged write FOnHeaderDragged; - property OnHeaderDraggedOut: TVTHeaderDraggedOutEvent read FOnHeaderDraggedOut write FOnHeaderDraggedOut; - property OnHeaderDragging: TVTHeaderDraggingEvent read FOnHeaderDragging write FOnHeaderDragging; - property OnHeaderDraw: TVTHeaderPaintEvent read FOnHeaderDraw write FOnHeaderDraw; - property OnHeaderDrawQueryElements: TVTHeaderPaintQueryElementsEvent read FOnHeaderDrawQueryElements - write FOnHeaderDrawQueryElements; - property OnHeaderMouseDown: TVTHeaderMouseEvent read FOnHeaderMouseDown write FOnHeaderMouseDown; - property OnHeaderMouseMove: TVTHeaderMouseMoveEvent read FOnHeaderMouseMove write FOnHeaderMouseMove; - property OnHeaderMouseUp: TVTHeaderMouseEvent read FOnHeaderMouseUp write FOnHeaderMouseUp; - property OnHotChange: TVTHotNodeChangeEvent read FOnHotChange write FOnHotChange; - property OnIncrementalSearch: TVTIncrementalSearchEvent read FOnIncrementalSearch write FOnIncrementalSearch; - property OnInitChildren: TVTInitChildrenEvent read FOnInitChildren write FOnInitChildren; - property OnInitNode: TVTInitNodeEvent read FOnInitNode write FOnInitNode; - property OnKeyAction: TVTKeyActionEvent read FOnKeyAction write FOnKeyAction; - property OnLoadNode: TVTSaveNodeEvent read FOnLoadNode write FOnLoadNode; - property OnMeasureItem: TVTMeasureItemEvent read FOnMeasureItem write FOnMeasureItem; - property OnNodeCopied: TVTNodeCopiedEvent read FOnNodeCopied write FOnNodeCopied; - property OnNodeCopying: TVTNodeCopyingEvent read FOnNodeCopying write FOnNodeCopying; - property OnNodeMoved: TVTNodeMovedEvent read FOnNodeMoved write FOnNodeMoved; - property OnNodeMoving: TVTNodeMovingEvent read FOnNodeMoving write FOnNodeMoving; - property OnPaintBackground: TVTBackgroundPaintEvent read FOnPaintBackground write FOnPaintBackground; - property OnRenderOLEData: TVTRenderOLEDataEvent read FOnRenderOLEData write FOnRenderOLEData; - property OnResetNode: TVTChangeEvent read FOnResetNode write FOnResetNode; - property OnSaveNode: TVTSaveNodeEvent read FOnSaveNode write FOnSaveNode; - property OnScroll: TVTScrollEvent read FOnScroll write FOnScroll; - property OnShowScrollbar: TVTScrollbarShowEvent read FOnShowScrollbar write FOnShowScrollbar; - property OnStateChange: TVTStateChangeEvent read FOnStateChange write FOnStateChange; - property OnStructureChange: TVTStructureChangeEvent read FOnStructureChange write FOnStructureChange; - property OnUpdating: TVTUpdatingEvent read FOnUpdating write FOnUpdating; - public - constructor Create(AOwner: TComponent); override; - destructor Destroy; override; - - function AbsoluteIndex(Node: PVirtualNode): Cardinal; - function AddChild(Parent: PVirtualNode; UserData: Pointer = nil): PVirtualNode; - procedure AddFromStream(Stream: TStream; TargetNode: PVirtualNode); - procedure AfterConstruction; override; - procedure Assign(Source: TPersistent); override; - procedure BeginDrag(Immediate: Boolean; Threshold: Integer = -1); - procedure BeginSynch; - procedure BeginUpdate; - procedure CancelCutOrCopy; - function CancelEditNode: Boolean; - function CanFocus: Boolean; {$ifdef COMPILER_5_UP} override;{$endif} - procedure Clear; virtual; - procedure ClearChecked; - procedure ClearSelection; - function CopyTo(Source: PVirtualNode; Tree: TBaseVirtualTree; Mode: TVTNodeAttachMode; - ChildrenOnly: Boolean): PVirtualNode; overload; - function CopyTo(Source, Target: PVirtualNode; Mode: TVTNodeAttachMode; - ChildrenOnly: Boolean): PVirtualNode; overload; - procedure CopyToClipBoard; virtual; - procedure CutToClipBoard; virtual; - procedure DeleteChildren(Node: PVirtualNode; ResetHasChildren: Boolean = False); - procedure DeleteNode(Node: PVirtualNode; Reindex: Boolean = True); - procedure DeleteSelectedNodes; virtual; - function Dragging: Boolean; - function EditNode(Node: PVirtualNode; Column: TColumnIndex): Boolean; virtual; - function EndEditNode: Boolean; - procedure EndSynch; - procedure EndUpdate; - function ExecuteAction(Action: TBasicAction): Boolean; override; - procedure FinishCutOrCopy; - procedure FlushClipboard; - procedure FullCollapse(Node: PVirtualNode = nil); virtual; - procedure FullExpand(Node: PVirtualNode = nil); virtual; - {$ifndef fpc} - function GetControlsAlignment: TAlignment; override; - {$endif} - function GetDisplayRect(Node: PVirtualNode; Column: TColumnIndex; TextOnly: Boolean; Unclipped: Boolean = False): TRect; - function GetFirst: PVirtualNode; - function GetFirstChecked(State: TCheckState = csCheckedNormal): PVirtualNode; - function GetFirstChild(Node: PVirtualNode): PVirtualNode; - function GetFirstCutCopy: PVirtualNode; - function GetFirstInitialized: PVirtualNode; - function GetFirstNoInit: PVirtualNode; - function GetFirstSelected: PVirtualNode; - function GetFirstVisible: PVirtualNode; - function GetFirstVisibleChild(Node: PVirtualNode): PVirtualNode; - function GetFirstVisibleChildNoInit(Node: PVirtualNode): PVirtualNode; - function GetFirstVisibleNoInit: PVirtualNode; - procedure GetHitTestInfoAt(X, Y: Integer; Relative: Boolean; var HitInfo: THitInfo); virtual; - function GetLast(Node: PVirtualNode = nil): PVirtualNode; - function GetLastInitialized(Node: PVirtualNode = nil): PVirtualNode; - function GetLastNoInit(Node: PVirtualNode = nil): PVirtualNode; - function GetLastChild(Node: PVirtualNode): PVirtualNode; - function GetLastChildNoInit(Node: PVirtualNode): PVirtualNode; - function GetLastVisible(Node: PVirtualNode = nil): PVirtualNode; - function GetLastVisibleChild(Node: PVirtualNode): PVirtualNode; - function GetLastVisibleChildNoInit(Node: PVirtualNode): PVirtualNode; - function GetLastVisibleNoInit(Node: PVirtualNode = nil): PVirtualNode; - function GetMaxColumnWidth(Column: TColumnIndex): Integer; - function GetNext(Node: PVirtualNode): PVirtualNode; - function GetNextChecked(Node: PVirtualNode; State: TCheckState = csCheckedNormal): PVirtualNode; - function GetNextCutCopy(Node: PVirtualNode): PVirtualNode; - function GetNextInitialized(Node: PVirtualNode): PVirtualNode; - function GetNextNoInit(Node: PVirtualNode): PVirtualNode; - function GetNextSelected(Node: PVirtualNode): PVirtualNode; - function GetNextSibling(Node: PVirtualNode): PVirtualNode; - function GetNextVisible(Node: PVirtualNode): PVirtualNode; - function GetNextVisibleNoInit(Node: PVirtualNode): PVirtualNode; - function GetNextVisibleSibling(Node: PVirtualNode): PVirtualNode; - function GetNextVisibleSiblingNoInit(Node: PVirtualNode): PVirtualNode; - function GetNodeAt(X, Y: Integer): PVirtualNode; overload; - function GetNodeAt(X, Y: Integer; Relative: Boolean; var NodeTop: Integer): PVirtualNode; overload; - function GetNodeData(Node: PVirtualNode): Pointer; - function GetNodeLevel(Node: PVirtualNode): Cardinal; - function GetPrevious(Node: PVirtualNode): PVirtualNode; - function GetPreviousInitialized(Node: PVirtualNode): PVirtualNode; - function GetPreviousNoInit(Node: PVirtualNode): PVirtualNode; - function GetPreviousSibling(Node: PVirtualNode): PVirtualNode; - function GetPreviousVisible(Node: PVirtualNode): PVirtualNode; - function GetPreviousVisibleNoInit(Node: PVirtualNode): PVirtualNode; - function GetPreviousVisibleSibling(Node: PVirtualNode): PVirtualNode; - function GetPreviousVisibleSiblingNoInit(Node: PVirtualNode): PVirtualNode; - function GetSortedCutCopySet(Resolve: Boolean): TNodeArray; - function GetSortedSelection(Resolve: Boolean): TNodeArray; - procedure GetTextInfo(Node: PVirtualNode; Column: TColumnIndex; const AFont: TFont; var R: TRect; - var Text: WideString); virtual; - function GetTreeRect: TRect; - function GetVisibleParent(Node: PVirtualNode): PVirtualNode; - function HasAsParent(Node, PotentialParent: PVirtualNode): Boolean; - function InsertNode(Node: PVirtualNode; Mode: TVTNodeAttachMode; UserData: Pointer = nil): PVirtualNode; - procedure InvalidateChildren(Node: PVirtualNode; Recursive: Boolean); - procedure InvalidateColumn(Column: TColumnIndex); - function InvalidateNode(Node: PVirtualNode): TRect; virtual; - procedure InvalidateToBottom(Node: PVirtualNode); - procedure InvertSelection(VisibleOnly: Boolean); - function IsEditing: Boolean; - function IsMouseSelecting: Boolean; - function IterateSubtree(Node: PVirtualNode; Callback: TVTGetNodeProc; Data: Pointer; Filter: TVirtualNodeStates = []; - DoInit: Boolean = False; ChildNodesOnly: Boolean = False): PVirtualNode; - procedure LoadFromFile(const FileName: TFileName); virtual; - procedure LoadFromStream(Stream: TStream); virtual; - procedure MeasureItemHeight(const Canvas: TCanvas; Node: PVirtualNode); - procedure MoveTo(Source, Target: PVirtualNode; Mode: TVTNodeAttachMode; ChildrenOnly: Boolean); overload; - procedure MoveTo(Node: PVirtualNode; Tree: TBaseVirtualTree; Mode: TVTNodeAttachMode; - ChildrenOnly: Boolean); overload; - procedure PaintTree(TargetCanvas: TCanvas; Window: TRect; Target: TPoint; PaintOptions: TVTInternalPaintOptions; - PixelFormat: TPixelFormat = pfDevice); - function PasteFromClipboard: Boolean; virtual; - procedure PrepareDragImage(HotSpot: TPoint; const DataObject: IDataObject); - {$ifdef EnablePrint} - procedure Print(Printer: TPrinter; PrintHeader: Boolean); - {$endif} - function ProcessDrop(DataObject: IDataObject; TargetNode: PVirtualNode; var Effect: Integer; Mode: - TVTNodeAttachMode): Boolean; - function ProcessOLEData(Source: TBaseVirtualTree; DataObject: IDataObject; TargetNode: PVirtualNode; - Mode: TVTNodeAttachMode; Optimized: Boolean): Boolean; - procedure RepaintNode(Node: PVirtualNode); - procedure ReinitChildren(Node: PVirtualNode; Recursive: Boolean); virtual; - procedure ReinitNode(Node: PVirtualNode; Recursive: Boolean); virtual; - procedure ResetNode(Node: PVirtualNode); virtual; - procedure SaveToFile(const FileName: TFileName); - procedure SaveToStream(Stream: TStream; Node: PVirtualNode = nil); virtual; - function ScrollIntoView(Node: PVirtualNode; Center: Boolean; Horizontally: Boolean = False): Boolean; - procedure SelectAll(VisibleOnly: Boolean); - procedure Sort(Node: PVirtualNode; Column: TColumnIndex; Direction: TSortDirection; DoInit: Boolean = True); virtual; - procedure SortTree(Column: TColumnIndex; Direction: TSortDirection; DoInit: Boolean = True); - procedure ToggleNode(Node: PVirtualNode); - function UpdateAction(Action: TBasicAction): Boolean; override; - procedure UpdateHorizontalScrollBar(DoRepaint: Boolean); - procedure UpdateScrollBars(DoRepaint: Boolean); virtual; - procedure UpdateVerticalScrollBar(DoRepaint: Boolean); - function UseRightToLeftAlignment: Boolean; - function UseRightToLeftReading: Boolean; - procedure ValidateChildren(Node: PVirtualNode; Recursive: Boolean); - procedure ValidateNode(Node: PVirtualNode; Recursive: Boolean); - {$ifdef EnableAccessible} - property Accessible: IAccessible read FAccessible write FAccessible; - property AccessibleItem: IAccessible read FAccessibleItem write FAccessibleItem; - property AccessibleName: string read FAccessibleName write FAccessibleName; - {$endif} - property CheckImages: TCustomImageList read FCheckImages; - property CheckState[Node: PVirtualNode]: TCheckState read GetCheckState write SetCheckState; - property CheckType[Node: PVirtualNode]: TCheckType read GetCheckType write SetCheckType; - property ChildCount[Node: PVirtualNode]: Cardinal read GetChildCount write SetChildCount; - property ChildrenInitialized[Node: PVirtualNode]: Boolean read GetChildrenInitialized; - property DragImage: TVTDragImage read FDragImage; - property DragManager: IVTDragManager read GetDragManager; - property DropTargetNode: PVirtualNode read FDropTargetNode; - property EditLink: IVTEditLink read FEditLink; - property Expanded[Node: PVirtualNode]: Boolean read GetExpanded write SetExpanded; - property FocusedColumn: TColumnIndex read FFocusedColumn write SetFocusedColumn default InvalidColumn; - property FocusedNode: PVirtualNode read FFocusedNode write SetFocusedNode; - property Font; - property FullyVisible[Node: PVirtualNode]: Boolean read GetFullyVisible write SetFullyVisible; - property HasChildren[Node: PVirtualNode]: Boolean read GetHasChildren write SetHasChildren; - property HotNode: PVirtualNode read FCurrentHotNode; - property IsDisabled[Node: PVirtualNode]: Boolean read GetDisabled write SetDisabled; - property IsVisible[Node: PVirtualNode]: Boolean read GetVisible write SetVisible; - property MultiLine[Node: PVirtualNode]: Boolean read GetMultiline write SetMultiline; - property NodeHeight[Node: PVirtualNode]: Cardinal read GetNodeHeight write SetNodeHeight; - property NodeParent[Node: PVirtualNode]: PVirtualNode read GetNodeParent write SetNodeParent; - property OffsetX: Integer read FOffsetX write SetOffsetX; - property OffsetXY: TPoint read GetOffsetXY write SetOffsetXY; - property OffsetY: Integer read FOffsetY write SetOffsetY; - property RootNode: PVirtualNode read FRoot; - property SearchBuffer: WideString read FSearchBuffer; - property Selected[Node: PVirtualNode]: Boolean read GetSelected write SetSelected; - property TotalCount: Cardinal read GetTotalCount; - property TreeStates: TVirtualTreeStates read FStates write FStates; - property SelectedCount: Integer read FSelectionCount; - property TopNode: PVirtualNode read GetTopNode write SetTopNode; - property VerticalAlignment[Node: PVirtualNode]: Byte read GetVerticalAlignment write SetVerticalAlignment; - property VisibleCount: Cardinal read FVisibleCount; - property VisiblePath[Node: PVirtualNode]: Boolean read GetVisiblePath write SetVisiblePath; - property UpdateCount: Cardinal read FUpdateCount; - 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 MiscOptions; - property PaintOptions; - property SelectionOptions; - property StringOptions; - end; - - TCustomVirtualStringTree = class; - - // Edit support classes. - TStringEditLink = class; - - {$ifdef TntSupport} - TVTEdit = class(TTntEdit) - {$else} - TVTEdit = class(TCustomEdit) - {$endif TntSupport} - private - FRefLink: IVTEditLink; - FLink: TStringEditLink; - procedure CMAutoAdjust(var Message: TLMessage); message CM_AUTOADJUST; - procedure CMExit(var Message: TLMessage); message CM_EXIT; - procedure CMRelease(var Message: TLMessage); message CM_RELEASE; - procedure CNCommand(var Message: TLMCommand); message CN_COMMAND; - procedure WMChar(var Message: TLMChar); message LM_CHAR; - procedure WMDestroy(var Message: TLMDestroy); message LM_DESTROY; - procedure WMGetDlgCode(var Message: TLMNoParams); message LM_GETDLGCODE; - procedure WMKeyDown(var Message: TLMKeyDown); message LM_KEYDOWN; - protected - procedure AutoAdjustSize; virtual; - procedure CreateParams(var Params: TCreateParams); override; - public - constructor Create(Link: TStringEditLink); reintroduce; - - 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. - 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); - public - constructor Create; - destructor Destroy; override; - - 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: TLMessage); virtual; stdcall; - procedure SetBounds(R: TRect); virtual; stdcall; - end; - - // Describes the type of text to return in the text and draw info retrival events. - TVSTTextType = ( - ttNormal, // normal label of the node, this is also the text which can be edited - ttStatic // static (non-editable) text after the normal text - ); - - // Describes the source to use when converting a string tree into a string for clipboard etc. - TVSTTextSourceType = ( - tstAll, // All nodes are rendered. Initialization is done on the fly. - tstInitialized, // Only initialized nodes are rendered. - tstSelected, // Only selected nodes are rendered. - tstCutCopySet, // Only nodes currently marked as being in the cut/copy clipboard set are rendered. - tstVisible // Only visible nodes are rendered. - ); - - TVTPaintText = procedure(Sender: TBaseVirtualTree; const TargetCanvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex; - TextType: TVSTTextType) of object; - TVSTGetTextEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; - TextType: TVSTTextType; var CellText: WideString) of object; - TVSTGetHintEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; - var LineBreakStyle: TVTTooltipLineBreakStyle; var HintText: WideString) of object; - // New text can only be set for variable caption. - TVSTNewTextEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; - NewText: WideString) of object; - TVSTShortenStringEvent = procedure(Sender: TBaseVirtualTree; TargetCanvas: TCanvas; Node: PVirtualNode; - Column: TColumnIndex; const S: WideString; TextSpace: Integer; var Result: WideString; - var Done: Boolean) of object; - - TCustomVirtualStringTree = class(TBaseVirtualTree) - private - FDefaultText: WideString; // text to show if there's no OnGetText event handler (e.g. at design time) - FTextHeight: Integer; // true size of the font - FEllipsisWidth: Integer; // width of '...' for the current font - FInternalDataOffset: Cardinal; // offset to the internal data of the string tree - - FOnPaintText: TVTPaintText; // triggered before either normal or fixed text is painted to allow - // even finer customization (kind of sub cell painting) - FOnGetText: TVSTGetTextEvent; // used to retrieve the string to be displayed for a specific node - FOnGetHint: TVSTGetHintEvent; // used to retrieve the hint to be displayed for a specific node - FOnNewText: TVSTNewTextEvent; // used to notify the application about an edited node caption - FOnShortenString: TVSTShortenStringEvent; // used to allow the application a customized string shortage - - procedure GetRenderStartValues(Source: TVSTTextSourceType; var Node: PVirtualNode; - var NextNodeProc: TGetNextNodeProc); - function GetOptions: TCustomStringTreeOptions; - function GetText(Node: PVirtualNode; Column: TColumnIndex): WideString; - procedure InitializeTextProperties(var PaintInfo: TVTPaintInfo); - procedure PaintNormalText(var PaintInfo: TVTPaintInfo; TextOutFlags: Integer; Text: WideString); - procedure PaintStaticText(const PaintInfo: TVTPaintInfo; TextOutFlags: Integer; const Text: WideString); - procedure ReadText(Reader: TReader); - procedure SetDefaultText(const Value: WideString); - procedure SetOptions(const Value: TCustomStringTreeOptions); - procedure SetText(Node: PVirtualNode; Column: TColumnIndex; const Value: WideString); - procedure WriteText(Writer: TWriter); - - procedure WMSetFont(var Msg: TLMNoParams{TWMSetFont}); message LM_SETFONT; - protected - procedure AdjustPaintCellRect(var PaintInfo: TVTPaintInfo; var NextNonEmpty: TColumnIndex); override; - function CalculateTextWidth(Canvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex; Text: WideString): Integer; virtual; - function ColumnIsEmpty(Node: PVirtualNode; Column: TColumnIndex): Boolean; override; - procedure DefineProperties(Filer: TFiler); override; - function DoCreateEditor(Node: PVirtualNode; Column: TColumnIndex): IVTEditLink; override; - function DoGetNodeHint(Node: PVirtualNode; Column: TColumnIndex; var LineBreakStyle: TVTTooltipLineBreakStyle): WideString; override; - function DoGetNodeTooltip(Node: PVirtualNode; Column: TColumnIndex; var LineBreakStyle: TVTTooltipLineBreakStyle): WideString; override; - function DoGetNodeWidth(Node: PVirtualNode; Column: TColumnIndex; Canvas: TCanvas = nil): Integer; override; - procedure DoGetText(Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType; - var Text: WideString); virtual; - function DoIncrementalSearch(Node: PVirtualNode; const Text: WideString): Integer; override; - procedure DoNewText(Node: PVirtualNode; Column: TColumnIndex; Text: WideString); virtual; - procedure DoPaintNode(var PaintInfo: TVTPaintInfo); override; - procedure DoPaintText(Node: PVirtualNode; const Canvas: TCanvas; Column: TColumnIndex; - TextType: TVSTTextType); virtual; - function DoShortenString(Canvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex; const S: WideString; Width: Integer; - EllipsisWidth: Integer = 0): WideString; virtual; - procedure DoTextDrawing(var PaintInfo: TVTPaintInfo; Text: WideString; CellRect: TRect; DrawFormat: Cardinal); virtual; - function DoTextMeasuring(Canvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex; Text: WideString): Integer; virtual; - function GetOptionsClass: TTreeOptionsClass; override; - function InternalData(Node: PVirtualNode): Pointer; - procedure MainColumnChanged; override; - function ReadChunk(Stream: TStream; Version: Integer; Node: PVirtualNode; ChunkType, - ChunkSize: Integer): Boolean; override; - procedure ReadOldStringOptions(Reader: TReader); - function RenderOLEData(const FormatEtcIn: TFormatEtc; out Medium: TStgMedium; ForClipboard: Boolean): HResult; override; - procedure WriteChunks(Stream: TStream; Node: PVirtualNode); override; - - property DefaultText: WideString read FDefaultText write SetDefaultText stored False; - property EllipsisWidth: Integer read FEllipsisWidth; - property TreeOptions: TCustomStringTreeOptions read GetOptions write SetOptions; - - property OnGetHint: TVSTGetHintEvent read FOnGetHint write FOnGetHint; - property OnGetText: TVSTGetTextEvent read FOnGetText write FOnGetText; - property OnNewText: TVSTNewTextEvent read FOnNewText write FOnNewText; - property OnPaintText: TVTPaintText read FOnPaintText write FOnPaintText; - property OnShortenString: TVSTShortenStringEvent read FOnShortenString write FOnShortenString; - public - constructor Create(AOwner: TComponent); override; - - function ComputeNodeHeight(Canvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex; S: WideString = ''): Integer; virtual; - function ContentToClipboard(Format: Word; Source: TVSTTextSourceType): HGLOBAL; - function ContentToHTML(Source: TVSTTextSourceType; Caption: WideString = ''): string; - function ContentToRTF(Source: TVSTTextSourceType): string; - function ContentToText(Source: TVSTTextSourceType; Separator: Char): string; - function ContentToUnicode(Source: TVSTTextSourceType; Separator: WideChar): WideString; - procedure GetTextInfo(Node: PVirtualNode; Column: TColumnIndex; const AFont: TFont; var R: TRect; - var Text: WideString); override; - function InvalidateNode(Node: PVirtualNode): TRect; override; - function Path(Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType; Delimiter: WideChar): WideString; - procedure ReinitNode(Node: PVirtualNode; Recursive: Boolean); override; - - property Text[Node: PVirtualNode; Column: TColumnIndex]: WideString read GetText write SetText; - end; - - TVirtualStringTree = class(TCustomVirtualStringTree) - private - function GetOptions: TStringTreeOptions; - procedure SetOptions(const Value: TStringTreeOptions); - protected - function GetOptionsClass: TTreeOptionsClass; override; - public - property Canvas; - published - {$ifdef EnableAccessible} - property AccessibleName; - {$endif} - 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 CheckImageKind; - property ClipboardFormats; - property Color; - property Colors; - property Constraints; - property Ctl3D; - property CustomCheckImages; - property DefaultNodeHeight; - property DefaultPasteMode; - property DefaultText; - 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 HintAnimation; - 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 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: TStringTreeOptions read GetOptions write SetOptions; - property Visible; - property WantTabs; - - property OnAdvancedHeaderDraw; - property OnAfterCellPaint; - property OnAfterItemErase; - property OnAfterItemPaint; - property OnAfterPaint; - property OnBeforeCellPaint; - property OnBeforeItemErase; - property OnBeforeItemPaint; - property OnBeforePaint; - property OnChange; - property OnChecked; - property OnChecking; - property OnClick; - property OnCollapsed; - property OnCollapsing; - property OnColumnClick; - property OnColumnDblClick; - property OnColumnResize; - property OnCompareNodes; - {$ifdef COMPILER_5_UP} - property OnContextPopup; - {$endif COMPILER_5_UP} - property OnCreateDataObject; - property OnCreateDragManager; - property OnCreateEditor; - property OnDblClick; - property OnDragAllowed; - property OnDragOver; - property OnDragDrop; - property OnEditCancelled; - property OnEdited; - property OnEditing; - property OnEndDock; - property OnEndDrag; - property OnEnter; - property OnExit; - property OnExpanded; - property OnExpanding; - property OnFocusChanged; - property OnFocusChanging; - property OnFreeNode; - property OnGetCellIsEmpty; - property OnGetCursor; - property OnGetHeaderCursor; - property OnGetText; - property OnPaintText; - property OnGetHelpContext; - property OnGetImageIndex; - property OnGetImageIndexEx; - property OnGetHint; - property OnGetLineStyle; - property OnGetNodeDataSize; - property OnGetPopupMenu; - property OnGetUserClipboardFormats; - property OnHeaderClick; - property OnHeaderDblClick; - property OnHeaderDragged; - property OnHeaderDraggedOut; - property OnHeaderDragging; - property OnHeaderDraw; - property OnHeaderDrawQueryElements; - 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 OnMeasureItem; - property OnMouseDown; - property OnMouseMove; - property OnMouseUp; - property OnMouseWheel; - property OnNewText; - property OnNodeCopied; - property OnNodeCopying; - property OnNodeMoved; - property OnNodeMoving; - property OnPaintBackground; - property OnRenderOLEData; - property OnResetNode; - property OnResize; - property OnSaveNode; - property OnScroll; - property OnShortenString; - property OnShowScrollbar; - property OnStartDock; - property OnStartDrag; - property OnStateChange; - property OnStructureChange; - property OnUpdating; - end; - - TVTDrawHintEvent = procedure(Sender: TBaseVirtualTree; HintCanvas: TCanvas; Node: PVirtualNode; R: TRect; - Column: TColumnIndex) of object; - TVTDrawNodeEvent = procedure(Sender: TBaseVirtualTree; const PaintInfo: TVTPaintInfo) of object; - TVTGetNodeWidthEvent = procedure(Sender: TBaseVirtualTree; HintCanvas: TCanvas; Node: PVirtualNode; - Column: TColumnIndex; var NodeWidth: Integer) of object; - TVTGetHintSizeEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; - var R: TRect) of object; - - // Tree descendant to let an application draw its stuff itself. - TCustomVirtualDrawTree = class(TBaseVirtualTree) - private - FOnDrawNode: TVTDrawNodeEvent; - FOnGetNodeWidth: TVTGetNodeWidthEvent; - FOnGetHintSize: TVTGetHintSizeEvent; - FOnDrawHint: TVTDrawHintEvent; - protected - procedure DoDrawHint(Canvas: TCanvas; Node: PVirtualNode; R: TRect; Column: TColumnIndex); - procedure DoGetHintSize(Node: PVirtualNode; Column: TColumnIndex; var R: TRect); virtual; - function DoGetNodeWidth(Node: PVirtualNode; Column: TColumnIndex; Canvas: TCanvas = nil): Integer; override; - procedure DoPaintNode(var PaintInfo: TVTPaintInfo); override; - - property OnDrawHint: TVTDrawHintEvent read FOnDrawHint write FOnDrawHint; - property OnDrawNode: TVTDrawNodeEvent read FOnDrawNode write FOnDrawNode; - property OnGetHintSize: TVTGetHintSizeEvent read FOnGetHintSize write FOnGetHintSize; - property OnGetNodeWidth: TVTGetNodeWidthEvent read FOnGetNodeWidth write FOnGetNodeWidth; - end; - - TVirtualDrawTree = class(TCustomVirtualDrawTree) - private - function GetOptions: TVirtualTreeOptions; - procedure SetOptions(const Value: TVirtualTreeOptions); - protected - function GetOptionsClass: TTreeOptionsClass; override; - public - property Canvas; - 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 CheckImageKind; - 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 HintAnimation; - 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 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 OnAdvancedHeaderDraw; - property OnAfterCellPaint; - property OnAfterItemErase; - property OnAfterItemPaint; - property OnAfterPaint; - property OnBeforeCellPaint; - property OnBeforeItemErase; - property OnBeforeItemPaint; - property OnBeforePaint; - property OnChange; - property OnChecked; - property OnChecking; - property OnClick; - property OnCollapsed; - property OnCollapsing; - property OnColumnClick; - property OnColumnDblClick; - property OnColumnResize; - property OnCompareNodes; - {$ifdef COMPILER_5_UP} - property OnContextPopup; - {$endif COMPILER_5_UP} - 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 OnEnter; - property OnExit; - property OnExpanded; - property OnExpanding; - property OnFocusChanged; - property OnFocusChanging; - property OnFreeNode; - property OnGetCellIsEmpty; - property OnGetCursor; - property OnGetHeaderCursor; - property OnGetHelpContext; - property OnGetHintSize; - property OnGetImageIndex; - property OnGetImageIndexEx; - property OnGetLineStyle; - property OnGetNodeDataSize; - property OnGetNodeWidth; - property OnGetPopupMenu; - property OnGetUserClipboardFormats; - property OnHeaderClick; - property OnHeaderDblClick; - property OnHeaderDragged; - property OnHeaderDraggedOut; - property OnHeaderDragging; - property OnHeaderDraw; - property OnHeaderDrawQueryElements; - 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 OnMeasureItem; - property OnMouseDown; - property OnMouseMove; - property OnMouseUp; - property OnMouseWheel; - property OnNodeCopied; - property OnNodeCopying; - property OnNodeMoved; - property OnNodeMoving; - property OnPaintBackground; - property OnRenderOLEData; - property OnResetNode; - property OnResize; - property OnSaveNode; - property OnScroll; - property OnShowScrollbar; - property OnStartDock; - property OnStartDrag; - property OnStateChange; - property OnStructureChange; - property OnUpdating; - end; - -type - // Describes the mode how to blend pixels. - TBlendMode = ( - bmConstantAlpha, // apply given constant alpha - bmPerPixelAlpha, // use alpha value of the source pixel - bmMasterAlpha, // use alpha value of source pixel and multiply it with the constant alpha value - bmConstantAlphaAndColor // blend the destination color with the given constant color und the constant alpha value - ); - -procedure Register; - -// OLE Clipboard and drag'n drop helper -procedure EnumerateVTClipboardFormats(TreeClass: TVirtualTreeClass; const List: TStrings); overload; -procedure EnumerateVTClipboardFormats(TreeClass: TVirtualTreeClass; var Formats: TFormatEtcArray); overload; -function GetVTClipboardFormatDescription(AFormat: Word): string; -procedure RegisterVTClipboardFormat(AFormat: Word; TreeClass: TVirtualTreeClass; Priority: Cardinal); overload; -function RegisterVTClipboardFormat(Description: string; TreeClass: TVirtualTreeClass; Priority: Cardinal; - tymed: Integer = TYMED_HGLOBAL; ptd: PDVTargetDevice = nil; dwAspect: Integer = DVASPECT_CONTENT; - lindex: Integer = -1): Word; overload; - -// utility routines -procedure AlphaBlend(Source, Destination: HDC; R: TRect; Target: TPoint; Mode: TBlendMode; ConstantAlpha, Bias: Integer); -procedure DrawTextW(DC: HDC; lpString: PWideChar; nCount: Integer; var lpRect: TRect; uFormat: Cardinal; - AdjustRight: Boolean); -{$ifdef EnablePrint} -procedure PrtStretchDrawDIB(Canvas: TCanvas; DestRect: TRect; ABitmap: TBitmap); -{$endif} -function ShortenString(DC: HDC; const S: WideString; Width: Integer; EllipsisWidth: Integer = 0): WideString; -function TreeFromNode(Node: PVirtualNode): TBaseVirtualTree; - -//---------------------------------------------------------------------------------------------------------------------- - -implementation - -{.$R VirtualTrees.res} - -uses - {Consts,} Math, - {$ifdef EnableOLE} - //AxCtrls, // TOLEStream - {$endif} - {$ifdef UseFlatScrollbars} - FlatSB, // wrapper for systems without flat SB support - {$endif UseFlatScrollbars} - MMSystem, // for animation timer (does not include further resources) - TypInfo, // for migration stuff - ActnList, - StdActns // for standard action support - {$ifdef EnableAccessible} - ,VTAccessibilityFactory - {$endif}; // accessibility helper class - -resourcestring - // Localizable strings. - SEditLinkIsNil = 'Edit link must not be nil.'; - SWrongMoveError = 'Target node cannot be a child node of the node to be moved.'; - SWrongStreamFormat = 'Unable to load tree structure, the format is wrong.'; - SWrongStreamVersion = 'Unable to load tree structure, the version is unknown.'; - SStreamTooSmall = 'Unable to load tree structure, not enough data available.'; - SCorruptStream1 = 'Stream data corrupt. A node''s anchor chunk is missing.'; - SCorruptStream2 = 'Stream data corrupt. Unexpected data after node''s end position.'; - SClipboardFailed = 'Clipboard operation failed.'; - SCannotSetUserData = 'Cannot set initial user data because there is not enough user data space allocated.'; - -const - ClipboardStates = [tsCopyPending, tsCutPending]; - DefaultScrollUpdateFlags = [suoRepaintHeader, suoRepaintScrollbars, suoScrollClientArea, suoUpdateNCArea]; - MinimumTimerInterval = 1; // minimum resolution for timeGetTime - TreeNodeSize = (SizeOf(TVirtualNode) + 3) and not 3; // used for node allocation and access to internal data - - // Lookup to quickly convert a specific check state into its pressed counterpart and vice versa. - PressedState: array[TCheckState] of TCheckState = ( - csUncheckedPressed, csUncheckedPressed, csCheckedPressed, csCheckedPressed, csMixedPressed, csMixedPressed - ); - UnpressedState: array[TCheckState] of TCheckState = ( - csUncheckedNormal, csUncheckedNormal, csCheckedNormal, csCheckedNormal, csMixedNormal, csMixedNormal - ); - MouseButtonDown = [tsLeftButtonDown, tsMiddleButtonDown, tsRightButtonDown]; - - // Do not modify the copyright in any way! Usage of this unit is prohibited without the copyright notice - // in the compiled binary file. - Copyright: string = 'Virtual Treeview © 1999, 2003 Mike Lischke'; - -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 // streaming support - TMagicID = array[0..5] of WideChar; - - TChunkHeader = record - ChunkType, - ChunkSize: Integer; // contains the size of the chunk excluding the header - end; - - // base information about a node - TBaseChunkBody = packed record - ChildCount, - NodeHeight: Cardinal; - States: TVirtualNodeStates; - Align: Byte; - CheckState: TCheckState; - CheckType: TCheckType; - Reserved: Cardinal; - end; - - TBaseChunk = packed record - Header: TChunkHeader; - Body: TBaseChunkBody; - end; - - // Internally used data for animations. - TToggleAnimationData = record - Expand: Boolean; // if true then expanding is in progress - Window: HWND; // copy of the tree's window handle - DC: HDC; // the DC of the window to erase unconvered parts - Brush: HBRUSH; // the brush to be used to erase uncovered parts - R: TRect; // the scroll rectangle - end; - -const - MagicID: TMagicID = (#$2045, 'V', 'T', WideChar(VTTreeStreamVersion), ' ', #$2046); - - // chunk IDs - NodeChunk = 1; - BaseChunk = 2; // chunk containing node state, check state, child node count etc. - // this chunk is immediately followed by all child nodes - CaptionChunk = 3; // used by the string tree to store a node's caption - UserChunk = 4; // used for data supplied by the application - - {$ifdef UseFlatScrollbars} - ScrollBarProp: array[TScrollBarStyle] of Integer = ( - FSB_REGULAR_MODE, - FSB_FLAT_MODE, - FSB_ENCARTA_MODE - ); - {$endif} - - RTLFlag: array[Boolean] of Integer = (0, ETO_RTLREADING); - AlignmentToDrawFlag: array[TAlignment] of Cardinal = (DT_LEFT, DT_RIGHT, DT_CENTER); - - WideNull = WideChar(#0); - WideCR = WideChar(#13); - WideLF = WideChar(#10); - WideLineSeparator = WideChar(#2028); - -type - TVTCriticalSection = class(TObject) - protected - FSection: LCLType.TCriticalSection; - public - constructor Create; - destructor Destroy; override; - - procedure Enter; - procedure Leave; - end; - - // internal worker thread - TWorkerThread = class(TThread) - private - FCurrentTree: TBaseVirtualTree; - FWaiterList: TThreadList; - FRefCount: Cardinal; - protected - procedure ChangeTreeStates(EnterStates, LeaveStates: TChangeStates); - procedure Execute; override; - public - constructor Create(CreateSuspended: Boolean); - destructor Destroy; override; - - procedure AddTree(Tree: TBaseVirtualTree); - procedure RemoveTree(Tree: TBaseVirtualTree); - - property CurrentTree: TBaseVirtualTree read FCurrentTree; - end; - - // Helper classes to speed up rendering text formats for clipboard and drag'n drop transfers. - TBufferedString = class - private - FStart, - FPosition, - FEnd: PChar; - function GetAsString: string; - public - destructor Destroy; override; - - procedure Add(const S: string); - procedure AddNewLine; - - property AsString: string read GetAsString; - end; - - TWideBufferedString = class - private - FStart, - FPosition, - FEnd: PWideChar; - function GetAsString: WideString; - public - destructor Destroy; override; - - procedure Add(const S: WideString); - procedure AddNewLine; - - property AsString: WideString read GetAsString; - end; - -var - WorkerThread: TWorkerThread; - WorkEvent: TEvent; - Watcher: TVTCriticalSection; - LightCheckImages, // global light check images - DarkCheckImages, // global heavy check images - LightTickImages, // global light tick images - DarkTickImages, // global heavy check images - FlatImages, // global flat check images - XPImages, // global XP style check images - UtilityImages, // some small additional images (e.g for header dragging) - SystemCheckImages, // global system check images - SystemFlatCheckImages: TImageList; // global flat system check images - Initialized: Boolean; // True if global structures have been initialized. - NeedToUnitialize: Boolean; // True if the OLE subsystem could be initialized successfully. - -{$I lclfunctions.inc} - -//----------------- TClipboardFormats ---------------------------------------------------------------------------------- - -type - PClipboardFormatListEntry = ^TClipboardFormatListEntry; - TClipboardFormatListEntry = record - Description: string; // The string used to register the format with Windows. - TreeClass: TVirtualTreeClass; // The tree class which supports rendering this format. - Priority: Cardinal; // Number which determines the order of formats used in IDataObject. - FormatEtc: TFormatEtc; // The definition of the format in the IDataObject. - end; - - TClipboardFormatList = class - private - FList: TList; - procedure Sort; - public - constructor Create; - destructor Destroy; override; - - procedure Add(FormatString: string; AClass: TVirtualTreeClass; Priority: Cardinal; AFormatEtc: TFormatEtc); - procedure Clear; - procedure EnumerateFormats(TreeClass: TVirtualTreeClass; var Formats: TFormatEtcArray; - const AllowedFormats: TClipboardFormats = nil); overload; - procedure EnumerateFormats(TreeClass: TVirtualTreeClass; const Formats: TStrings); overload; - function FindFormat(FormatString: string): PClipboardFormatListEntry; overload; - function FindFormat(FormatString: string; var Fmt: Word): TVirtualTreeClass; overload; - function FindFormat(Fmt: Word; var Description: string): TVirtualTreeClass; overload; - end; - -var - InternalClipboardFormats: TClipboardFormatList; - -//---------------------------------------------------------------------------------------------------------------------- - -constructor TClipboardFormatList.Create; - -begin - FList := TList.Create; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -destructor TClipboardFormatList.Destroy; - -begin - Clear; - FList.Free; - inherited; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TClipboardFormatList.Sort; - -// Sorts all entry for priority (increasing priority value). - - //--------------- local function -------------------------------------------- - - procedure QuickSort(L, R: Integer); - - var - I, J: Integer; - P, T: PClipboardFormatListEntry; - - begin - repeat - I := L; - J := R; - P := FList[(L + R) shr 1]; - repeat - while PClipboardFormatListEntry(FList[I]).Priority < P.Priority do - Inc(I); - while PClipboardFormatListEntry(Flist[J]).Priority > P.Priority do - Dec(J); - if I <= J then - begin - T := Flist[I]; - FList[I] := FList[J]; - FList[J] := T; - Inc(I); - Dec(J); - end; - until I > J; - if L < J then - QuickSort(L, J); - L := I; - until I >= R; - end; - - //--------------- end local function ---------------------------------------- - -begin - if FList.Count > 1 then - QuickSort(0, FList.Count - 1); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TClipboardFormatList.Add(FormatString: string; AClass: TVirtualTreeClass; Priority: Cardinal; - AFormatEtc: TFormatEtc); - -// Adds the given data to the internal list. The priority value is used to sort formats for importance. Larger priority -// values mean less priority. - -var - Entry: PClipboardFormatListEntry; - -begin - New(Entry); - Entry.Description := FormatString; - Entry.TreeClass := AClass; - Entry.Priority := Priority; - Entry.FormatEtc := AFormatEtc; - FList.Add(Entry); - - Sort; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TClipboardFormatList.Clear; - -var - I: Integer; - -begin - for I := 0 to FList.Count - 1 do - Dispose(PClipboardFormatListEntry(FList[I])); - FList.Clear; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TClipboardFormatList.EnumerateFormats(TreeClass: TVirtualTreeClass; var Formats: TFormatEtcArray; - const AllowedFormats: TClipboardFormats = nil); - -// Returns a list of format records for the given class. If assigned the AllowedFormats is used to limit the -// enumerated formats to those described in the list. - -var - I, Count: Integer; - Entry: PClipboardFormatListEntry; - -begin - SetLength(Formats, FList.Count); - Count := 0; - for I := 0 to FList.Count - 1 do - begin - Entry := FList[I]; - // Does the tree class support this clipboard format? - if TreeClass.InheritsFrom(Entry.TreeClass) then - begin - // Is this format allowed to be included? - if (AllowedFormats = nil) or (AllowedFormats.IndexOf(Entry.Description) > -1) then - begin - // The list could change before we use the FormatEtc so it is best not to pass a pointer to the true FormatEtc - // structure. Instead make a copy and send that. - Formats[Count] := Entry.FormatEtc; - Inc(Count); - end; - end; - end; - SetLength(Formats, Count); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TClipboardFormatList.EnumerateFormats(TreeClass: TVirtualTreeClass; const Formats: TStrings); - -// Returns a list of format descriptions for the given class. - -var - I: Integer; - Entry: PClipboardFormatListEntry; - -begin - for I := 0 to FList.Count - 1 do - begin - Entry := FList[I]; - if TreeClass.InheritsFrom(Entry.TreeClass) then - Formats.Add(Entry.Description); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TClipboardFormatList.FindFormat(FormatString: string): PClipboardFormatListEntry; - -var - I: Integer; - Entry: PClipboardFormatListEntry; - -begin - Result := nil; - for I := FList.Count - 1 downto 0 do - begin - Entry := FList[I]; - if CompareText(Entry.Description, FormatString) = 0 then - begin - Result := Entry; - Break; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TClipboardFormatList.FindFormat(FormatString: string; var Fmt: Word): TVirtualTreeClass; - -var - I: Integer; - Entry: PClipboardFormatListEntry; - -begin - Result := nil; - for I := FList.Count - 1 downto 0 do - begin - Entry := FList[I]; - if CompareText(Entry.Description, FormatString) = 0 then - begin - Result := Entry.TreeClass; - Fmt := Entry.FormatEtc.cfFormat; - Break; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TClipboardFormatList.FindFormat(Fmt: Word; var Description: string): TVirtualTreeClass; - -var - I: Integer; - Entry: PClipboardFormatListEntry; - -begin - Result := nil; - for I := FList.Count - 1 downto 0 do - begin - Entry := FList[I]; - if Entry.FormatEtc.cfFormat = Fmt then - begin - Result := Entry.TreeClass; - Description := Entry.Description; - Break; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -type - TClipboardFormatEntry = record - ID: Word; - Description: string; - end; - -var - ClipboardDescriptions: array [1..CF_MAX - 1] of TClipboardFormatEntry = ( - (ID: CF_TEXT; Description: 'Plain text'), // Do not localize - (ID: CF_BITMAP; Description: 'Windows bitmap'), // Do not localize - (ID: CF_METAFILEPICT; Description: 'Windows metafile'), // Do not localize - (ID: CF_SYLK; Description: 'Symbolic link'), // Do not localize - (ID: CF_DIF; Description: 'Data interchange format'), // Do not localize - (ID: CF_TIFF; Description: 'Tiff image'), // Do not localize - (ID: CF_OEMTEXT; Description: 'OEM text'), // Do not localize - (ID: CF_DIB; Description: 'DIB image'), // Do not localize - (ID: CF_PALETTE; Description: 'Palette data'), // Do not localize - (ID: CF_PENDATA; Description: 'Pen data'), // Do not localize - (ID: CF_RIFF; Description: 'Riff audio data'), // Do not localize - (ID: CF_WAVE; Description: 'Wav audio data'), // Do not localize - (ID: CF_UNICODETEXT; Description: 'Unicode text'), // Do not localize - (ID: CF_ENHMETAFILE; Description: 'Enhanced metafile image'), // Do not localize - (ID: CF_HDROP; Description: 'File name(s)'), // Do not localize - (ID: CF_LOCALE; Description: 'Locale descriptor') // Do not localize - ); - -//---------------------------------------------------------------------------------------------------------------------- - -procedure EnumerateVTClipboardFormats(TreeClass: TVirtualTreeClass; const List: TStrings); - -begin - if InternalClipboardFormats = nil then - InternalClipboardFormats := TClipboardFormatList.Create; - InternalClipboardFormats.EnumerateFormats(TreeClass, List); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure EnumerateVTClipboardFormats(TreeClass: TVirtualTreeClass; var Formats: TFormatEtcArray); - -begin - if InternalClipboardFormats = nil then - InternalClipboardFormats := TClipboardFormatList.Create; - InternalClipboardFormats.EnumerateFormats(TreeClass, Formats); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function GetVTClipboardFormatDescription(AFormat: Word): string; - -begin - if InternalClipboardFormats = nil then - InternalClipboardFormats := TClipboardFormatList.Create; - if InternalClipboardFormats.FindFormat(AFormat, Result) = nil then - Result := ''; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure RegisterVTClipboardFormat(AFormat: Word; TreeClass: TVirtualTreeClass; Priority: Cardinal); - -// Registers the given clipboard format for the given TreeClass. - -var - I: Integer; - FormatEtc: TFormatEtc; - -begin - if InternalClipboardFormats = nil then - InternalClipboardFormats := TClipboardFormatList.Create; - - // Assumes a HGlobal format. - FormatEtc.cfFormat := AFormat; - FormatEtc.ptd := nil; - FormatEtc.dwAspect := DVASPECT_CONTENT; - FormatEtc.lindex := -1; - FormatEtc.tymed := TYMED_HGLOBAL; - - // Determine description string of the given format. For predefined formats we need the lookup table because they - // don't have a description string. For registered formats the description string is the string which was used - // to register them. - if AFormat < CF_MAX then - begin - for I := 1 to High(ClipboardDescriptions) do - if ClipboardDescriptions[I].ID = AFormat then - begin - InternalClipboardFormats.Add(ClipboardDescriptions[I].Description, TreeClass, Priority, FormatEtc); - Break; - end; - end - else - begin - InternalClipboardFormats.Add(ClipboardFormatToMimeType(AFormat), TreeClass, Priority, FormatEtc); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function RegisterVTClipboardFormat(Description: string; TreeClass: TVirtualTreeClass; Priority: Cardinal; - tymed: Integer = TYMED_HGLOBAL; ptd: PDVTargetDevice = nil; dwAspect: Integer = DVASPECT_CONTENT; - lindex: Integer = -1): Word; - -// Alternative method to register a certain clipboard format for a given tree class. Registration with the -// clipboard is done here too and the assigned ID returned by the function. -// tymed may contain or'ed TYMED constants which allows to register several storage formats for one clipboard format. - -var - FormatEtc: TFormatEtc; - -begin - if InternalClipboardFormats = nil then - InternalClipboardFormats := TClipboardFormatList.Create; - Result := ClipboardRegisterFormat(Description); - FormatEtc.cfFormat := Result; - FormatEtc.ptd := ptd; - FormatEtc.dwAspect := dwAspect; - FormatEtc.lindex := lindex; - FormatEtc.tymed := tymed; - InternalClipboardFormats.Add(Description, TreeClass, Priority, FormatEtc); -end; - -//----------------- utility functions ---------------------------------------------------------------------------------- - -procedure ShowError(Msg: WideString; HelpContext: Integer); - -begin - raise EVirtualTreeError.CreateHelp(Msg, HelpContext); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TreeFromNode(Node: PVirtualNode): TBaseVirtualTree; - -// Returns the tree the node currently belongs to or nil if the node is not attached to a tree. - -begin - Assert(Assigned(Node), 'Node must not be nil.'); - - // The root node is marked by having its NextSibling (and PrevSibling) pointing to itself. - while Assigned(Node) and (Node.NextSibling <> Node) do - Node := Node.Parent; - if Assigned(Node) then - Result := TBaseVirtualTree(Node.Parent) - else - Result := nil; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function OrderRect(const R: TRect): TRect; - -// Converts the incoming rectangle so that left and top are always less than or equal to right and bottom. - -begin - if R.Left < R.Right then - begin - Result.Left := R.Left; - Result.Right := R.Right; - end - else - begin - Result.Left := R.Right; - Result.Right := R.Left; - end; - if R.Top < R.Bottom then - begin - Result.Top := R.Top; - Result.Bottom := R.Bottom; - end - else - begin - Result.Top := R.Bottom; - Result.Bottom := R.Top; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure QuickSort(const TheArray: TNodeArray; L, R: Integer); - -var - I, J: Integer; - P, T: Pointer; - -begin - repeat - I := L; - J := R; - P := TheArray[(L + R) shr 1]; - repeat - while Cardinal(TheArray[I]) < Cardinal(P) do - Inc(I); - while Cardinal(TheArray[J]) > Cardinal(P) do - Dec(J); - if I <= J then - begin - T := TheArray[I]; - TheArray[I] := TheArray[J]; - TheArray[J] := T; - Inc(I); - Dec(J); - end; - until I > J; - if L < J then - QuickSort(TheArray, L, J); - L := I; - until I >= R; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure DrawTextW(DC: HDC; lpString: PWideChar; nCount: Integer; var lpRect: TRect; uFormat: Cardinal; - AdjustRight: Boolean); - -// This procedure implements a subset of Window's DrawText API for Unicode which is not available for -// Windows 9x. For a description of the parameters see DrawText in the online help. -// Supported flags are currently: -// - DT_LEFT -// - DT_TOP -// - DT_CALCRECT -// - DT_NOCLIP -// - DT_RTLREADING -// - DT_SINGLELINE -// - DT_VCENTER -// Differences to the DrawTextW Windows API: -// - The additional parameter AdjustRight determines whether to adjust the right border of the given rectangle to -// accomodate the largest line in the text. It has only a meaning if also DT_CALCRECT is specified. - -var - Head, Tail: PWideChar; - Size: TSize; - MaxWidth: Integer; - TextOutFlags: Integer; - TextAlign, - OldTextAlign: Cardinal; - TM: TTextMetric; - TextHeight: Integer; - LineRect: TRect; - TextPosY, - TextPosX: Integer; - - CalculateRect: Boolean; - -begin - // Prepare some work variables. - MaxWidth := 0; - Head := lpString; - GetTextMetrics(DC, TM); - TextHeight := TM.tmHeight; - if uFormat and DT_SINGLELINE <> 0 then - LineRect := lpRect - else - LineRect := Rect(lpRect.Left, lpRect.Top, lpRect.Right, lpRect.Top + TextHeight); - - CalculateRect := uFormat and DT_CALCRECT <> 0; - - // Prepare text output. - TextOutFlags := 0; - if uFormat and DT_NOCLIP = 0 then - TextOutFlags := TextOutFlags or ETO_CLIPPED; - if uFormat and DT_RTLREADING <> 0 then - TextOutFlags := TextOutFlags or ETO_RTLREADING; - - // Determine horizontal and vertical text alignment. - OldTextAlign := GetTextAlign(DC); - TextAlign := TA_LEFT or TA_TOP; - TextPosX := lpRect.Left; - if uFormat and DT_RIGHT <> 0 then - begin - TextAlign := TextAlign or TA_RIGHT and not TA_LEFT; - TextPosX := lpRect.Right; - end - else - if uFormat and DT_CENTER <> 0 then - begin - TextAlign := TextAlign or TA_CENTER and not TA_LEFT; - TextPosX := (lpRect.Left + lpRect.Right) div 2; - end; - - TextPosY := lpRect.Top; - if uFormat and DT_VCENTER <> 0 then - begin - // Note: vertical alignment does only work with single line text ouput! - TextPosY := (lpRect.Top + lpRect.Bottom - TextHeight) div 2; - end; - SetTextAlign(DC, TextAlign); - - if uFormat and DT_SINGLELINE <> 0 then - begin - if CalculateRect then - begin - GetTextExtentPoint32W(DC, Head, nCount, Size); - if Size.cx > MaxWidth then - MaxWidth := Size.cx; - end - else - ExtTextOutW(DC, TextPosX, TextPosY, TextOutFlags, @LineRect, Head, nCount, nil); - OffsetRect(LineRect, 0, TextHeight); - end - else - begin - while (nCount > 0) and (Head^ <> WideNull) do - begin - Tail := Head; - // Look for the end of the current line. A line is finished either by the string end or a line break. - while (nCount > 0) and not (Tail^ in [WideNull, WideCR, WideLF]) and (Tail^ <> WideLineSeparator) do - begin - Inc(Tail); - Dec(nCount); - end; - - if CalculateRect then - begin - GetTextExtentPoint32W(DC, Head, Tail - Head, Size); - if Size.cx > MaxWidth then - MaxWidth := Size.cx; - end - else - ExtTextOutW(DC, TextPosX, LineRect.Top, TextOutFlags, @LineRect, Head, Tail - Head, nil); - OffsetRect(LineRect, 0, TextHeight); - - // Get out of the loop if the rectangle is filled up. - if (nCount = 0) or (not CalculateRect and (LineRect.Top >= lpRect.Bottom)) then - Break; - - if (nCount > 0) and (Tail^ = WideCR) or (Tail^ = WideLineSeparator) then - begin - Inc(Tail); - Dec(nCount); - end; - - if (nCount > 0) and (Tail^ = WideLF) then - begin - Inc(Tail); - Dec(nCount); - end; - Head := Tail; - end; - end; - - SetTextAlign(DC, OldTextAlign); - if CalculateRect then - begin - if AdjustRight then - lpRect.Right := lpRect.Left + MaxWidth; - lpRect.Bottom := LineRect.Top; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function ShortenString(DC: HDC; const S: WideString; Width: Integer; EllipsisWidth: Integer = 0): WideString; - -// Adjusts the given string S so that it fits into the given width. EllipsisWidth gives the width of -// the three points to be added to the shorted string. If this value is 0 then it will be determined implicitely. -// For higher speed (and multiple entries to be shorted) specify this value explicitely. -// Note: It is assumed that the string really needs shortage. Check this in advance. - -var - Size: TSize; - Len: Integer; - L, H, N, W: Integer; - -begin - Len := Length(S); - if (Len = 0) or (Width <= 0) then - Result := '' - else - begin - // Determine width of triple point using the current DC settings (if not already done). - if EllipsisWidth = 0 then - begin - GetTextExtentPoint32W(DC, '...', 3, Size); - EllipsisWidth := Size.cx; - end; - - if Width <= EllipsisWidth then - Result := '' - else - begin - // Do a binary search for the optimal string length which fits into the given width. - L := 0; - H := Len - 1; - while L < H do - begin - N := (L + H + 1) shr 1; - GetTextExtentPoint32W(DC, PWideChar(S), N, Size); - W := Size.cx + EllipsisWidth; - if W <= Width then - L := N - else - H := N - 1; - end; - Result := Copy(S, 1, L) + '...' - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure FillDragRectangles(DragWidth, DragHeight, DeltaX, DeltaY: Integer; var RClip, RScroll, RSamp1, RSamp2, RDraw1, - RDraw2: TRect); - -// Fills the given rectangles with values which can be used while dragging around an image -// (used in DragMove of the drag manager and DragTo of the header columns). - -begin - // ScrollDC limits - RClip := Rect(0, 0, DragWidth, DragHeight); - if DeltaX > 0 then - begin - // move to the left - if DeltaY = 0 then - begin - // move only to the left - // background movement - RScroll := Rect(0, 0, DragWidth - DeltaX, DragHeight); - RSamp1 := Rect(0, 0, DeltaX, DragHeight); - RDraw1 := Rect(DragWidth - DeltaX, 0, DeltaX, DragHeight); - end - else - if DeltaY < 0 then - begin - // move to bottom left - RScroll := Rect(0, -DeltaY, DragWidth - DeltaX, DragHeight); - RSamp1 := Rect(0, 0, DeltaX, DragHeight); - RSamp2 := Rect(DeltaX, DragHeight + DeltaY, DragWidth - DeltaX, -DeltaY); - RDraw1 := Rect(0, 0, DragWidth - DeltaX, -DeltaY); - RDraw2 := Rect(DragWidth - DeltaX, 0, DeltaX, DragHeight); - end - else - begin - // move to upper left - RScroll := Rect(0, 0, DragWidth - DeltaX, DragHeight - DeltaY); - RSamp1 := Rect(0, 0, DeltaX, DragHeight); - RSamp2 := Rect(DeltaX, 0, DragWidth - DeltaX, DeltaY); - RDraw1 := Rect(0, DragHeight - DeltaY, DragWidth - DeltaX, DeltaY); - RDraw2 := Rect(DragWidth - DeltaX, 0, DeltaX, DragHeight); - end; - end - else - if DeltaX = 0 then - begin - // vertical movement only - if DeltaY < 0 then - begin - // move downwards - RScroll := Rect(0, -DeltaY, DragWidth, DragHeight); - RSamp2 := Rect(0, DragHeight + DeltaY, DragWidth, -DeltaY); - RDraw2 := Rect(0, 0, DragWidth, -DeltaY); - end - else - begin - // move upwards - RScroll := Rect(0, 0, DragWidth, DragHeight - DeltaY); - RSamp2 := Rect(0, 0, DragWidth, DeltaY); - RDraw2 := Rect(0, DragHeight - DeltaY, DragWidth, DeltaY); - end; - end - else - begin - // move to the right - if DeltaY > 0 then - begin - // move up right - RScroll := Rect(-DeltaX, 0, DragWidth, DragHeight); - RSamp1 := Rect(0, 0, DragWidth + DeltaX, DeltaY); - RSamp2 := Rect(DragWidth + DeltaX, 0, -DeltaX, DragHeight); - RDraw1 := Rect(0, 0, -DeltaX, DragHeight); - RDraw2 := Rect(-DeltaX, DragHeight - DeltaY, DragWidth + DeltaX, DeltaY); - end - else - if DeltaY = 0 then - begin - // to the right only - RScroll := Rect(-DeltaX, 0, DragWidth, DragHeight); - RSamp1 := Rect(DragWidth + DeltaX, 0, -DeltaX, DragHeight); - RDraw1 := Rect(0, 0, -DeltaX, DragHeight); - end - else - begin - // move down right - RScroll := Rect(-DeltaX, -DeltaY, DragWidth, DragHeight); - RSamp1 := Rect(0, DragHeight + DeltaY, DragWidth + DeltaX, -DeltaY); - RSamp2 := Rect(DragWidth + DeltaX, 0, -DeltaX, DragHeight); - RDraw1 := Rect(0, 0, -DeltaX, DragHeight); - RDraw2 := Rect(-DeltaX, 0, DragWidth + DeltaX, -DeltaY); - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure AlphaBlendLineConstant(Source, Destination: Pointer; Count: Integer; ConstantAlpha, Bias: Integer); - -// Blends a line of Count pixels from Source to Destination using a constant alpha value. -// The layout of a pixel must be BGRA where A is ignored (but is calculated as the other components). -// ConstantAlpha must be in the range 0..255 where 0 means totally transparent (destination pixel only) -// and 255 totally opaque (source pixel only). -// Bias is an additional value which gets added to every component and must be in the range -128..127 -// -// EAX contains Source -// EDX contains Destination -// ECX contains Count -// ConstantAlpha and Bias are on the stack - -asm - PUSH ESI // save used registers - PUSH EDI - - MOV ESI, EAX // ESI becomes the actual source pointer - MOV EDI, EDX // EDI becomes the actual target pointer - - // Load MM6 with the constant alpha value (replicate it for every component). - // Expand it to word size. - MOV EAX, [ConstantAlpha] - DB $0F, $6E, $F0 /// MOVD MM6, EAX - DB $0F, $61, $F6 /// PUNPCKLWD MM6, MM6 - DB $0F, $62, $F6 /// PUNPCKLDQ MM6, MM6 - - // Load MM5 with the bias value. - MOV EAX, [Bias] - DB $0F, $6E, $E8 /// MOVD MM5, EAX - DB $0F, $61, $ED /// PUNPCKLWD MM5, MM5 - DB $0F, $62, $ED /// PUNPCKLDQ MM5, MM5 - - // Load MM4 with 128 to allow for saturated biasing. - MOV EAX, 128 - DB $0F, $6E, $E0 /// MOVD MM4, EAX - DB $0F, $61, $E4 /// PUNPCKLWD MM4, MM4 - DB $0F, $62, $E4 /// PUNPCKLDQ MM4, MM4 - -@1: // The pixel loop calculates an entire pixel in one run. - // Note: The pixel byte values are expanded into the higher bytes of a word due - // to the way unpacking works. We compensate for this with an extra shift. - DB $0F, $EF, $C0 /// PXOR MM0, MM0, clear source pixel register for unpacking - DB $0F, $60, $06 /// PUNPCKLBW MM0, [ESI], unpack source pixel byte values into words - DB $0F, $71, $D0, $08 /// PSRLW MM0, 8, move higher bytes to lower bytes - DB $0F, $EF, $C9 /// PXOR MM1, MM1, clear target pixel register for unpacking - DB $0F, $60, $0F /// PUNPCKLBW MM1, [EDI], unpack target pixel byte values into words - DB $0F, $6F, $D1 /// MOVQ MM2, MM1, make a copy of the shifted values, we need them again - DB $0F, $71, $D1, $08 /// PSRLW MM1, 8, move higher bytes to lower bytes - - // calculation is: target = (alpha * (source - target) + 256 * target) / 256 - DB $0F, $F9, $C1 /// PSUBW MM0, MM1, source - target - DB $0F, $D5, $C6 /// PMULLW MM0, MM6, alpha * (source - target) - DB $0F, $FD, $C2 /// PADDW MM0, MM2, add target (in shifted form) - DB $0F, $71, $D0, $08 /// PSRLW MM0, 8, divide by 256 - - // Bias is accounted for by conversion of range 0..255 to -128..127, - // doing a saturated add and convert back to 0..255. - DB $0F, $F9, $C4 /// PSUBW MM0, MM4 - DB $0F, $ED, $C5 /// PADDSW MM0, MM5 - DB $0F, $FD, $C4 /// PADDW MM0, MM4 - DB $0F, $67, $C0 /// PACKUSWB MM0, MM0, convert words to bytes with saturation - DB $0F, $7E, $07 /// MOVD [EDI], MM0, store the result -@3: - ADD ESI, 4 - ADD EDI, 4 - DEC ECX - JNZ @1 - POP EDI - POP ESI -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure AlphaBlendLinePerPixel(Source, Destination: Pointer; Count, Bias: Integer); - -// Blends a line of Count pixels from Source to Destination using the alpha value of the source pixels. -// The layout of a pixel must be BGRA. -// Bias is an additional value which gets added to every component and must be in the range -128..127 -// -// EAX contains Source -// EDX contains Destination -// ECX contains Count -// Bias is on the stack - -asm - PUSH ESI // save used registers - PUSH EDI - - MOV ESI, EAX // ESI becomes the actual source pointer - MOV EDI, EDX // EDI becomes the actual target pointer - - // Load MM5 with the bias value. - MOV EAX, [Bias] - DB $0F, $6E, $E8 /// MOVD MM5, EAX - DB $0F, $61, $ED /// PUNPCKLWD MM5, MM5 - DB $0F, $62, $ED /// PUNPCKLDQ MM5, MM5 - - // Load MM4 with 128 to allow for saturated biasing. - MOV EAX, 128 - DB $0F, $6E, $E0 /// MOVD MM4, EAX - DB $0F, $61, $E4 /// PUNPCKLWD MM4, MM4 - DB $0F, $62, $E4 /// PUNPCKLDQ MM4, MM4 - -@1: // The pixel loop calculates an entire pixel in one run. - // Note: The pixel byte values are expanded into the higher bytes of a word due - // to the way unpacking works. We compensate for this with an extra shift. - DB $0F, $EF, $C0 /// PXOR MM0, MM0, clear source pixel register for unpacking - DB $0F, $60, $06 /// PUNPCKLBW MM0, [ESI], unpack source pixel byte values into words - DB $0F, $71, $D0, $08 /// PSRLW MM0, 8, move higher bytes to lower bytes - DB $0F, $EF, $C9 /// PXOR MM1, MM1, clear target pixel register for unpacking - DB $0F, $60, $0F /// PUNPCKLBW MM1, [EDI], unpack target pixel byte values into words - DB $0F, $6F, $D1 /// MOVQ MM2, MM1, make a copy of the shifted values, we need them again - DB $0F, $71, $D1, $08 /// PSRLW MM1, 8, move higher bytes to lower bytes - - // Load MM6 with the source alpha value (replicate it for every component). - // Expand it to word size. - DB $0F, $6F, $F0 /// MOVQ MM6, MM0 - DB $0F, $69, $F6 /// PUNPCKHWD MM6, MM6 - DB $0F, $6A, $F6 /// PUNPCKHDQ MM6, MM6 - - // calculation is: target = (alpha * (source - target) + 256 * target) / 256 - DB $0F, $F9, $C1 /// PSUBW MM0, MM1, source - target - DB $0F, $D5, $C6 /// PMULLW MM0, MM6, alpha * (source - target) - DB $0F, $FD, $C2 /// PADDW MM0, MM2, add target (in shifted form) - DB $0F, $71, $D0, $08 /// PSRLW MM0, 8, divide by 256 - - // Bias is accounted for by conversion of range 0..255 to -128..127, - // doing a saturated add and convert back to 0..255. - DB $0F, $F9, $C4 /// PSUBW MM0, MM4 - DB $0F, $ED, $C5 /// PADDSW MM0, MM5 - DB $0F, $FD, $C4 /// PADDW MM0, MM4 - DB $0F, $67, $C0 /// PACKUSWB MM0, MM0, convert words to bytes with saturation - DB $0F, $7E, $07 /// MOVD [EDI], MM0, store the result -@3: - ADD ESI, 4 - ADD EDI, 4 - DEC ECX - JNZ @1 - POP EDI - POP ESI -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure AlphaBlendLineMaster(Source, Destination: Pointer; Count: Integer; ConstantAlpha, Bias: Integer); - -// Blends a line of Count pixels from Source to Destination using the source pixel and a constant alpha value. -// The layout of a pixel must be BGRA. -// ConstantAlpha must be in the range 0..255. -// Bias is an additional value which gets added to every component and must be in the range -128..127 -// -// EAX contains Source -// EDX contains Destination -// ECX contains Count -// ConstantAlpha and Bias are on the stack - -asm - PUSH ESI // save used registers - PUSH EDI - - MOV ESI, EAX // ESI becomes the actual source pointer - MOV EDI, EDX // EDI becomes the actual target pointer - - // Load MM6 with the constant alpha value (replicate it for every component). - // Expand it to word size. - MOV EAX, [ConstantAlpha] - DB $0F, $6E, $F0 /// MOVD MM6, EAX - DB $0F, $61, $F6 /// PUNPCKLWD MM6, MM6 - DB $0F, $62, $F6 /// PUNPCKLDQ MM6, MM6 - - // Load MM5 with the bias value. - MOV EAX, [Bias] - DB $0F, $6E, $E8 /// MOVD MM5, EAX - DB $0F, $61, $ED /// PUNPCKLWD MM5, MM5 - DB $0F, $62, $ED /// PUNPCKLDQ MM5, MM5 - - // Load MM4 with 128 to allow for saturated biasing. - MOV EAX, 128 - DB $0F, $6E, $E0 /// MOVD MM4, EAX - DB $0F, $61, $E4 /// PUNPCKLWD MM4, MM4 - DB $0F, $62, $E4 /// PUNPCKLDQ MM4, MM4 - -@1: // The pixel loop calculates an entire pixel in one run. - // Note: The pixel byte values are expanded into the higher bytes of a word due - // to the way unpacking works. We compensate for this with an extra shift. - DB $0F, $EF, $C0 /// PXOR MM0, MM0, clear source pixel register for unpacking - DB $0F, $60, $06 /// PUNPCKLBW MM0, [ESI], unpack source pixel byte values into words - DB $0F, $71, $D0, $08 /// PSRLW MM0, 8, move higher bytes to lower bytes - DB $0F, $EF, $C9 /// PXOR MM1, MM1, clear target pixel register for unpacking - DB $0F, $60, $0F /// PUNPCKLBW MM1, [EDI], unpack target pixel byte values into words - DB $0F, $6F, $D1 /// MOVQ MM2, MM1, make a copy of the shifted values, we need them again - DB $0F, $71, $D1, $08 /// PSRLW MM1, 8, move higher bytes to lower bytes - - // Load MM7 with the source alpha value (replicate it for every component). - // Expand it to word size. - DB $0F, $6F, $F8 /// MOVQ MM7, MM0 - DB $0F, $69, $FF /// PUNPCKHWD MM7, MM7 - DB $0F, $6A, $FF /// PUNPCKHDQ MM7, MM7 - DB $0F, $D5, $FE /// PMULLW MM7, MM6, source alpha * master alpha - DB $0F, $71, $D7, $08 /// PSRLW MM7, 8, divide by 256 - - // calculation is: target = (alpha * master alpha * (source - target) + 256 * target) / 256 - DB $0F, $F9, $C1 /// PSUBW MM0, MM1, source - target - DB $0F, $D5, $C7 /// PMULLW MM0, MM7, alpha * (source - target) - DB $0F, $FD, $C2 /// PADDW MM0, MM2, add target (in shifted form) - DB $0F, $71, $D0, $08 /// PSRLW MM0, 8, divide by 256 - - // Bias is accounted for by conversion of range 0..255 to -128..127, - // doing a saturated add and convert back to 0..255. - DB $0F, $F9, $C4 /// PSUBW MM0, MM4 - DB $0F, $ED, $C5 /// PADDSW MM0, MM5 - DB $0F, $FD, $C4 /// PADDW MM0, MM4 - DB $0F, $67, $C0 /// PACKUSWB MM0, MM0, convert words to bytes with saturation - DB $0F, $7E, $07 /// MOVD [EDI], MM0, store the result -@3: - ADD ESI, 4 - ADD EDI, 4 - DEC ECX - JNZ @1 - POP EDI - POP ESI -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure AlphaBlendLineMasterAndColor(Destination: Pointer; Count: Integer; ConstantAlpha, Color: Integer); - -// Blends a line of Count pixels in Destination against the given color using a constant alpha value. -// The layout of a pixel must be BGRA and Color must be rrggbb00 (as stored by a COLORREF). -// ConstantAlpha must be in the range 0..255. -// -// EAX contains Destination -// EDX contains Count -// ECX contains ConstantAlpha -// Color is passed on the stack - -asm - // The used formula is: target = (alpha * color + (256 - alpha) * target) / 256. - // alpha * color (factor 1) and 256 - alpha (factor 2) are constant values which can be calculated in advance. - // The remaining calculation is therefore: target = (F1 + F2 * target) / 256 - - // Load MM3 with the constant alpha value (replicate it for every component). - // Expand it to word size. (Every calculation here works on word sized operands.) - DB $0F, $6E, $D9 /// MOVD MM3, ECX - DB $0F, $61, $DB /// PUNPCKLWD MM3, MM3 - DB $0F, $62, $DB /// PUNPCKLDQ MM3, MM3 - - // Calculate factor 2. - MOV ECX, $100 - DB $0F, $6E, $D1 /// MOVD MM2, ECX - DB $0F, $61, $D2 /// PUNPCKLWD MM2, MM2 - DB $0F, $62, $D2 /// PUNPCKLDQ MM2, MM2 - DB $0F, $F9, $D3 /// PSUBW MM2, MM3 // MM2 contains now: 255 - alpha = F2 - - // Now calculate factor 1. Alpha is still in MM3, but the r and b components of Color must be swapped. - MOV ECX, [Color] - BSWAP ECX - ROR ECX, 8 - DB $0F, $6E, $C9 /// MOVD MM1, ECX // Load the color and convert to word sized values. - DB $0F, $EF, $E4 /// PXOR MM4, MM4 - DB $0F, $60, $CC /// PUNPCKLBW MM1, MM4 - DB $0F, $D5, $CB /// PMULLW MM1, MM3 // MM1 contains now: color * alpha = F1 - -@1: // The pixel loop calculates an entire pixel in one run. - DB $0F, $6E, $00 /// MOVD MM0, [EAX] - DB $0F, $60, $C4 /// PUNPCKLBW MM0, MM4 - - DB $0F, $D5, $C2 /// PMULLW MM0, MM2 // calculate F1 + F2 * target - DB $0F, $FD, $C1 /// PADDW MM0, MM1 - DB $0F, $71, $D0, $08 /// PSRLW MM0, 8 // divide by 256 - - DB $0F, $67, $C0 /// PACKUSWB MM0, MM0 // convert words to bytes with saturation - DB $0F, $7E, $00 /// MOVD [EAX], MM0 // store the result - - ADD EAX, 4 - DEC EDX - JNZ @1 -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure EMMS; - -// Reset MMX state to use the FPU for other tasks again. - -asm - DB $0F, $77 /// EMMS -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function GetBitmapBitsFromDeviceContext(DC: HDC; var Width, Height: Integer): Pointer; - -// Helper function used to retrieve the bitmap selected into the given device context. If there is a bitmap then -// the function will return a pointer to its bits otherwise nil is returned. -// Additionally the dimensions of the bitmap are returned. - -var - Bitmap: HBITMAP; - DIB: TDIBSection; - -begin - Result := nil; - Width := 0; - Height := 0; - //todo_lcl - {$ifdef EnableAlphaBlend} - Bitmap := GetCurrentObject(DC, OBJ_BITMAP); - if Bitmap <> 0 then - begin - if GetObject(Bitmap, SizeOf(DIB), @DIB) = SizeOf(DIB) then - begin - Assert(DIB.dsBm.bmPlanes * DIB.dsBm.bmBitsPixel = 32, 'Alpha blending error: bitmap must use 32 bpp.'); - Result := DIB.dsBm.bmBits; - Width := DIB.dsBmih.biWidth; - Height := DIB.dsBmih.biHeight; - end; - end; - Assert(Result <> nil, 'Alpha blending DC error: no bitmap available.'); - {$endif} -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function CalculateScanline(Bits: Pointer; Width, Height, Row: Integer): Pointer; - -// Helper function to calculate the start address for the given row. - -begin - if Height > 0 then // bottom-up DIB - Row := Height - Row - 1; - // Return DWORD aligned address of the requested scanline. - Integer(Result) := Integer(Bits) + Row * ((Width * 32 + 31) and not 31) div 8; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure AlphaBlend(Source, Destination: HDC; R: TRect; Target: TPoint; Mode: TBlendMode; ConstantAlpha, Bias: Integer); - -// Optimized alpha blend procedure using MMX instructions to perform as quick as possible. -// For this procedure to work properly it is important that both source and target bitmap use the 32 bit color format. -// R describes the source rectangle to work on. -// Target is the place (upper left corner) in the target bitmap where to blend to. Note that source width + X offset -// must be less or equal to the target width. Similar for the height. -// If Mode is bmConstantAlpha then the blend operation uses the given ConstantAlpha value for all pixels. -// If Mode is bmPerPixelAlpha then each pixel is blended using its individual alpha value (the alpha value of the source). -// If Mode is bmMasterAlpha then each pixel is blended using its individual alpha value multiplied by ConstantAlpha. -// If Mode is bmConstantAlphaAndColor then each destination pixel is blended using ConstantAlpha but also a constant -// color which will be obtained from Bias. In this case no offset value is added, otherwise Bias is used as offset. -// Blending of a color into target only (bmConstantAlphaAndColor) ignores Source (the DC) and Target (the position). -// CAUTION: This procedure does not check whether MMX instructions are actually available! Call it only if MMX is really -// usable. - -var - Y: Integer; - SourceRun, - TargetRun: PByte; - - SourceBits, - DestBits: Pointer; - SourceWidth, - SourceHeight, - DestWidth, - DestHeight: Integer; - -begin - if not IsRectEmpty(R) then - begin - // Note: it is tempting to optimize the special cases for constant alpha 0 and 255 by just ignoring soure - // (alpha = 0) or simply do a blit (alpha = 255). But this does not take the bias into account. - case Mode of - bmConstantAlpha: - begin - // Get a pointer to the bitmap bits for the source and target device contexts. - // Note: this supposes that both contexts do actually have bitmaps assigned! - SourceBits := GetBitmapBitsFromDeviceContext(Source, SourceWidth, SourceHeight); - DestBits := GetBitmapBitsFromDeviceContext(Destination, DestWidth, DestHeight); - if Assigned(SourceBits) and Assigned(DestBits) then - begin - for Y := 0 to R.Bottom - R.Top - 1 do - begin - SourceRun := CalculateScanline(SourceBits, SourceWidth, SourceHeight, Y + R.Top); - Inc(SourceRun, 4 * R.Left); - TargetRun := CalculateScanline(DestBits, DestWidth, DestHeight, Y + Target.Y); - Inc(TargetRun, 4 * Target.X); - AlphaBlendLineConstant(SourceRun, TargetRun, R.Right - R.Left, ConstantAlpha, Bias); - end; - end; - EMMS; - end; - bmPerPixelAlpha: - begin - SourceBits := GetBitmapBitsFromDeviceContext(Source, SourceWidth, SourceHeight); - DestBits := GetBitmapBitsFromDeviceContext(Destination, DestWidth, DestHeight); - if Assigned(SourceBits) and Assigned(DestBits) then - begin - for Y := 0 to R.Bottom - R.Top - 1 do - begin - SourceRun := CalculateScanline(SourceBits, SourceWidth, SourceHeight, Y + R.Top); - Inc(SourceRun, 4 * R.Left); - TargetRun := CalculateScanline(DestBits, DestWidth, DestHeight, Y + Target.Y); - Inc(TargetRun, 4 * Target.X); - AlphaBlendLinePerPixel(SourceRun, TargetRun, R.Right - R.Left, Bias); - end; - end; - EMMS; - end; - bmMasterAlpha: - begin - SourceBits := GetBitmapBitsFromDeviceContext(Source, SourceWidth, SourceHeight); - DestBits := GetBitmapBitsFromDeviceContext(Destination, DestWidth, DestHeight); - if Assigned(SourceBits) and Assigned(DestBits) then - begin - for Y := 0 to R.Bottom - R.Top - 1 do - begin - SourceRun := CalculateScanline(SourceBits, SourceWidth, SourceHeight, Y + R.Top); - Inc(SourceRun, 4 * Target.X); - TargetRun := CalculateScanline(DestBits, DestWidth, DestHeight, Y + Target.Y); - AlphaBlendLineMaster(SourceRun, TargetRun, R.Right - R.Left, ConstantAlpha, Bias); - end; - end; - EMMS; - end; - bmConstantAlphaAndColor: - begin - // Source is ignored since there is a constant color value. - DestBits := GetBitmapBitsFromDeviceContext(Destination, DestWidth, DestHeight); - if Assigned(DestBits) then - begin - for Y := 0 to R.Bottom - R.Top - 1 do - begin - TargetRun := CalculateScanline(DestBits, DestWidth, DestHeight, Y + R.Top); - Inc(TargetRun, 4 * R.Left); - AlphaBlendLineMasterAndColor(TargetRun, R.Right - R.Left, ConstantAlpha, Bias); - end; - end; - EMMS; - end; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function GetRGBColor(Value: TColor): DWORD; - -// Little helper to convert a Delphi color to an image list color. - -begin - Result := ColorToRGB(Value); - case Result of - clNone: - Result := CLR_NONE; - clDefault: - Result := CLR_DEFAULT; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -const - Grays: array[0..3] of TColor = (clWhite, clSilver, clGray, clBlack); - SysGrays: array[0..3] of TColor = (clWindow, clBtnFace, clBtnShadow, clBtnText); -//todo_lcl_block - -procedure ConvertImageList(IL: TImageList; const ImageName: string; ColorRemapping: Boolean = True); - -// Loads a bunch of images given by ImageName into IL. If ColorRemapping = True then a mapping of gray values to -// system colors is performed. - -var - Images, - OneImage, - AnotherImage: TBitmap; - I: Integer; - MaskColor: TColor; - Source, - Dest: TRect; - //Small (???) hack while a solution does not come - Stream: TMemoryStream; -begin - Watcher.Enter; - try - // Since we want the image list appearing in the correct system colors, we have to remap its colors. - Images := TBitmap.Create; - //OneImage := TBitmap.Create; - //todo: remove this ugly hack ASAP - Stream:=TMemoryStream.Create; - //todo: see what CreateMappedRes do and replace it - { - if ColorRemapping then - Images.Handle := CreateMappedRes(FindClassHInstance(TBaseVirtualTree), PChar(ImageName), Grays, SysGrays) - else - Images.Handle := LoadBitmap(FindClassHInstance(TBaseVirtualTree), PChar(ImageName)); - } - Images.LoadFromLazarusResource(ImageName); - Logger.SendBitmap(lcCheck,ImageName,Images); - try - Assert(Images.Height > 0, 'Internal image "' + ImageName + '" is missing or corrupt.'); - - // It is assumed that the image height determines also the width of one entry in the image list. - IL.Clear; - IL.Height := Images.Height; - IL.Width := Images.Height; - //OneImage.Width := IL.Width; - //OneImage.Height := IL.Height; - - MaskColor := clFuchsia;//Images.Canvas.Pixels[0, 0]; // this is usually clFuchsia - Dest := Rect(0, 0, IL.Width, IL.Height); - for I := 0 to (Images.Width div Images.Height) - 1 do - begin - Source := Rect(I * IL.Width, 0, (I + 1) * IL.Width, IL.Height); - OneImage:= TBitmap.Create; - OneImage.Width:=IL.Height; - OneImage.Height:=IL.Width; - OneImage.Canvas.CopyRect(Dest, Images.Canvas, Source); - //somehow SaveToStream - LoadFromStream restores the tranparency lost in CopyRect - OneImage.SaveToStream(Stream); - OneImage.Free; - AnotherImage:=TBitmap.Create; - Stream.Position:=0; - AnotherImage.LoadFromStream(Stream); - Stream.Size:=0; - Logger.SendBitmap(lcCheck,'AnotherImage - '+IntToStr(i),AnotherImage); - IL.AddDirect(AnotherImage, nil); - end; - finally - Images.Free; - //OneImage.Free; - Stream.Free; - end; - Logger.Send(lcCheck,'IL.Count',IL.Count); - finally - Watcher.Leave; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure CreateSystemImageSet(var IL: TImageList; Flags: Cardinal; Flat: Boolean); - -// Creates a system check image set. -// Note: the DarkCheckImages and FlatImages image lists must already be filled, as some images from them are copied here. - -const - MaskColor: TColor = clRed; - -var - BM: TBitmap; - - //--------------- local functions ------------------------------------------- - - procedure AddNodeImages(IL: TImageList); - - var - I: Integer; - OffsetX, - OffsetY: Integer; - - begin - // The offsets are used to center the node images in case the sizes differ. - OffsetX := (IL.Width - DarkCheckImages.Width) div 2; - OffsetY := (IL.Height - DarkCheckImages.Height) div 2; - for I := 21 to 24 do - begin - BM.Canvas.Brush.Color := MaskColor; - BM.Canvas.FillRect(Rect(0, 0, BM.Width, BM.Height)); - if Flat then - FlatImages.Draw(BM.Canvas, OffsetX, OffsetY, I) - else - DarkCheckImages.Draw(BM.Canvas, OffsetX, OffsetY, I); - //IL.AddMasked(BM, MaskColor); - IL.AddCopy(BM,nil); - end; - end; - - //--------------------------------------------------------------------------- - - procedure AddSystemImage(IL: TImageList; Index: Integer); - - var - ButtonState: Cardinal; - ButtonType: Cardinal; - - begin - BM.Canvas.Brush.Color := MaskColor; - BM.Canvas.FillRect(Rect(0, 0, BM.Width, BM.Height)); - if Index < 8 then - ButtonType := DFCS_BUTTONRADIO - else - ButtonType := DFCS_BUTTONCHECK; - if Index >= 16 then - ButtonType := ButtonType or DFCS_BUTTON3STATE; - - case Index mod 4 of - 0: - ButtonState := 0; - 1: - ButtonState := DFCS_HOT; - 2: - ButtonState := DFCS_PUSHED; - else - ButtonState := DFCS_INACTIVE; - end; - if Index in [4..7, 12..19] then - ButtonState := ButtonState or DFCS_CHECKED; - if Flat then - ButtonState := ButtonState or DFCS_FLAT; - //todo: remap to LCLIntf - Windows.DrawFrameControl(BM.Canvas.Handle, Rect(1, 2, BM.Width - 2, BM.Height - 1), DFC_BUTTON, ButtonType or ButtonState); - IL.AddCopy(BM,nil); - //IL.AddMasked(BM, MaskColor); - end; - - //--------------- end local functions --------------------------------------- - -var - I, Width, Height: Integer; - -begin - Width := GetSystemMetrics(SM_CXMENUCHECK) + 3; - Height := GetSystemMetrics(SM_CYMENUCHECK) + 3; - IL := TImageList.CreateSize(Width, Height); - //with IL do - // Handle := ImageList_Create(Width, Height, Flags, 0, AllocBy); - IL.Masked := True; - //todo: see why compiler complain here - //IL.BkColor := clWhite; - - // Create a temporary bitmap, which holds the intermediate images. - BM := TBitmap.Create; - try - // Make the bitmap the same size as the image list is to avoid problems when adding. - BM.Width := IL.Width; - BM.Height := IL.Height; - BM.Canvas.Brush.Color := MaskColor; - BM.Canvas.Brush.Style := bsSolid; - BM.Canvas.FillRect(Rect(0, 0, BM.Width, BM.Height)); - //IL.AddMasked(BM, MaskColor); - IL.AddCopy(BM,nil); - - // Add the 20 system checkbox and radiobutton images. - for I := 0 to 19 do - AddSystemImage(IL, I); - // Add the 4 node images from the dark check set. - AddNodeImages(IL); - - finally - //todo: change to except?? - //lcl free the bitmap in IL - //BM.Free; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function HasMMX: Boolean; - -// Helper method to determine whether the current processor supports MMX. - -asm - PUSH EBX - XOR EAX, EAX // Result := False - PUSHFD // determine if the processor supports the CPUID command - POP EDX - MOV ECX, EDX - XOR EDX, $200000 - PUSH EDX - POPFD - PUSHFD - POP EDX - XOR ECX, EDX - JZ @1 // no CPUID support so we can't even get to the feature information - PUSH EDX - POPFD - - MOV EAX, 1 - DW $A20F // CPUID, EAX contains now version info and EDX feature information - MOV EBX, EAX // free EAX to get the result value - XOR EAX, EAX // Result := False - CMP EBX, $50 - JB @1 // if processor family is < 5 then it is not a Pentium class processor - TEST EDX, $800000 - JZ @1 // if the MMX bit is not set then we don't have MMX - INC EAX // Result := True -@1: - POP EBX -end; - -//---------------------------------------------------------------------------------------------------------------------- -{$ifdef EnablePrint} -procedure PrtStretchDrawDIB(Canvas: TCanvas; DestRect: TRect; ABitmap: TBitmap); - -// Stretch draw on to the new canvas. - -var - Header, - Bits: Pointer; - HeaderSize, - BitsSize: Cardinal; - -begin - GetDIBSizes(ABitmap.Handle, HeaderSize, BitsSize); - - GetMem(Header, HeaderSize); - GetMem(Bits, BitsSize); - try - GetDIB(ABitmap.Handle, ABitmap.Palette, Header^, Bits^); - StretchDIBits(Canvas.Handle, DestRect.Left, DestRect.Top, DestRect.Right - DestRect.Left, DestRect.Bottom - - DestRect.Top, 0, 0, ABitmap.Width, ABitmap.Height, Bits, TBitmapInfo(Header^), DIB_RGB_COLORS, SRCCOPY); - finally - FreeMem(Header); - FreeMem(Bits); - end; -end; -{$endif} -//---------------------------------------------------------------------------------------------------------------------- -{$ifdef EnableAccessible} -procedure GetAccessibilityFactory; - -// Accessibility helper function to create a singleton class that will create or return -// the IAccessible interface for the tree and the focused node. - -begin - // Check to see if the class has already been created. - if VTAccessibleFactory = nil then - VTAccessibleFactory := TVTAccessibilityFactory.Create; -end; -{$endif} -//---------------------------------------------------------------------------------------------------------------------- - -procedure InitializeGlobalStructures; - -// initialization of stuff global to the unit - -var - Flags: Cardinal; - -begin - Initialized := True; - - // For the drag image a fast MMX blend routine is used. We have to make sure MMX is available. - MMXAvailable := HasMMX; - - // There is a bug in Win95 and WinME (and potentially in Win98 too) regarding GetDCEx which causes sometimes - // serious trouble within GDI (see method WMNCPaint). - - //IsWinNT := (Win32Platform and VER_PLATFORM_WIN32_NT) <> 0; - IsWinNT:=True; - - {$ifdef EnableOLE} - // Initialize OLE subsystem for drag'n drop and clipboard operations. - //todo: replace by Suceeded (see in windows unit) - NeedToUnitialize := OleInitialize(nil) in [S_FALSE,S_OK]; - {$endif} - // Register the tree reference clipboard format. Others will be handled in InternalClipboarFormats. - CF_VTREFERENCE := ClipboardRegisterFormat(CFSTR_VTREFERENCE); - - // Load all internal image lists and convert their colors to current desktop color scheme. - // In order to use high color images we have to create the image list handle ourselves. - //todo_lcl_block - - if IsWinNT then - Flags := ILC_COLOR32 or ILC_MASK - else - Flags := ILC_COLOR16 or ILC_MASK; - LightCheckImages := TImageList.CreateSize(16,16); - //with LightCheckImages do - // Handle := ImageList_Create(16, 16, Flags, 0, AllocBy); - ConvertImageList(LightCheckImages, 'VT_CHECK_LIGHT'); - - DarkCheckImages := TImageList.CreateSize(16, 16); - //with DarkCheckImages do - // Handle := ImageList_Create(16, 16, Flags, 0, AllocBy); - ConvertImageList(DarkCheckImages, 'VT_CHECK_DARK'); - - LightTickImages := TImageList.CreateSize(16, 16); - //with LightTickImages do - // Handle := ImageList_Create(16, 16, Flags, 0, AllocBy); - ConvertImageList(LightTickImages, 'VT_TICK_LIGHT'); - - DarkTickImages := TImageList.CreateSize(16, 16); - //with DarkTickImages do - // Handle := ImageList_Create(16, 16, Flags, 0, AllocBy); - ConvertImageList(DarkTickImages, 'VT_TICK_DARK'); - - FlatImages := TImageList.CreateSize(16, 16); - //with FlatImages do - // Handle := ImageList_Create(16, 16, Flags, 0, AllocBy); - ConvertImageList(FlatImages, 'VT_FLAT'); - - XPImages := TImageList.CreateSize(16, 16); - //with XPImages do - // Handle := ImageList_Create(16, 16, Flags, 0, AllocBy); - ConvertImageList(XPImages, 'VT_XP', False); - - UtilityImages := TImageList.CreateSize(UtilityImageSize, UtilityImageSize); - //with UtilityImages do - // Handle := ImageList_Create(UtilityImageSize, UtilityImageSize, Flags, 0, AllocBy); - ConvertImageList(UtilityImages, 'VT_UTILITIES'); - - CreateSystemImageSet(SystemCheckImages, Flags, False); - CreateSystemImageSet(SystemFlatCheckImages, Flags, True); - - // Specify an useful timer resolution for timeGetTime. - timeBeginPeriod(MinimumTimerInterval); - - // Delphi (at least version 6 and lower) does not provide a standard split cursor. - // Hence we have to load our own. - Screen.Cursors[crHeaderSplit] := LoadCursorFromLazarusResource('VT_HEADERSPLIT'); - - // 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 - // OLEFlushClipboard is used. Hence it is disabled until somebody finds a solution. - CF_VIRTUALTREE := RegisterVTClipboardFormat(CFSTR_VIRTUALTREE, TBaseVirtualTree, 50, TYMED_HGLOBAL {or TYMED_ISTREAM}); - // Specialized string tree formats. - CF_HTML := RegisterVTClipboardFormat(CFSTR_HTML, TCustomVirtualStringTree, 80); - CF_VRTFNOOBJS := RegisterVTClipboardFormat(CFSTR_RTFNOOBJS, TCustomVirtualStringTree, 84); - CF_VRTF := RegisterVTClipboardFormat(CFSTR_RTF, TCustomVirtualStringTree, 85); - CF_CSV := RegisterVTClipboardFormat(CFSTR_CSV, TCustomVirtualStringTree, 90); - // Predefined clipboard formats. Just add them to the internal list. - RegisterVTClipboardFormat(CF_TEXT, TCustomVirtualStringTree, 100); - RegisterVTClipboardFormat(CF_UNICODETEXT, TCustomVirtualStringTree, 95); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure FinalizeGlobalStructures; - -var - HintWasEnabled: Boolean; - -begin - timeEndPeriod(MinimumTimerInterval); - - LightCheckImages.Free; - LightCheckImages := nil; - DarkCheckImages.Free; - DarkCheckImages := nil; - LightTickImages.Free; - LightTickImages := nil; - DarkTickImages.Free; - DarkTickImages := nil; - FlatImages.Free; - FlatImages := nil; - XPImages.Free; - XPImages := nil; - UtilityImages.Free; - UtilityImages := nil; - SystemCheckImages.Free; - SystemCheckImages := nil; - SystemFlatCheckImages.Free; - SystemFlatCheckImages := nil; - - if NeedToUnitialize then - OleUninitialize; - - // If VT is used in a package and its special hint window was used then the last instance of this - // window is not freed correctly (bug in the VCL). We explicitely tell the application to free it - // otherwise an AV is raised due to access to an invalid memory area. - //todo_lcl_remove - { - if ModuleIsPackage then - begin - HintWasEnabled := Application.ShowHint; - Application.ShowHint := False; - if HintWasEnabled then - Application.ShowHint := True; - end; - } -end; - -//----------------- TCriticalSection ----------------------------------------------------------------------------------- - -constructor TVTCriticalSection.Create; - -begin - inherited Create; - //InitializeCriticalSection(FSection); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -destructor TVTCriticalSection.Destroy; - -begin - //DeleteCriticalSection(FSection); - - inherited Destroy; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTCriticalSection.Enter; - -begin - //EnterCriticalSection(FSection); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTCriticalSection.Leave; - -begin - //LeaveCriticalSection(FSection); -end; - -//----------------- TWorkerThread -------------------------------------------------------------------------------------- - -procedure AddThreadReference; - -begin - if WorkerThread = nil then - begin - // Create an event used to trigger our worker thread when something is to do. - WorkEvent := TEvent.Create(nil, False, False, ''); - if WorkEvent.Handle = 0 then - Raise Exception.Create('VirtualTreeView - Error creating TEvent instance'); - - // Create worker thread, initialize it and send it to its wait loop. - WorkerThread := TWorkerThread.Create(False); - end; - Inc(WorkerThread.FRefCount); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure ReleaseThreadReference(Tree: TBaseVirtualTree); - -begin - if Assigned(WorkerThread) then - begin - Dec(WorkerThread.FRefCount); - - // Make sure there is no reference remaining to the releasing tree. - Tree.InterruptValidation; - - if WorkerThread.FRefCount = 0 then - begin - with WorkerThread do - begin - Terminate; - WorkEvent.SetEvent; - - // The following work around is no longer necessary with Delphi 6 and up. - {$ifndef COMPILER_6_UP} - // There is a problem when the thread is freed in the exit code of a DLL. This can happen when a tree is - // destroyed on unload of a DLL (e.g. control panel applet). In this case only the main thread will get - // CPU time, other threads will never awake again. The VCL however waits for a thread when freeing it - // which will result in a deadlock (the WaitFor call does not return because the thread does not get CPU time). - // If a thread is however suspended then the VCL does not wait and all is fine. - if IsLibrary then - Suspend; - {$endif COMPILER_6_UP} - - WorkerThread.Free; - end; - WorkerThread := nil; - WorkEvent.Free; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -constructor TWorkerThread.Create(CreateSuspended: Boolean); - -begin - inherited Create(CreateSuspended); - FWaiterList := TThreadList.Create; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -destructor TWorkerThread.Destroy; - -begin - // First let the ancestor stop the thread before freeing our resources. - inherited; - - FWaiterList.Free; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TWorkerThread.ChangeTreeStates(EnterStates, LeaveStates: TChangeStates); - -begin - if Assigned(FCurrentTree) and (FCurrentTree.HandleAllocated) then - SendMessage(FCurrentTree.Handle, WM_CHANGESTATE, Integer(EnterStates), Integer(LeaveStates)); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TWorkerThread.Execute; - -// Does some background tasks, like validating tree caches. - -var - EnterStates, - LeaveStates: TChangeStates; - -begin - while not Terminated do - begin - WorkEvent.WaitFor(INFINITE); - if not Terminated then - begin - // Get the next waiting tree. - with FWaiterList.LockList do - try - if Count > 0 then - begin - FCurrentTree := Items[0]; - // Remove this tree from waiter list. - Delete(0); - // If there is yet another tree to work on then set the work event to keep looping. - if Count > 0 then - WorkEvent.SetEvent; - end - else - FCurrentTree := nil; - finally - FWaiterList.UnlockList; - end; - - // Something to do? - try - if Assigned(FCurrentTree) then - begin - ChangeTreeStates([csValidating], [csUseCache]); - EnterStates := []; - if not (tsStopValidation in FCurrentTree.FStates) and FCurrentTree.DoValidateCache then - EnterStates := [csUseCache]; - end; - finally - LeaveStates := [csValidating, csStopValidation]; - if csUseCache in EnterStates then - Include(LeaveStates, csValidationNeeded); - ChangeTreeStates(EnterStates, LeaveStates); - FCurrentTree := nil; - end; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TWorkerThread.AddTree(Tree: TBaseVirtualTree); - -begin - Assert(Assigned(Tree), 'Tree must not be nil.'); - - // Remove validation stop flag, just in case it is still set. - Tree.DoStateChange([], [tsStopValidation]); - with FWaiterList.LockList do - try - if IndexOf(Tree) = -1 then - Add(Tree); - finally - FWaiterList.UnlockList; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TWorkerThread.RemoveTree(Tree: TBaseVirtualTree); - -begin - Assert(Assigned(Tree), 'Tree must not be nil.'); - - with FWaiterList.LockList do - try - Remove(Tree); - finally - FWaiterList.UnlockList; - end; -end; - -//----------------- TBufferedString ------------------------------------------------------------------------------------ - -const - AllocIncrement = 4096; - -destructor TBufferedString.Destroy; - -begin - FreeMem(FStart); - inherited; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBufferedString.GetAsString: string; - -begin - SetString(Result, FStart, FPosition - FStart); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBufferedString.Add(const S: string); - -var - LastLen, - LastOffset, - Len: Integer; - -begin - Len := Length(S); - // Make room for the new string. - if FEnd - FPosition <= Len then - begin - // Keep last offset to restore it correctly in the case that FStart gets a new memory block assigned. - LastLen := FEnd - FStart; - LastOffset := FPosition - FStart; - ReallocMem(FStart, FEnd - FStart + AllocIncrement); - FPosition := FStart + LastOffset; - FEnd := FStart + LastLen + AllocIncrement; - end; - Move(PChar(S)^, FPosition^, Len); - Inc(FPosition, Len); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBufferedString.AddNewLine; - -var - LastLen, - LastOffset: Integer; - -begin - // Make room for the CR/LF characters. - if FEnd - FPosition <= 2 then - begin - // Keep last offset to restore it correctly in the case that FStart gets a new memory block assigned. - LastLen := FEnd - FStart; - LastOffset := FPosition - FStart; - ReallocMem(FStart, FEnd - FStart + AllocIncrement); - FPosition := FStart + LastOffset; - FEnd := FStart + LastLen + AllocIncrement; - end; - FPosition^ := #13; - Inc(FPosition); - FPosition^ := #10; - Inc(FPosition); -end; - -//----------------- TWideBufferedString -------------------------------------------------------------------------------- - -destructor TWideBufferedString.Destroy; - -begin - FreeMem(FStart); - inherited; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TWideBufferedString.GetAsString: WideString; - -begin - SetString(Result, FStart, FPosition - FStart); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TWideBufferedString.Add(const S: WideString); - -var - LastLen, - LastOffset, - Len: Integer; - -begin - Len := Length(S); - // Make room for the new string. - if FEnd - FPosition <= Len then - begin - // Keep last offset to restore it correctly in the case that FStart gets a new memory block assigned. - LastLen := FEnd - FStart; - LastOffset := FPosition - FStart; - ReallocMem(FStart, 2 * (FEnd - FStart + AllocIncrement)); - FPosition := FStart + LastOffset; - FEnd := FStart + LastLen + AllocIncrement; - end; - Move(PWideChar(S)^, FPosition^, 2 * Len); - Inc(FPosition, Len); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TWideBufferedString.AddNewLine; - -var - LastLen, - LastOffset: Integer; - -begin - // Make room for the CR/LF characters. - if FEnd - FPosition <= 4 then - begin - // Keep last offset to restore it correctly in the case that FStart gets a new memory block assigned. - LastLen := FEnd - FStart; - LastOffset := FPosition - FStart; - ReallocMem(FStart, 2 * (FEnd - FStart + AllocIncrement)); - FPosition := FStart + LastOffset; - FEnd := FStart + LastLen + AllocIncrement; - end; - FPosition^ := #13; - Inc(FPosition); - FPosition^ := #10; - Inc(FPosition); -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.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 not (csDesigning in ComponentState) then - begin - if toFullRepaintOnResize in (TobeSet + ToBeCleared) then - //todo_lcl_check - RecreateWnd(FOwner); - if toAcceptOLEDrop in ToBeSet then - RegisterDragDrop(Handle, DragManager as IDropTarget); - if toAcceptOLEDrop in ToBeCleared then - RevokeDragDrop(Handle); - end; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TCustomVirtualTreeOptions.SetPaintOptions(const Value: TVTPaintOptions); - -var - ToBeSet, - ToBeCleared: TVTPaintOptions; - -begin - if FPaintOptions <> Value then - begin - ToBeSet := Value - FPaintOptions; - ToBeCleared := FPaintOptions - Value; - FPaintOptions := Value; - with FOwner do - if not (csLoading in ComponentState) and HandleAllocated then - begin - {$ifdef ThemeSupport} - if toThemeAware in ToBeSet + ToBeCleared then - begin - if (toThemeAware in ToBeSet) and ThemeServices.ThemesEnabled then - DoStateChange([tsUseThemes]) - else - DoStateChange([], [tsUseThemes]); - PrepareBitmaps(True, False); - RedrawWindow(Handle, nil, 0, RDW_INVALIDATE or RDW_VALIDATE or RDW_FRAME); - end - else - {$endif ThemeSupport} - Invalidate; - 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; - -//---------------------------------------------------------------------------------------------------------------------- - -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; - -//----------------- TVTNodeMemoryManager ------------------------------------------------------------------------------- - -{$ifdef UseLocalMemoryManager} - - const - NodeMemoryGuard: PVirtualNode = PVirtualNode($FEEFEFFE); - - constructor TVTNodeMemoryManager.Create; - - begin - FBlockList := TList.Create; - end; - - //---------------------------------------------------------------------------------------------------------------------- - - destructor TVTNodeMemoryManager.Destroy; - - begin - Clear; - FBlockList.Free; - end; - - //---------------------------------------------------------------------------------------------------------------------- - - function TVTNodeMemoryManager.AllocNode(const Size: Cardinal): PVirtualNode; - - // Allocates memory for a node using the local memory manager. - - const - BlockSize = (16 * 1024); // Blocks larger than 16K offer no significant performance improvement. - - begin - if FAllocSize = 0 then - // Recalculate allocation size first time after a clear. - FAllocSize := (Size + 3) and not 3 // Force alignment on 32-bit boundaries. - else - // Allocation size cannot be increased unless Memory Manager is explicitly cleared. - Assert(Size <= FAllocSize, 'Node memory manager allocation size cannot be increased.'); - - if Assigned(FFreeSpace) then - begin - // Assign node from free-space chain. - Assert(FFreeSpace.NextSibling = NodeMemoryGuard, 'Memory overwrite in node memory manager free space chain.'); - Result := FFreeSpace; // Assign node - FFreeSpace := Result.PrevSibling; // Point to prev node in free-space chain - end - else - begin - if FBytesAvailable < FAllocSize then - begin - // Get another block from the Delphi memory manager. - GetMem(FNext, BlockSize); - FBytesAvailable := BlockSize; - FBlockList.Add(FNext); - end; - // Assign node from current block. - Result := FNext; - Inc(PChar(FNext), FAllocSize); - Dec(FBytesAvailable, FAllocSize); - end; - - // Clear the memory. - FillChar(Result^, FAllocSize, 0); - end; - - //---------------------------------------------------------------------------------------------------------------------- - - procedure TVTNodeMemoryManager.Clear; - - // Releases all memory held by the local memory manager. - - var - I: Integer; - - begin - for I := 0 to FBlockList.Count - 1 do - FreeMem(FBlockList[I]); - FBlockList.Clear; - FFreeSpace := nil; - FBytesAvailable := 0; - FAllocSize := 0; - end; - - //---------------------------------------------------------------------------------------------------------------------- - - procedure TVTNodeMemoryManager.FreeNode(const Node: PVirtualNode); - - // Frees node memory that was allocated using the local memory manager. - - begin - Node.PrevSibling := FFreeSpace; // Point to previous free node. - Node.NextSibling := NodeMemoryGuard; // Memory guard to detect overwrites. - FFreeSpace := Node; // Point Free chain pointer to me. - end; - -{$endif UseLocalMemoryManager} - -//---------------------------------------------------------------------------------------------------------------------- - -// 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 ------------------------------------------------------------------------------------- -{$ifdef EnableOLE} -constructor TEnumFormatEtc.Create(Tree: TBaseVirtualTree; 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: LongWord; out elt: FormatEtc; out pceltFetched: LongWord): HResult; - -var - CopyCount: LongWord; - -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; - //todo_lcl_check Delphi treats pceltFetched an PInteger. Implemented like in fpc.activex. What heappens with - // a C Program call with a NULL in pCeltFetcjed?? - pceltFetched := CopyCount; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TEnumFormatEtc.Reset: HResult; - -begin - FCurrentIndex := 0; - Result := S_OK; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TEnumFormatEtc.Skip(celt: LongWord): 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.FStates) 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(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: PChar; - -begin - {$ifdef NeedWindows} - 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; - {$endif} -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; 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.PunkForRelease := Pointer(DataObject); // Does not increase RefCount. - end; - TYMED_FILE: - begin - //todo_lcl_check - Len := Length(WideString(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.Pstm)._AddRef; - TYMED_ISTORAGE: - IUnknown(OutStgMedium.Pstg)._AddRef; - TYMED_GDI: - if not CopyInMedium then - // Don't generate a copy just use ourselves and the previously saved data. - OutStgMedium.PunkForRelease := 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.PunkForRelease := 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.PunkForRelease := 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.PunkForRelease) then - IUnknown(OutStgMedium.PunkForRelease)._AddRef; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTDataObject.DAdvise(const FormatEtc: TFormatEtc; advf: DWord; const advSink: IAdviseSink; - out dwConnection: DWord): 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: DWord): HResult; - -begin - if FAdviseHolder = nil then - Result := E_NOTIMPL - else - Result := FAdviseHolder.Unadvise(dwConnection); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTDataObject.EnumDAvise(Out enumAdvise : IEnumStatData):HResult; - -begin - if FAdviseHolder = nil then - Result := OLE_E_ADVISENOTSUPPORTED - else - Result := FAdviseHolder.EnumAdvise(enumAdvise); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTDataObject.EnumFormatEtc(Direction: DWord; 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.GetCanonicalFormatTEtc(const pformatetcIn : FORMATETC;Out pformatetcOut : FORMATETC):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 - {$ifdef NeedWindows} - // 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.FStates 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.PunkForRelease := 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 - FillChar(Medium, SizeOf(Medium), #0); - Result := E_FAIL; - end; - end; - {$endif} -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); - FillChar(LocalStgMedium^, SizeOf(LocalStgMedium^), #0); - 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; - FillChar(LocalStgMedium^, SizeOf(LocalStgMedium^), #0); - 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.PunkForRelease) then - begin - if CanonicalIUnknown(Self) = CanonicalIUnknown(IUnknown(LocalStgMedium.PunkForRelease)) then - IUnknown(LocalStgMedium.PunkForRelease) := 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. - Pointer(FOwner.FDragManager) := nil; - 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 then - 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: LongWord; Pt: TPoint; - var Effect: LongWord): HResult; - -begin - {$ifdef NeedWindows} - 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 - FDropTargetHelper.DragEnter(FOwner.Handle, DataObject, Pt, Effect); - - FDragSource := FOwner.GetTreeFromDataObject(DataObject); - Result := FOwner.DragEnter(KeyState, Pt, Effect); - {$endif} -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: LongWord; Pt: TPoint; var Effect: LongWord): 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: LongWord; Pt: TPoint; - var Effect: LongWord): 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; - -{$endif} //EnableOLE -//----------------- TVirtualTreeHintWindow ----------------------------------------------------------------------------- - -var - // This variable is necessary to coordinate the complex interaction between different hints in the application - // and animated hints in our own class. Under certain conditions it can happen that our hint window is destroyed - // while it is still in the animation loop. - HintWindowDestroyed: Boolean = True; - -constructor TVirtualTreeHintWindow.Create(AOwner: TComponent); - -begin - inherited; - - FBackground := TBitmap.Create; - FBackground.PixelFormat := pf32Bit; - FDrawBuffer := TBitmap.Create; - FDrawBuffer.PixelFormat := pf32Bit; - FTarget := TBitmap.Create; - FTarget.PixelFormat := pf32Bit; - - DoubleBuffered := False; // we do our own buffering - HintWindowDestroyed := False; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -destructor TVirtualTreeHintWindow.Destroy; - -begin - HintWindowDestroyed := True; - - FTarget.Free; - FDrawBuffer.Free; - FBackground.Free; - inherited; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVirtualTreeHintWindow.AnimationCallback(Step, StepSize: Integer; Data: Pointer): Boolean; - -begin - Result := not HintWindowDestroyed and HandleAllocated and IsWindowVisible(Handle) and - not (tsCancelHintAnimation in FHintData.Tree.FStates); - if Result then - begin - InternalPaint(Step, StepSize); - // We have to allow certain messages to be processed normally for various reasons. - // This introduces another problem however if this hint window is destroyed - // while it is still in the animation loop. A global variable keeps track of - // that case. This is reliable because we can only have one (internal) hint window. - Application.ProcessMessages; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeHintWindow.InternalPaint(Step, StepSize: Integer); - - //--------------- local functions ------------------------------------------- - - procedure DoShadowBlend(DC: HDC; R: TRect; Alpha: Integer); - - // Helper routine for shadow blending to shorten the parameter list in frequent calls. - - begin - AlphaBlend(0, DC, R, Point(0, 0), bmConstantAlphaAndColor, Alpha, clBlack); - end; - - //--------------------------------------------------------------------------- - - procedure DrawHintShadow(Canvas: TCanvas; ShadowSize: Integer); - - var - R: TRect; - - begin - // Bottom shadow. - R := Rect(ShadowSize, Height - ShadowSize, Width, Height); - DoShadowBlend(Canvas.Handle, R, 5); - Inc(R.Left); - Dec(R.Right); - Dec(R.Bottom); - DoShadowBlend(Canvas.Handle, R, 10); - Inc(R.Left); - Dec(R.Right); - Dec(R.Bottom); - DoShadowBlend(Canvas.Handle, R, 20); - Inc(R.Left); - Dec(R.Right); - Dec(R.Bottom); - DoShadowBlend(Canvas.Handle, R, 35); - Inc(R.Left); - Dec(R.Right); - Dec(R.Bottom); - DoShadowBlend(Canvas.Handle, R, 50); - // Right shadow. - R := Rect(Width - ShadowSize, ShadowSize, Width, Height - ShadowSize); - DoShadowBlend(Canvas.Handle, R, 5); - Inc(R.Top); - Dec(R.Right); - DoShadowBlend(Canvas.Handle, R, 10); - Inc(R.Top); - Dec(R.Right); - DoShadowBlend(Canvas.Handle, R, 20); - Inc(R.Top); - Dec(R.Right); - DoShadowBlend(Canvas.Handle, R, 35); - Inc(R.Top); - Dec(R.Right); - DoShadowBlend(Canvas.Handle, R, 50); - end; - - //--------------- end local functions --------------------------------------- - -var - R: TRect; - Y: Integer; - S: WideString; - DrawFormat: Cardinal; - Shadow: Integer; - -begin - {$ifndef COMPILER_7_UP} - if MMXAvailable then - Shadow := ShadowSize - else - {$endif COMPILER_7_UP} - Shadow := 0; - - with FHintData, FDrawBuffer do - begin - // Do actual painting only in the very first run. - if Step = 0 then - begin - // If the given node is nil then we have to display a header hint. - if (Node = nil) or (Tree.FHintMode <> hmToolTip) then - begin - Canvas.Font := Screen.HintFont; - Y := 2; - end - else - begin - Tree.GetTextInfo(Node, Column, Canvas.Font, R, S); - if LineBreakStyle = hlbForceMultiLine then - Y := 1 - else - Y := (R.Top - R.Bottom - Shadow + Self.Height) div 2; - end; - - with ClientRect do - R := Rect(0, 0, Width - Shadow, Height - Shadow); - - if (Tree is TCustomVirtualDrawTree) and Assigned(Node) then - begin - // The draw tree has by default no hint text so let it draw the hint itself. - (Tree as TCustomVirtualDrawTree).DoDrawHint(Canvas, Node, R, Column); - end - else - with Canvas do - begin - // Still force tooltip back and text color. - Font.Color := clInfoText; - Pen.Color := clBlack; - Brush.Color := clInfoBk; - {$ifdef COMPILER_5_UP} - Rectangle(R); - {$else} - with R do - Rectangle(Left, Top, Right, Bottom); - {$endif COMPILER_5_UP} - - // Determine text position and don't forget the border. - InflateRect(R, -1, -1); - - DrawFormat := DT_TOP or DT_NOPREFIX; - if BidiMode <> bdLeftToRight then - begin - DrawFormat := DrawFormat or DT_RIGHT or DT_RTLREADING; - Dec(R.Right, Tree.FTextMargin); - Inc(R.Right); - end - else - begin - DrawFormat := DrawFormat or DT_LEFT; - Inc(R.Left, Tree.FTextMargin); - end; - SetBkMode(Handle, LCLType.TRANSPARENT); - R.Top := Y; - if Assigned(Node) and (LineBreakStyle = hlbForceMultiLine) then - DrawFormat := DrawFormat or DT_WORDBREAK; - if IsWinNT then - Windows.DrawTextW(Handle, PWideChar(HintText), Length(HintText), R, DrawFormat) - else - DrawTextW(Handle, PWideChar(HintText), Length(HintText), R, DrawFormat, False); - end; - end; - end; - - if StepSize > 0 then - begin - if FHintData.Tree.DoGetAnimationType = hatFade then - begin - with FTarget do - BitBlt(Canvas.Handle, 0, 0, Width, Height, FBackground.Canvas.Handle, 0, 0, SRCCOPY); - // Main image. - AlphaBlend(FDrawBuffer.Canvas.Handle, FTarget.Canvas.Handle, Rect(0, 0, Width - Shadow, Height - Shadow), - Point(0, 0), bmConstantAlpha, MulDiv(Step, 256, FadeAnimationStepCount), 0); - - if Shadow > 0 then - DrawHintShadow(FTarget.Canvas, Shadow); - BitBlt(Canvas.Handle, 0, 0, Width, Height, FTarget.Canvas.Handle, 0, 0, SRCCOPY); - end - else - begin - // Slide is done by blitting "step" lines of the lower part of the hint window - // and fill the rest with the screen background. - - // 1) blit hint bitmap to the hint canvas - BitBlt(Canvas.Handle, 0, 0, Width - Shadow, Step, FDrawBuffer.Canvas.Handle, 0, Height - Step, SRCCOPY); - // 2) blit background rest to hint canvas - if Step <= Shadow then - Step := 0 - else - Dec(Step, Shadow); - BitBlt(Canvas.Handle, 0, Step, Width, Height - Step, FBackground.Canvas.Handle, 0, Step, SRCCOPY); - end; - end - else - // Last step during slide or the only step without animation. - if FHintData.Tree.DoGetAnimationType <> hatFade then - begin - if Shadow > 0 then - begin - with FBackground do - BitBlt(Canvas.Handle, 0, 0, Width - Shadow, Height - Shadow, FDrawBuffer.Canvas.Handle, 0, 0, SRCCOPY); - - DrawHintShadow(FBackground.Canvas, Shadow); - BitBlt(Canvas.Handle, 0, 0, Width, Height, FBackground.Canvas.Handle, 0, 0, SRCCOPY); - end - else - BitBlt(Canvas.Handle, 0, 0, Width, Height, FDrawBuffer.Canvas.Handle, 0, 0, SRCCOPY); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeHintWindow.CMTextChanged(var Message: TLMessage); - -begin - // swallow this message to prevent the ancestor from resizing the window (we don't use the caption anyway) -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeHintWindow.WMEraseBkgnd(var Message: TLMEraseBkgnd); - -// The control is fully painted by own code so don't erase its background as this causes flickering. - -begin - Message.Result := 1; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeHintWindow.WMNCPaint(var Message: TLMessage); - -// The control is fully painted by own code so don't paint any borders. - -begin - Message.Result := 0; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeHintWindow.WMShowWindow(var Message: TLMShowWindow); - -// Clear hint data when the window becomes hidden. - -begin - if not Message.Show then - begin - // Don't touch the last hint rectangle stored in the associated tree to avoid flickering in certain situations. - Finalize(FHintData); - FillChar(FHintData, SizeOf(FHintData), 0); - - // If the hint window destruction flag to stop any hint window animation was set by a tree - // during its destruction then reset it here to allow other tree instances to still use - // this hint window. - HintWindowDestroyed := False; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeHintWindow.CreateParams(var Params: TCreateParams); - -begin - inherited CreateParams(Params); - - with Params do - begin - Style := WS_POPUP; - ExStyle := ExStyle and not WS_EX_CLIENTEDGE; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeHintWindow.Paint; - -begin - InternalPaint(0, 0); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeHintWindow.ActivateHint(Rect: TRect; const AHint: string); - -var - DC: HDC; - StopLastAnimation: Boolean; - -begin - if IsRectEmpty(Rect) then - Application.CancelHint - else - begin - // There is already an animation. Start a new one but do not continue the old one once we are finished here. - StopLastAnimation := (tsInAnimation in FHintData.Tree.FStates); - if StopLastAnimation then - FHintData.Tree.DoStateChange([], [tsInAnimation]); - - SetWindowPos(Handle, 0, Rect.Left, Rect.Top, Width, Height, SWP_HIDEWINDOW or SWP_NOACTIVATE or SWP_NOZORDER); - //todo_lcl_check - BoundsRect:=Rect; - - - // Make sure the whole hint is visible on the monitor. Don't forget multi-monitor systems with the - // primary monitor not being at the top-left corner. - //todo_lcl - { - if Rect.Top - Screen.DesktopTop + Height > Screen.DesktopHeight then - Rect.Top := Screen.DesktopHeight - Height + Screen.DesktopTop; - if Rect.Left - Screen.DesktopLeft + Width > Screen.DesktopWidth then - Rect.Left := Screen.DesktopWidth - Width + Screen.DesktopLeft; - if Rect.Bottom - Screen.DesktopTop < Screen.DesktopTop then - Rect.Bottom := Screen.DesktopTop + Screen.DesktopTop; - if Rect.Left - Screen.DesktopLeft < Screen.DesktopLeft then - Rect.Left := Screen.DesktopLeft + Screen.DesktopLeft; - } - // adjust sizes of bitmaps - FDrawBuffer.Width := Width; - FDrawBuffer.Height := Height; - FBackground.Width := Width; - FBackground.Height := Height; - FTarget.Width := Width; - FTarget.Height := Height; - - FHintData.Tree.Update; - - // capture screen - DC := GetDC(0); - try - with Rect do - BitBlt(FBackground.Canvas.Handle, 0, 0, Width, Height, DC, Left, Top, SRCCOPY); - finally - ReleaseDC(0, DC); - end; - - SetWindowPos(Handle, HWND_TOPMOST, Rect.Left, Rect.Top, Width, Height, SWP_SHOWWINDOW or SWP_NOACTIVATE); - with FHintData.Tree do - case DoGetAnimationType of - hatNone: - InvalidateRect(Self.Handle, nil, False); - hatFade: - begin - // Make sure the window is not drawn unanimated. - //ValidateRect(Self.Handle, nil); - // Empirically determined animation duration shows that fading needs about twice as much time as - // sliding to show a comparable visual effect. - Animate(FadeAnimationStepCount, 2 * FAnimationDuration, AnimationCallback, nil); - end; - hatSlide: - begin - // Make sure the window is not drawn unanimated. - //ValidateRect(Self.Handle, nil); - Animate(Self.Height, FAnimationDuration, AnimationCallback, nil); - end; - end; - if not HintWindowDestroyed and StopLastAnimation and Assigned(FHintData.Tree) then - FHintData.Tree.DoStateChange([tsCancelHintAnimation]); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVirtualTreeHintWindow.CalcHintRect(MaxWidth: Integer; const AHint: string; AData: Pointer): TRect; - -var - TM: TTextMetric; - R: TRect; - -begin - if AData = nil then - // Defensive approach, it *can* happen that AData is nil. Maybe when several user defined hint classes are used. - Result := Rect(0, 0, 0, 0) - else - begin - // The hint window does not need any bidi mode setting but the caller of this method (TApplication.ActivateHint) - // does some unneccessary actions if the hint window is not left-to-right. - // The text alignment is based on the bidi mode passed in the hint data, hence we can - // simply set the window's mode to left-to-right (it might have been modified by the caller, if the - // tree window is right-to-left aligned). - BidiMode := bdLeftToRight; - - FHintData := PVTHintData(AData)^; - - with FHintData do - begin - // The draw tree gets its hint size by the application (but only if not a header hint is about to show). - // This size has already been determined in CMHintShow. - if (Tree is TCustomVirtualDrawTree) and Assigned(Node) then - Result := HintRect - else - begin - if Column <= NoColumn then - begin - BidiMode := Tree.BidiMode; - Alignment := Tree.Alignment; - end - else - begin - BidiMode := Tree.Header.Columns[Column].BidiMode; - Alignment := Tree.Header.Columns[Column].Alignment; - end; - - if BidiMode <> bdLeftToRight then - ChangeBidiModeAlignment(Alignment); - - if (Node = nil) or (Tree.FHintMode <> hmToolTip) then - begin - Canvas.Font := Screen.HintFont; - end - else - begin - Canvas.Font := Tree.Font; - if Tree is TCustomVirtualStringTree then - with TCustomVirtualStringTree(Tree) do - DoPaintText(Node, Self.Canvas, Column, ttNormal); - end; - - GetTextMetrics(Canvas.Handle, TM); - FTextHeight := TM.tmHeight; - LineBreakStyle := hlbDefault; - - if Length(DefaultHint) > 0 then - HintText := DefaultHint - else - if Tree.HintMode = hmToolTip then - HintText := Tree.DoGetNodeToolTip(Node, Column, LineBreakStyle) - else - HintText := Tree.DoGetNodeHint(Node, Column, LineBreakStyle); - - if Length(HintText) = 0 then - Result := Rect(0, 0, 0, 0) - else - begin - if Assigned(Node) and (Tree.FHintMode = hmToolTip) then - 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 then - LineBreakStyle := hlbForceMultiLine - else - LineBreakStyle := hlbForceSingleLine; - - // Hint for a node. - if LineBreakStyle = hlbForceMultiLine then - begin - // Multiline tooltips use the columns width but extend the bottom border to fit the whole caption. - Result := Tree.GetDisplayRect(Node, Column, True, False); - R := Result; - - // On Windows NT/2K/XP the behavior of the tooltip is slightly different to that on Windows 9x/Me. - // We don't have Unicode word wrap on the latter so the tooltip gets as wide as the largest line - // in the caption (limited by carriage return), which results in unoptimal overlay of the tooltip. - // On Windows NT the tooltip exactly overlays the node text. - if IsWinNT then - Windows.DrawTextW(Canvas.Handle, PWideChar(HintText), Length(HintText), R, DT_CALCRECT or DT_WORDBREAK) - else - DrawTextW(Canvas.Handle, PWideChar(HintText), Length(HintText), R, DT_CALCRECT, True); - if BidiMode = bdLeftToRight then - Result.Right := R.Right + Tree.FTextMargin - else - Result.Left := R.Left - Tree.FTextMargin + 1; - Result.Bottom := R.Bottom; - - Inc(Result.Right); - - // If the node height is already large enough to cover the entire text, then we don't need the hint, though. - // However if the text is partially scrolled out of the client area then a hint is useful as well. - if ((Integer(Tree.NodeHeight[Node]) + 2) >= (Result.Bottom - Result.Top)) and not - ((Result.Left < 0) or (Result.Right > Tree.ClientWidth + 3) or - (Result.Top < 0) or (Result.Bottom > Tree.ClientHeight + 3)) then - begin - Result := Rect(0, 0, 0, 0); - Exit; - end; - end - else - begin - Result := Tree.GetDisplayRect(Node, Column, True, True); - if toShowHorzGridLines in Tree.TreeOptions.PaintOptions then - Dec(Result.Bottom); - end; - - // Include a one pixel border. - InflateRect(Result, 1, 1); - - // Make the coordinates relative. They will again be offset by the caller code. - OffsetRect(Result, -Result.Left - 1, -Result.Top - 1); - end - else - begin - // Hint for a header or non-tooltip hint. - - // Start with the base size of the hint in client coordinates. - Result := Rect(0, 0, MaxWidth, FTextHeight); - // Calculate the true size of the text rectangle. - if IsWinNT then - Windows.DrawTextW(Canvas.Handle, PWideChar(HintText), Length(HintText), Result, DT_CALCRECT) - else - DrawTextW(Canvas.Handle, PWideChar(HintText), Length(HintText), Result, DT_CALCRECT, True); - // The height of the text plus 2 pixels vertical margin plus the border determine the hint window height. - Inc(Result.Bottom, 6); - // The text is centered horizontally with usual text margin for left and right borders (plus border). - Inc(Result.Right, 2 * Tree.FTextMargin + 2); - end; - - {$ifndef COMPILER_7_UP} - // Add some pixels for the shadow if MMX is available for blending. - if MMXAvailable then - begin - Inc(Result.Right, ShadowSize); - Inc(Result.Bottom, ShadowSize); - end; - {$endif COMPILER_7_UP} - end; - end; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVirtualTreeHintWindow.IsHintMsg(var Msg: TMsg): Boolean; - -// The VCL is a bit too generous when telling that an existing hint can be cancelled. Need to specify further here. - -begin - Result:=False; - //todo_lcl: implement this in LCL - { - Result := inherited IsHintMsg(Msg) and HandleAllocated and IsWindowVisible(Handle); - // Avoid that mouse moves over the non-client area or key presses cancel the current hint. - if Result and ((Msg.Message = WM_NCMOUSEMOVE) or ((Msg.Message >= WM_KEYFIRST) and (Msg.Message <= WM_KEYLAST))) then - Result := False - else - // Work around problems with keypresses while doing hint animation. - if HandleAllocated and IsWindowVisible(Handle) and (Msg.Message >= WM_KEYFIRST) and (Msg.Message <= WM_KEYLAST) and - (tsInAnimation in FHintData.Tree.FStates) and TranslateMessage(Msg) then - DispatchMessage(Msg); - } -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 - {$ifdef EnableAdvancedGraphics} - 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; - {$endif} -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 - {$ifdef NeedWindows} - // 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 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 RDraw1 do - BitBlt(ScreenDC, FImagePosition.X + Left, FImagePosition.Y + Top, Right, Bottom, Handle, Left, Top, - SRCCOPY); - end - else - begin - with RDraw1 do - BitBlt(ScreenDC, FImagePosition.X + Left, FImagePosition.Y + Top, Right, Bottom, Handle, Left, Top, - SRCCOPY); - with 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 RSamp2 do - BitBlt(Handle, Left, Top, Right, Bottom, ScreenDC, FImagePosition.X + Left, FImagePosition.Y + Top, - SRCCOPY); - end - else - if DeltaY = 0 then - begin - with RSamp1 do - BitBlt(Handle, Left, Top, Right, Bottom, ScreenDC, FImagePosition.X + Left, FImagePosition.Y + Top, - SRCCOPY); - end - else - begin - with RSamp1 do - BitBlt(Handle, Left, Top, Right, Bottom, ScreenDC, FImagePosition.X + Left, FImagePosition.Y + Top, - SRCCOPY); - with 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; - {$endif} -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; - -begin - {$ifdef NeedWindows} - 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, - IID_IDragSourceHelper, DragSourceHelper)) then - begin - Include(FStates, disSystemSupport); - - // 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.ColorRef := ColorToRGB(FColorKey); - if not Succeeded(DragSourceHelper.InitializeFromBitmap(DragInfo, DataObject)) then - begin - DeleteObject(DragInfo.hbmpDragImage); - Exclude(FStates, disSystemSupport); - end; - end - else - Exclude(FStates, disSystemSupport); - - if MMXAvailable and not (disSystemSupport in FStates) then - begin - FLastPosition := HotSpot; - - FDragImage := TBitmap.Create; - FDragImage.PixelFormat := pf32Bit; - FDragImage.Width := Width; - FDragImage.Height := Height; - - FAlphaImage := TBitmap.Create; - FAlphaImage.PixelFormat := pf32Bit; - FAlphaImage.Width := Width; - FAlphaImage.Height := Height; - - FBackImage := TBitmap.Create; - FBackImage.PixelFormat := pf32Bit; - FBackImage.Width := Width; - FBackImage.Height := 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; - {$endif} -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 - {$ifdef NeedWindows} - // 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.TopLeft, 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.TopLeft, 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; - Tree.LimitPaintingToArea(Canvas, ClipRect, VisibleRegion); - Tree.PaintTree(Canvas, R, PaintTarget, PaintOptions); - - if CaptureNCArea then - begin - // 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); - SetWindowOrgEx(Canvas.Handle, DragRect.Left - ClipRect.Left, DragRect.Top - ClipRect.Top, nil); - Tree.Perform(WM_PRINT, Integer(Canvas.Handle), PRF_NONCLIENT); - SetWindowOrgEx(Canvas.Handle, 0, 0, nil); - end; - SelectClipRgn(Canvas.Handle, 0); - - if ReshowDragImage then - begin - GDIFlush; - ScreenDC := GetDC(0); - try - InternalShowDragImage(ScreenDC); - finally - ReleaseDC(0, ScreenDC); - end; - end; - end; - end; - {$endif} -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 - {$ifdef NeedWindows} - 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; - {$endif} -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. - -var - DeltaX, - DeltaY: Integer; - -begin - Result := Visible; - if Result then - 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); - end; -end; - -//----------------- TVirtualTreeColumn --------------------------------------------------------------------------------- - -constructor TVirtualTreeColumn.Create(Collection: TCollection); - -begin - FWidth := 50; - FLastWidth := 50; - FMinWidth := 10; - FMaxWidth := 10000; - FImageIndex := -1; - FMargin := 4; - FSpacing := 4; - FText := ''; - FOptions := DefaultColumnOptions; - FAlignment := taLeftJustify; - FBidiMode := bdLeftToRight; - FColor := clWindow; - FLayout := blGlyphLeft; - - inherited Create(Collection); - - FPosition := Owner.Count - 1; - // 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 - 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.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.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.SetColor(const Value: TColor); - -begin - if FColor <> Value then - begin - FColor := Value; - Exclude(FOptions, coParentColor); - Changed(False); - Owner.Header.TreeView.Invalidate; - 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; - if not IsWinNT and (Value > 10000) then - Value := 10000; - 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; - AVisibleChanged, - ColorChanged: Boolean; - -begin - if FOptions <> Value then - begin - ToBeCleared := FOptions - Value; - ToBeSet := Value - FOptions; - - FOptions := Value; - - AVisibleChanged := coVisible in (ToBeSet + ToBeCleared); - ColorChanged := coParentColor in ToBeSet; - - if coParentBidiMode in ToBeSet then - ParentBiDiModeChanged; - if ColorChanged then - ParentColorChanged; - - if coAutoSpring in ToBeSet then - FSpringRest := 0; - - Changed(False); - // Need to repaint and adjust the owner tree too. - - //lcl: fpc refuses to compile the original code by no aparent reason. - //Found: Was confounding TControl.VisibleChanged - with Owner, Header.Treeview do - if not (csLoading in ComponentState) and (AVisibleChanged or ColorChanged) and (UpdateCount = 0) and - HandleAllocated then - begin - Invalidate; - if AVisibleChanged then - UpdateHorizontalScrollBar(False); - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumn.SetPosition(Value: TColumnPosition); - -var - Temp: TColumnIndex; - -begin - if csLoading in Owner.Header.Treeview.ComponentState 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: WideString); - -begin - if FText <> Value then - begin - FText := Value; - Changed(False); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumn.SetWidth(Value: Integer); - -begin - if Value < FMinWidth then - Value := FMinWidth; - if Value > FMaxWidth then - Value := FMaxWidth; - - if FWidth <> Value then - begin - FLastWidth := FWidth; - with Owner, Header do - begin - if not (hoAutoResize in FOptions) or (Index <> FAutoSizeIndex) then - begin - FWidth := Value; - UpdatePositions; - end; - if not (csLoading in Treeview.ComponentState) and (UpdateCount = 0) then - begin - if hoAutoResize in FOptions then - AdjustAutoSize(Index); - Treeview.DoColumnResize(Index); - end; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumn.ComputeHeaderLayout(DC: HDC; const Client: TRect; UseHeaderGlyph, UseSortGlyph: Boolean; - var HeaderGlyphPos, SortGlyphPos: TPoint; var TextBounds: TRect); - -// 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, - SortGlyphSize: TPoint; - CurrentAlignment: TAlignment; - MinLeft, - MaxRight, - TextSpacing: Integer; - UseText: Boolean; - -begin - UseText := Length(FText) > 0; - // If nothing is to show then don't waste time with useless preparation. - if not (UseText or UseHeaderGlyph or UseSortGlyph) then - Exit; - - CurrentAlignment := FAlignment; - if FBidiMode <> bdLeftToRight then - ChangeBiDiModeAlignment(CurrentAlignment); - - // Calculate sizes of the involved items. - ClientSize := Point(Client.Right - Client.Left, Client.Bottom - Client.Top); - with Owner, Header do - begin - if UseHeaderGlyph then - HeaderGlyphSize := Point(FImages.Width, FImages.Height) - else - HeaderGlyphSize := Point(0, 0); - if UseSortGlyph then - begin - SortGlyphSize := Point(UtilityImages.Width, UtilityImages.Height); - // In any case, the sort glyph is vertically centered. - SortGlyphPos.Y := (ClientSize.Y - SortGlyphSize.Y) div 2; - end - else - SortGlyphSize := Point(0, 0); - end; - - if UseText then - begin - GetTextExtentPoint32W(DC, PWideChar(FText), Length(FText), TextSize); - Inc(TextSize.cx, 2); - TextBounds := Rect(0, 0, TextSize.cx, TextSize.cy); - 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 UseSortGlyph and not (UseText or UseHeaderGlyph) then - begin - // Center the sort glyph in the available area if nothing else is there. - SortGlyphPos := Point((ClientSize.X - SortGlyphSize.X) div 2, (ClientSize.Y - SortGlyphSize.Y) 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 UseHeaderGlyph then - begin - HeaderGlyphPos.Y := (ClientSize.Y - HeaderGlyphSize.Y) div 2; - TextPos.Y := (ClientSize.Y - TextSize.cy) div 2; - end - else - begin - if Layout = blGlyphTop then - begin - HeaderGlyphPos.Y := (ClientSize.Y - HeaderGlyphSize.Y - TextSize.cy - TextSpacing) div 2; - TextPos.Y := HeaderGlyphPos.Y + HeaderGlyphSize.Y + TextSpacing; - end - else - begin - TextPos.Y := (ClientSize.Y - HeaderGlyphSize.Y - TextSize.cy - TextSpacing) div 2; - HeaderGlyphPos.Y := TextPos.Y + TextSize.cy + TextSpacing; - end; - end; - - // Each alignment needs special consideration. - case CurrentAlignment of - taLeftJustify: - begin - MinLeft := FMargin; - if UseSortGlyph and (FBidiMode <> bdLeftToRight) then - begin - // In RTL context is the sort glyph placed on the left hand side. - SortGlyphPos.X := MinLeft; - Inc(MinLeft, SortGlyphSize.X + 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 UseHeaderGlyph then - begin - HeaderGlyphPos.X := (ClientSize.X - HeaderGlyphSize.X) div 2; - if HeaderGlyphPos.X < MinLeft then - HeaderGlyphPos.X := MinLeft; - MinLeft := Max(TextPos.X + TextSize.cx + TextSpacing, HeaderGlyphPos.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 UseHeaderGlyph and (Layout = blGlyphLeft) then - begin - HeaderGlyphPos.X := MinLeft; - Inc(MinLeft, HeaderGlyphSize.X + FSpacing); - end; - TextPos.X := MinLeft; - Inc(MinLeft, TextSize.cx + TextSpacing); - if UseHeaderGlyph and (Layout = blGlyphRight) then - begin - HeaderGlyphPos.X := MinLeft; - Inc(MinLeft, HeaderGlyphSize.X + FSpacing); - end; - end; - if UseSortGlyph and (FBidiMode = bdLeftToRight) then - SortGlyphPos.X := MinLeft; - end; - taCenter: - begin - if Layout in [blGlyphTop, blGlyphBottom] then - begin - HeaderGlyphPos.X := (ClientSize.X - HeaderGlyphSize.X) div 2; - TextPos.X := (ClientSize.X - TextSize.cx) div 2; - if UseSortGlyph then - Dec(TextPos.X, SortGlyphSize.X div 2); - end - else - begin - MinLeft := (ClientSize.X - HeaderGlyphSize.X - TextSpacing - TextSize.cx) div 2; - if UseHeaderGlyph and (Layout = blGlyphLeft) then - begin - HeaderGlyphPos.X := MinLeft; - Inc(MinLeft, HeaderGlyphSize.X + TextSpacing); - end; - TextPos.X := MinLeft; - Inc(MinLeft, TextSize.cx + TextSpacing); - if UseHeaderGlyph and (Layout = blGlyphRight) then - HeaderGlyphPos.X := MinLeft; - end; - if UseHeaderGlyph then - begin - MinLeft := Min(HeaderGlyphPos.X, TextPos.X); - MaxRight := Max(HeaderGlyphPos.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 UseSortGlyph then - if FBidiMode = bdLeftToRight then - begin - // Sort glyph on the right hand side. - SortGlyphPos.X := MaxRight + FSpacing; - end - else - begin - // Sort glyph on the left hand side. - SortGlyphPos.X := MinLeft - FSpacing - SortGlyphSize.X; - end; - end; - else - // taRightJustify - MaxRight := ClientSize.X - FMargin; - if UseSortGlyph and (FBidiMode = bdLeftToRight) then - begin - // In LTR context is the sort glyph placed on the right hand side. - Dec(MaxRight, SortGlyphSize.X); - SortGlyphPos.X := MaxRight; - Dec(MaxRight, FSpacing); - end; - if Layout in [blGlyphTop, blGlyphBottom] then - begin - TextPos.X := MaxRight - TextSize.cx; - if UseHeaderGlyph then - begin - HeaderGlyphPos.X := (ClientSize.X - HeaderGlyphSize.X) div 2; - if HeaderGlyphPos.X + HeaderGlyphSize.X + FSpacing > MaxRight then - HeaderGlyphPos.X := MaxRight - HeaderGlyphSize.X - FSpacing; - MaxRight := Min(TextPos.X - TextSpacing, HeaderGlyphPos.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 UseHeaderGlyph and (Layout = blGlyphRight) then - begin - HeaderGlyphPos.X := MaxRight - HeaderGlyphSize.X; - MaxRight := HeaderGlyphPos.X - FSpacing; - end; - TextPos.X := MaxRight - TextSize.cx; - MaxRight := TextPos.X - TextSpacing; - if UseHeaderGlyph and (Layout = blGlyphLeft) then - begin - HeaderGlyphPos.X := MaxRight - HeaderGlyphSize.X; - MaxRight := HeaderGlyphPos.X - FSpacing; - end; - end; - if UseSortGlyph and (FBidiMode <> bdLeftToRight) then - SortGlyphPos.X := MaxRight - SortGlyphSize.X; - 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 UseSortGlyph then - begin - if FBidiMode = bdLeftToRight then - begin - // Sort glyph on the right hand side. - if SortGlyphPos.X + SortGlyphSize.X > MaxRight then - SortGlyphPos.X := MaxRight - SortGlyphSize.X; - MaxRight := SortGlyphPos.X - FSpacing; - end; - - // Consider also the left side of the sort glyph regardless of the bidi mode. - if SortGlyphPos.X < MinLeft then - SortGlyphPos.X := MinLeft; - // Left border needs only adjustment if the sort glyph marks the left border. - if FBidiMode <> bdLeftToRight then - MinLeft := SortGlyphPos.X + SortGlyphSize.X + FSpacing; - - // Finally transform sort glyph to its actual position. - with SortGlyphPos do - begin - Inc(X, Client.Left); - Inc(Y, Client.Top); - end; - end; - if UseHeaderGlyph then - begin - if HeaderGlyphPos.X + HeaderGlyphSize.X > MaxRight then - HeaderGlyphPos.X := MaxRight - HeaderGlyphSize.X; - if Layout = blGlyphRight then - MaxRight := HeaderGlyphPos.X - FSpacing; - if HeaderGlyphPos.X < MinLeft then - HeaderGlyphPos.X := MinLeft; - if Layout = blGlyphLeft then - MinLeft := HeaderGlyphPos.X + HeaderGlyphSize.X + FSpacing; - // Finally transform header glyph to its actual position. - with HeaderGlyphPos do - begin - Inc(X, Client.Left); - Inc(Y, Client.Top); - end; - end; - if UseText then - begin - if TextPos.X < MinLeft then - TextPos.X := MinLeft; - OffsetRect(TextBounds, TextPos.X, TextPos.Y); - if TextBounds.Right > MaxRight then - TextBounds.Right := MaxRight; - OffsetRect(TextBounds, Client.Left, Client.Top); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumn.DefineProperties(Filer: TFiler); - -begin - inherited; - - // Must define a new name for the properties otherwise the VCL will try to load the wide string - // without asking us and screws it completely up. - Filer.DefineProperty('WideText', ReadText, WriteText, FText <> ''); - Filer.DefineProperty('WideHint', ReadHint, WriteHint, FHint <> ''); -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.ReadText(Reader: TReader); - -begin - case Reader.NextValue of - vaLString, vaString: - SetText(Reader.ReadString); - else - SetText(Reader.ReadWideString); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumn.ReadHint(Reader: TReader); - -begin - case Reader.NextValue of - vaLString, vaString: - FHint := Reader.ReadString; - else - FHint := Reader.ReadWideString; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumn.WriteHint(Writer: TWriter); - -begin - Writer.WriteWideString(FHint); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumn.WriteText(Writer: TWriter); - -begin - Writer.WriteWideString(FText); -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; - Color := TVirtualTreeColumn(Source).Color; - Tag := TVirtualTreeColumn(Source).Tag; - - // Order is important. Assign options last. - FOptions := OldOptions; - Options := TVirtualTreeColumn(Source).Options; - - Changed(False); - end - else - inherited Assign(Source); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVirtualTreeColumn.Equals(OtherColumn: TVirtualTreeColumn): Boolean; - -begin - 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 - (Color = OtherColumn.Color) and - (Tag = OtherColumn.Tag) and - (Options = OtherColumn.Options); -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; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumn.LoadFromStream(const Stream: TStream; Version: Integer); - - //--------------- local function -------------------------------------------- - - function ConvertOptions(Value: Cardinal): TVTColumnOptions; - - // Converts the given raw value which represents column options for possibly older - // formats to the current format. - //todo_lcl_check - begin - if Version >= 3 then - Result := TVTColumnOptions(LongWord(Value and $FFFF)) - else - if Version = 2 then - Result := TVTColumnOptions(LongWord(Value and $FF)) - else - begin - // In version 2 coParentColor has been added. This needs an option shift for older stream formats. - // The first (lower) 4 options remain as they are. - Result := TVTColumnOptions(LongWord(Word(Value) and $F)); - Value := (Value and not $F) shl 1; - Result := Result + TVTColumnOptions(LongWord(Value and $FF)); - end; - end; - - //--------------- end local function ---------------------------------------- - -var - Dummy: Integer; - S: WideString; - -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)); - Options := ConvertOptions(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; - 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 := LongWord(FOptions); - WriteBuffer(Dummy, SizeOf(Dummy)); - - // parts introduce with stream version 1 - WriteBuffer(FTag, SizeOf(Dummy)); - Dummy := Cardinal(FAlignment); - WriteBuffer(Dummy, SizeOf(Dummy)); - - // parts introduce with stream version 2 - Dummy := Integer(FColor); - WriteBuffer(Dummy, SizeOf(Dummy)); - 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; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -destructor TVirtualTreeColumns.Destroy; - -begin - FHeaderBitmap.Free; - inherited; -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.FHeight); - NewIndex := ColumnFromPosition(P); - if NewIndex <> OldIndex then - begin - if OldIndex > NoColumn then - FHeader.Invalidate(Items[OldIndex]); - OldIndex := NewIndex; - if OldIndex > NoColumn then - FHeader.Invalidate(Items[OldIndex]); - Result := True; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumns.SetItem(Index: TColumnIndex; Value: TVirtualTreeColumn); - -begin - inherited SetItem(Index, Value); -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; - -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.FAutoSizeIndex; - 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].FOptions) 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; - FHeader.Treeview.DoColumnResize(AutoIndex); - 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.FHeight); - Result := ColumnFromPosition(P); - if (Result > NoColumn) and (Result <> FDownIndex) and (coAllowClick in Items[Result].FOptions) and - (coEnabled in Items[Result].FOptions) then - begin - if FDownIndex > NoColumn then - FHeader.Invalidate(Items[FDownIndex]); - FDownIndex := Result; - 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; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumns.DrawButtonText(DC: HDC; Caption: WideString; Bounds: TRect; Enabled, Hot: Boolean; - DrawFormat: Cardinal); - -var - TextSpace: Integer; - Size: TSize; - -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); - - SetBkMode(DC, TRANSPARENT); - if not Enabled then - begin - OffsetRect(Bounds, 1, 1); - SetTextColor(DC, ColorToRGB(clBtnHighlight)); - if IsWinNT then - Windows.DrawTextW(DC, PWideChar(Caption), Length(Caption), Bounds, DrawFormat) - else - DrawTextW(DC, PWideChar(Caption), Length(Caption), Bounds, DrawFormat, False); - OffsetRect(Bounds, -1, -1); - SetTextColor(DC, ColorToRGB(clBtnShadow)); - if IsWinNT then - Windows.DrawTextW(DC, PWideChar(Caption), Length(Caption), Bounds, DrawFormat) - else - DrawTextW(DC, PWideChar(Caption), Length(Caption), Bounds, DrawFormat, False); - end - else - begin - if Hot then - SetTextColor(DC, ColorToRGB(FHeader.Treeview.FColors.HeaderHotColor)) - else - SetTextColor(DC, ColorToRGB(FHeader.FFont.Color)); - if IsWinNT then - Windows.DrawTextW(DC, PWideChar(Caption), Length(Caption), Bounds, DrawFormat) - else - DrawTextW(DC, PWideChar(Caption), Length(Caption), Bounds, DrawFormat, False); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -// XP style header button legacy code. This procedure is only used on non-XP systems to simulate the themed -// header style. -// Note: the theme elements displayed here only correspond to the standard themes of Windows XP - -const - XPMainHeaderColorUp = $DBEAEB; // Main background color of the header if drawn as being not pressed. - XPMainHeaderColorDown = $D8DFDE; // Main background color of the header if drawn as being pressed. - XPMainHeaderColorHover = $F3F8FA; // Main background color of the header if drawn as being under the mouse pointer. - XPDarkSplitBarColor = $B2C5C7; // Dark color of the splitter bar. - XPLightSplitBarColor = $FFFFFF; // Light color of the splitter bar. - XPDarkGradientColor = $B8C7CB; // Darkest color in the bottom gradient. Other colors will be interpolated. - XPDownOuterLineColor = $97A5A5; // Down state border color. - XPDownMiddleLineColor = $B8C2C1; // Down state border color. - XPDownInnerLineColor = $C9D1D0; // Down state border color. - -procedure TVirtualTreeColumns.DrawXPButton(DC: HDC; ButtonR: TRect; DrawSplitter, Down, Hover: Boolean); - -// Helper procedure to draw an Windows XP like header button. - -var - PaintBrush: HBRUSH; - Pen, - OldPen: HPEN; - PenColor, - FillColor: COLORREF; - dRed, dGreen, dBlue: Single; - Width, - XPos: Integer; - -begin - if Down then - FillColor := XPMainHeaderColorDown - else - if Hover then - FillColor := XPMainHeaderColorHover - else - FillColor := XPMainHeaderColorUp; - PaintBrush := CreateSolidBrush(FillColor); - FillRect(DC, ButtonR, PaintBrush); - DeleteObject(PaintBrush); - - if DrawSplitter and not (Down or Hover) then - begin - // One solid pen for the dark line... - Pen := CreatePen(PS_SOLID, 1, XPDarkSplitBarColor); - OldPen := SelectObject(DC, Pen); - MoveToEx(DC, ButtonR.Right - 2, ButtonR.Top + 3, nil); - LineTo(DC, ButtonR.Right - 2, ButtonR.Bottom - 5); - // ... and one solid pen for the light line. - Pen := CreatePen(PS_SOLID, 1, XPLightSplitBarColor); - DeleteObject(SelectObject(DC, Pen)); - MoveToEx(DC, ButtonR.Right - 1, ButtonR.Top + 3, nil); - LineTo(DC, ButtonR.Right - 1, ButtonR.Bottom - 5); - SelectObject(DC, OldPen); - DeleteObject(Pen); - end; - - if Down then - begin - // Down state. Three lines to draw. - // First one is the outer line, drawn at left, bottom and right. - Pen := CreatePen(PS_SOLID, 1, XPDownOuterLineColor); - OldPen := SelectObject(DC, Pen); - MoveToEx(DC, ButtonR.Left, ButtonR.Top, nil); - LineTo(DC, ButtonR.Left, ButtonR.Bottom - 1); - LineTo(DC, ButtonR.Right - 1, ButtonR.Bottom - 1); - LineTo(DC, ButtonR.Right - 1, ButtonR.Top - 1); - - // Second one is the middle line, which is a bit lighter. - Pen := CreatePen(PS_SOLID, 1, XPDownMiddleLineColor); - DeleteObject(SelectObject(DC, Pen)); - MoveToEx(DC, ButtonR.Left + 1, ButtonR.Bottom - 2, nil); - LineTo(DC, ButtonR.Left + 1, ButtonR.Top); - LineTo(DC, ButtonR.Right - 1, ButtonR.Top); - - // Third line is the inner line, which is even lighter than the middle line. - Pen := CreatePen(PS_SOLID, 1, XPDownInnerLineColor); - DeleteObject(SelectObject(DC, Pen)); - MoveToEx(DC, ButtonR.Left + 2, ButtonR.Bottom - 2, nil); - LineTo(DC, ButtonR.Left + 2, ButtonR.Top + 1); - LineTo(DC, ButtonR.Right - 1, ButtonR.Top + 1); - - // Housekeeping: - SelectObject(DC, OldPen); - DeleteObject(Pen); - end - else - if Hover then - begin - // Hover state. There are three lines at the bottom border, but they are rendered in a way which - // requires expensive construction. - Width := ButtonR.Right - ButtonR.Left; - if Width <= 32 then - begin - ImageList_DrawEx(UtilityImages.Handle, 8, DC, ButtonR.Right - 16, ButtonR.Bottom - 3, 16, 3, CLR_NONE, CLR_NONE, - ILD_NORMAL); - ImageList_DrawEx(UtilityImages.Handle, 6, DC, ButtonR.Left, ButtonR.Bottom - 3, Width div 2, 3, CLR_NONE, - CLR_NONE, ILD_NORMAL); - end - else - begin - ImageList_DrawEx(UtilityImages.Handle, 6, DC, ButtonR.Left, ButtonR.Bottom - 3, 16, 3, CLR_NONE, CLR_NONE, - ILD_NORMAL); - // Replicate inner part as many times as need to fill up the button rectangle. - XPos := ButtonR.Left + 16; - repeat - ImageList_DrawEx(UtilityImages.Handle, 7, DC, XPos, ButtonR.Bottom - 3, 16, 3, CLR_NONE, CLR_NONE, ILD_NORMAL); - Inc(XPos, 16); - until XPos + 16 >= ButtonR.Right; - ImageList_DrawEx(UtilityImages.Handle, 8, DC, ButtonR.Right - 16, ButtonR.Bottom - 3, 16, 3, CLR_NONE, CLR_NONE, - ILD_NORMAL); - end; - end - else - begin - // There is a three line gradient near the bottom border which transforms from the button color to a dark, - // clBtnFace like color (here XPDarkGradientColor). - PenColor := XPMainHeaderColorUp; - dRed := ((PenColor and $FF) - (XPDarkGradientColor and $FF)) / 3; - dGreen := (((PenColor shr 8) and $FF) - ((XPDarkGradientColor shr 8) and $FF)) / 3; - dBlue := (((PenColor shr 16) and $FF) - ((XPDarkGradientColor shr 16) and $FF)) / 3; - - // First line: - PenColor := PenColor - Round(dRed) - Round(dGreen) shl 8 - Round(dBlue) shl 16; - Pen := CreatePen(PS_SOLID, 1, PenColor); - OldPen := SelectObject(DC, Pen); - MoveToEx(DC, ButtonR.Left, ButtonR.Bottom - 3, nil); - LineTo(DC, ButtonR.Right, ButtonR.Bottom - 3); - - // Second line: - PenColor := PenColor - Round(dRed) - Round(dGreen) shl 8 - Round(dBlue) shl 16; - Pen := CreatePen(PS_SOLID, 1, PenColor); - DeleteObject(SelectObject(DC, Pen)); - MoveToEx(DC, ButtonR.Left, ButtonR.Bottom - 2, nil); - LineTo(DC, ButtonR.Right, ButtonR.Bottom - 2); - - // Third line: - Pen := CreatePen(PS_SOLID, 1, XPDarkGradientColor); - DeleteObject(SelectObject(DC, Pen)); - MoveToEx(DC, ButtonR.Left, ButtonR.Bottom - 1, nil); - LineTo(DC, ButtonR.Right, ButtonR.Bottom - 1); - - // Housekeeping: - DeleteObject(SelectObject(DC, OldPen)); - 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; - if P.X < ColumnRight then - begin - Result := FPositionToIndex[I]; - Exit; - end; - ColumnLeft := ColumnRight; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVirtualTreeColumns.GetOwner: TPersistent; - -begin - Result := FHeader; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumns.HandleClick(P: TPoint; Button: TMouseButton; Force, DblClick: 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). - -var - NewClickIndex: Integer; - Shift: TShiftState; - -begin - // Convert vertical position to local coordinates. - Inc(P.Y, FHeader.FHeight); - NewClickIndex := ColumnFromPosition(P); - if (NewClickIndex > NoColumn) and (coAllowClick in Items[NewClickIndex].FOptions) and - ((NewClickIndex = FDownIndex) or Force) then - begin - FClickIndex := NewClickIndex; - Shift := FHeader.GetShiftState; - if DblClick then - Shift := Shift + [ssDouble]; - FHeader.Treeview.DoHeaderClick(NewClickIndex, Button, Shift, P.X, P.Y); - FHeader.Invalidate(Items[NewClickIndex]); - end - else - FClickIndex := NoColumn; - - if (FClickIndex > NoColumn) and (FClickIndex <> NewClickIndex) then - FHeader.Invalidate(Items[FClickIndex]); -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(Integer)); - 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.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.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.FMainColumn := 0; - - if not (csLoading in Header.Treeview.ComponentState) and not (hsLoading in FHeader.FStates) 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 (tsUpdating in Treeview.FStates) 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 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; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVirtualTreeColumns.Add: TVirtualTreeColumn; - -begin - 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 - // Make sure the width constrains are considered. - if NewWidth < Items[Column].FMinWidth then - NewWidth := Items[Column].FMinWidth; - if NewWidth > Items[Column].FMaxWidth then - NewWidth := Items[Column].FMaxWidth; - - OldWidth := Items[Column].Width; - // Nothing to do if the width is the same. - if OldWidth <> NewWidth 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; - 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 - // Since we're freeing all columns, the following have to be true when we're done. - FHoverIndex := NoColumn; - FDownIndex := NoColumn; - FTrackIndex := NoColumn; - FClickIndex := NoColumn; - - with Header do - if not (hsLoading in FStates) then - begin - FAutoSizeIndex := NoColumn; - FMainColumn := NoColumn; - FSortColumn := NoColumn; - end; - - 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]].FOptions 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(OtherColumns: TVirtualTreeColumns): 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; - -begin - // 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.GetFirstVisibleColumn: TColumnIndex; - -// Returns the index of the first visible column or "InvalidColumn" if either no columns are defined or -// all columns are hidden. - -var - I: Integer; - -begin - Result := InvalidColumn; - for I := 0 to Count - 1 do - if coVisible in Items[FPositionToIndex[I]].FOptions then - begin - Result := FPositionToIndex[I]; - Break; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVirtualTreeColumns.GetLastVisibleColumn: TColumnIndex; - -// Returns the index of the last visible column or "InvalidColumn" if either no columns are defined or -// all columns are hidden. - -var - I: Integer; - -begin - Result := InvalidColumn; - for I := Count - 1 downto 0 do - if coVisible in Items[FPositionToIndex[I]].FOptions then - begin - Result := FPositionToIndex[I]; - Break; - end; -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): TColumnIndex; - -// Returns the next visible column in display order, Column is an index into the columns list. - -begin - Result := Column; - repeat - Result := GetNextColumn(Result); - until (Result = InvalidColumn) or (coVisible in Items[Result].FOptions); -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): TColumnIndex; - -// Returns the previous column in display order, Column is an index into the columns list. - -begin - Result := Column; - repeat - Result := GetPreviousColumn(Result); - until (Result = InvalidColumn) or (coVisible in Items[Result].FOptions); -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]].FOptions 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(Cardinal)); - UpdatePositions(True); - finally - EndUpdate; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualTreeColumns.PaintHeader(DC: HDC; R: TRect; HOffset: Integer); - -// Main paint method to draw the header. - -const - SortGlyphs: array[TSortDirection, Boolean] of Integer = ( // ascending/descending, normal/XP style - (3, 5) {ascending}, (2, 4) {descending} - ); - -var - I, Y, - SortIndex: Integer; - Run: TRect; - RightBorderFlag, - NormalButtonStyle, - NormalButtonFlags, - PressedButtonStyle, - PressedButtonFlags, - RaisedButtonStyle, - RaisedButtonFlags: Cardinal; - DrawFormat: Cardinal; - Images: TCustomImageList; - ButtonRgn: HRGN; - OwnerDraw, - AdvancedOwnerDraw: Boolean; - {$ifdef ThemeSupport} - Details: TThemedElementDetails; - {$endif ThemeSupport} - - PaintInfo: THeaderPaintInfo; - RequestedElements, - ActualElements: THeaderPaintElements; - - SavedDC: Integer; - Temp: TRect; - -begin - Run := FHeader.Treeview.FHeaderRect; - FHeaderBitmap.Width := Max(Run.Right, R.Right - R.Left); - FHeaderBitmap.Height := Run.Bottom; - OwnerDraw := (hoOwnerDraw in FHeader.FOptions) and Assigned(FHeader.Treeview.FOnHeaderDraw) and - not (csDesigning in FHeader.Treeview.ComponentState); - AdvancedOwnerDraw := (hoOwnerDraw in FHeader.FOptions) and Assigned(FHeader.Treeview.FOnAdvancedHeaderDraw) and - Assigned(FHeader.Treeview.FOnHeaderDrawQueryElements) and not (csDesigning in FHeader.Treeview.ComponentState); - // If both draw posibillities are specified then prefer the advanced way. - if AdvancedOwnerDraw then - OwnerDraw := False; - - FillChar(PaintInfo, SizeOf(PaintInfo),#0); - PaintInfo.TargetCanvas := FHeaderBitmap.Canvas; - - with PaintInfo, TargetCanvas do - begin - Font := FHeader.FFont; - - 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; - - // Use shortcut for the images. - Images := FHeader.FImages; - - // Consider right-to-left directionality. - with FHeader.Treeview do - if UseRightToLeftAlignment then - Inc(HOffset, ComputeRTLOffset); - - // Erase background of the header. - // See if the application wants to do that on its own. - RequestedElements := []; - if AdvancedOwnerDraw then - begin - PaintInfo.PaintRectangle := R; - PaintInfo.Column := nil; - FHeader.Treeview.DoHeaderDrawQueryElements(PaintInfo, RequestedElements); - end; - - if hpeBackground in RequestedElements then - begin - FHeader.Treeview.DoAdvancedHeaderDraw(PaintInfo, [hpeBackground]); - end - else - begin - {$ifdef ThemeSupport} - if tsUseThemes in FHeader.Treeview.FStates then - begin - Details := ThemeServices.GetElementDetails(thHeaderItemRightNormal); - ThemeServices.DrawElement(Handle, Details, R, @R); - end - else - {$endif ThemeSupport} - if FHeader.Style = hsXPStyle then - DrawXPButton(Handle, Run, False, False, False) - else - begin - Brush.Color := FHeader.FBackground; - FillRect(R); - end; - end; - - Run.Top := R.Top; - Run.Right := R.Left; - Run.Bottom := R.Bottom; - // Run.Left is set in the loop - - Temp := Run; - //todo_lcl_check - ShowRightBorder := (FHeader.Style = hsThickButtons) or not (hoAutoResize in FHeader.FOptions);// or - //(FHeader.Treeview.BevelKind = bkNone); - - // Now go for each button. - for I := 0 to Count - 1 do - begin - with Items[FPositionToIndex[I]] do - if coVisible in FOptions then - begin - if not (coFixed in FOptions) then - begin - Inc(Run.Right, HOffset); - HOffset := 0; - end; - - Temp := Rect(Temp.Right, Run.Top, Max(Temp.Right, Run.Right + Width), Run.Bottom); - - Run.Left := Run.Right; - Inc(Run.Right, Width); - // Skip columns which are not visible at all. - if (Run.Right > R.Left) and (Run.Right > Temp.Left) then - begin - // Stop painting if the rectangle is filled. - if Run.Left > R.Right then - Break; - - // Create a clip region to avoid overpainting any other area which does not belong to this column. - if Temp.Right > R.Right then - Temp.Right := R.Right; - if Temp.Left < R.Left then - Temp.Left := R.Left; - - ButtonRgn := CreateRectRgnIndirect(Temp); - SelectClipRgn(Handle, ButtonRgn); - DeleteObject(ButtonRgn); - - IsHoverIndex := (Integer(FPositionToIndex[I]) = FHoverIndex) and (hoHotTrack in FHeader.FOptions) and - (coEnabled in FOptions); - IsDownIndex := Integer(FPositionToIndex[I]) = FDownIndex; - if (coShowDropMark in FOptions) and (Integer(FPositionToIndex[I]) = FDropTarget) and - (Integer(FPositionToIndex[I]) <> FDragIndex) then - begin - if FDropBefore then - DropMark := dmmLeft - else - DropMark := dmmRight; - end - else - DropMark := dmmNone; - IsEnabled := (coEnabled in FOptions) and (FHeader.Treeview.Enabled); - ShowHeaderGlyph := (hoShowImages in FHeader.FOptions) and Assigned(Images) and (FImageIndex > -1); - ShowSortGlyph := (Integer(FPositionToIndex[I]) = FHeader.FSortColumn) and (hoShowSortGlyphs in FHeader.FOptions); - - PaintRectangle := Run; - - // 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[FPositionToIndex[I]]; - FHeader.Treeview.DoHeaderDrawQueryElements(PaintInfo, RequestedElements); - end; - - if ShowRightBorder or (I < Count - 1) then - RightBorderFlag := BF_RIGHT - else - RightBorderFlag := 0; - - if hpeBackground in RequestedElements then - FHeader.Treeview.DoAdvancedHeaderDraw(PaintInfo, [hpeBackground]) - else - begin - // Draw button first before setting the clip region. - {$ifdef ThemeSupport} - if tsUseThemes in FHeader.Treeview.FStates then - begin - if IsDownIndex then - Details := ThemeServices.GetElementDetails(thHeaderItemPressed) - else - if IsHoverIndex then - Details := ThemeServices.GetElementDetails(thHeaderItemHot) - else - Details := ThemeServices.GetElementDetails(thHeaderItemNormal); - ThemeServices.DrawElement(Handle, Details, PaintRectangle, @PaintRectangle); - end - else - {$endif ThemeSupport} - begin - if FHeader.Style = hsXPStyle then - DrawXPButton(Handle, PaintRectangle, RightBorderFlag <> 0, IsDownIndex, IsHoverIndex) - else - if IsDownIndex then - DrawEdge(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(Handle, PaintRectangle, RaisedButtonStyle, RaisedButtonFlags or RightBorderFlag) - else - DrawEdge(Handle, PaintRectangle, NormalButtonStyle, NormalButtonFlags or RightBorderFlag); - end; - end; - end; - - PaintRectangle := Run; - if (Style = vsText) or not OwnerDraw or AdvancedOwnerDraw then - begin - // calculate text and glyph position - InflateRect(PaintRectangle, -2, -2); - DrawFormat := DT_LEFT or DT_TOP or DT_NOPREFIX; - if UseRightToLeftReading then - DrawFormat := DrawFormat + DT_RTLREADING; - ComputeHeaderLayout(Handle, PaintRectangle, ShowHeaderGlyph, ShowSortGlyph, GlyphPos, SortGlyphPos, - TextRectangle); - - // 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]; - - // main glyph - if not (hpeHeaderGlyph in ActualElements) and ShowHeaderGlyph and - (not ShowSortGlyph or (FBidiMode <> bdLeftToRight) or (GlyphPos.X + Images.Width <= SortGlyphPos.X)) then - Images.Draw(FHeaderBitmap.Canvas, GlyphPos.X, GlyphPos.Y, FImageIndex, IsEnabled); - - // caption - if not (hpeText in ActualElements) and (Length(Text) > 0) then - DrawButtonText(Handle, Text, TextRectangle, IsEnabled, IsHoverIndex and (hoHotTrack in FHeader.FOptions) and - not (tsUseThemes in FHeader.Treeview.FStates), DrawFormat); - - // sort glyph - if not (hpeSortGlyph in ActualElements) and ShowSortGlyph then - begin - SortIndex := SortGlyphs[FHeader.FSortDirection, tsUseThemes in FHeader.Treeview.FStates]; - UtilityImages.Draw(FHeaderBitmap.Canvas, SortGlyphPos.X, SortGlyphPos.Y, SortIndex); - 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 - Y := (PaintRectangle.Top + PaintRectangle.Bottom - UtilityImages.Height) div 2; - if DropMark = dmmLeft then - UtilityImages.Draw(FHeaderBitmap.Canvas, PaintRectangle.Left, Y, 0) - else - UtilityImages.Draw(FHeaderBitmap.Canvas, PaintRectangle.Right - 16 , Y, 1); - end; - - if ActualElements <> [] then - begin - SavedDC := SaveDC(Handle); - FHeader.Treeview.DoAdvancedHeaderDraw(PaintInfo, ActualElements); - RestoreDC(Handle, SavedDC); - end; - end - else // Let application draw the header. - FHeader.Treeview.DoHeaderDraw(FHeaderBitmap.Canvas, Items[FPositionToIndex[I]], PaintRectangle, IsHoverIndex, - IsDownIndex, DropMark); - SelectClipRgn(Handle, 0); - end; - end; - end; - - // Blit the result to target. - with R do - BitBlt(DC, Left, Top, Right - Left, Bottom - Top, Handle, Left, Top, SRCCOPY); - 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(Cardinal)); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVirtualTreeColumns.TotalWidth: Integer; - -var - LastColumn: TColumnIndex; - -begin - if Count = 0 then - Result := 0 - else - begin - LastColumn := FPositionToIndex[Count - 1]; - if not (coVisible in Items[LastColumn].FOptions) then - LastColumn := GetPreviousVisibleColumn(LastColumn); - if LastColumn > NoColumn then - with Items[LastColumn] do - Result := FLeft + FWidth - else - Result := 0; - end; -end; - -//----------------- TVTHeader ----------------------------------------------------------------------------------------- - -constructor TVTHeader.Create(AOwner: TBaseVirtualTree); - -begin - inherited Create; - FOwner := AOwner; - FColumns := GetColumnsClass.Create(Self); - FHeight := 17; - FFont := TFont.Create; - FFont.OnChange := FontChanged; - FParentFont := False; - FBackground := clBtnFace; - FOptions := [hoColumnResize, hoDrag]; - - FImageChangeLink := TChangeLink.Create; - FImageChangeLink.OnChange := ImageListChange; - - FSortColumn := NoColumn; - FSortDirection := sdAscending; - FMainColumn := NoColumn; - - FDragImage := TVTDragImage.Create(AOwner); - with FDragImage do - begin - Fade := False; - PostBlendBias := 0; - PreBlendBias := -50; - Transparency := 140; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -destructor TVTHeader.Destroy; - -begin - FDragImage.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 - Invalidate(nil); -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; - -//---------------------------------------------------------------------------------------------------------------------- - -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 FBackground <> Value then - begin - FBackground := Value; - Invalidate(nil); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTHeader.SetColumns(Value: TVirtualTreeColumns); - -begin - FColumns.Assign(Value); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTHeader.SetFont(const Value: TFont); - -begin - FFont.Assign(Value); - FParentFont := False; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTHeader.SetHeight(Value: Cardinal); - -begin - if FHeight <> Value then - begin - FHeight := Value; - if not (csLoading in Treeview.ComponentState) then - RecalculateHeader; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTHeader.SetImages(const Value: TCustomImageList); - -begin - if FImages <> Value then - begin - if Assigned(FImages) then - begin - FImages.UnRegisterChanges(FImageChangeLink); - {$ifdef COMPILER_5_UP} - FImages.RemoveFreeNotification(FOwner); - {$endif COMPILER_5_UP} - 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.FOptions.FSelectionOptions) then - Treeview.FocusedColumn := FMainColumn; - Treeview.Invalidate; - end; - end; - end; -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 - 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; - if FSortColumn > NoColumn then - Invalidate(Columns[FSortColumn]); - if (toAutoSort in Treeview.FOptions.FAutoOptions) and (Treeview.FUpdateCount = 0) then - Treeview.SortTree(FSortColumn, FSortDirection, True); - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTHeader.SetSortDirection(const Value: TSortDirection); - -begin - if Value <> FSortDirection then - begin - FSortDirection := Value; - Invalidate(nil); - if (toAutoSort in Treeview.FOptions.FAutoOptions) and (Treeview.FUpdateCount = 0) then - Treeview.SortTree(FSortColumn, FSortDirection, True); - end; -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; - -//---------------------------------------------------------------------------------------------------------------------- - -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); - -begin - FFont.Size := MulDiv(FFont.Size, M, D); -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 - I, - SplitPoint: Integer; - -begin - Result := False; - FColumns.FTrackIndex := NoColumn; - - if FColumns.Count > 0 then - begin - if Treeview.UseRightToLeftAlignment then - begin - SplitPoint := -Treeview.FEffectiveOffsetX; - if Integer(Treeview.FRangeX) < Treeview.ClientWidth then - Inc(SplitPoint, Treeview.ClientWidth - Integer(Treeview.FRangeX)); - - for I := 0 to FColumns.Count - 1 do - with FColumns, Items[FPositionToIndex[I]] do - if coVisible in FOptions then - begin - if (P.X < SplitPoint + 3) and (P.X > SplitPoint - 5) then - begin - if coResizable in FOptions 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. - FTrackPos := SplitPoint + FWidth; - end; - Break; - end; - Inc(SplitPoint, FWidth); - end; - end - else - begin - SplitPoint := -Treeview.FEffectiveOffsetX + Integer(Treeview.FRangeX); - - for I := FColumns.Count - 1 downto 0 do - with FColumns, Items[FPositionToIndex[I]] do - if coVisible in FOptions then - begin - if (P.X < SplitPoint + 5) and (P.X > SplitPoint - 3) then - begin - if coResizable in FOptions 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. - FTrackPos := SplitPoint - FWidth; - end; - Break; - end; - Dec(SplitPoint, FWidth); - end; - end; - 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.FDropTarget); - if NewTarget >= 0 then - begin - FColumns.GetColumnBounds(NewTarget, Left, Right); - if (ClientP.X < ((Left + Right) div 2)) <> FColumns.FDropBefore then - begin - NeedRepaint := True; - FColumns.FDropBefore := not FColumns.FDropBefore; - end; - end; - - if NeedRepaint then - begin - // Invalidate columns which need a repaint. - if FColumns.FDropTarget > NoColumn then - begin - I := FColumns.FDropTarget; - FColumns.FDropTarget := NoColumn; - Invalidate(FColumns.Items[I]); - end; - if (NewTarget > NoColumn) and (NewTarget <> FColumns.FDropTarget) then - begin - Invalidate(FColumns.Items[NewTarget]); - FColumns.FDropTarget := NewTarget; - end; - end; - - FDragImage.DragTo(P, NeedRepaint); -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.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: TLMMouseMove): Boolean; - -var - P: TPoint; - I: TColumnIndex; - -begin - Result := False; - with Message do - begin - P := Point(XPos, YPos); - if hsTrackPending in FStates then - begin - Treeview.StopTimer(HeaderTimer); - FStates := FStates - [hsTrackPending] + [hsTracking]; - HandleHeaderMouseMove := True; - Result := 0; - end - else - if hsTracking in FStates then - begin - if Treeview.UseRightToLeftAlignment then - FColumns[FColumns.FTrackIndex].Width := FTrackPos - XPos - else - FColumns[FColumns.FTrackIndex].Width := XPos - FTrackPos; - 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.FDownIndex) 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.FDownIndex; - FColumns.FDownIndex := NoColumn; - FColumns.FHoverIndex := 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: TLMessage): 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; - -begin - Result := False; - {$ifdef EnableHeader} - case Message.Msg of - LM_SIZE: - begin - if (hoAutoResize in FOptions) and not (hsAutoSizing in FStates) and - not (tsWindowCreating in FOwner.FStates) then - begin - FColumns.AdjustAutoSize(InvalidColumn); - 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].FOptions 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.FDownIndex := NoColumn; - end; - end; - WM_NCLBUTTONDBLCLK, - WM_NCMBUTTONDBLCLK, - WM_NCRBUTTONDBLCLK: - begin - with TWMNCLButtonDblClk(Message) do - P := FOwner.ScreenToClient(Point(XCursor, YCursor)); - // If the click was on a splitter then resize column do smallest width. - if InHeader(P) then - begin - case Message.Msg of - WM_NCMBUTTONDBLCLK: - Button := mbMiddle; - WM_NCRBUTTONDBLCLK: - Button := mbRight; - else - // WM_NCLBUTTONDBLCLK - Button := mbLeft; - end; - if (hoDblClickResize in FOptions) and (FColumns.FTrackIndex > NoColumn) then - begin - with FColumns do - AnimatedResize(FTrackIndex, Max(FColumns[FTrackIndex].MinWidth, Treeview.GetMaxColumnWidth(FTrackIndex))); - end - else - FColumns.HandleClick(P, Button, True, True); - if FColumns.FClickIndex > NoColumn then - FOwner.DoHeaderDblClick(FColumns.FClickIndex, Button, GetShiftState + [ssDouble], P.X, P.Y + - Integer(FHeight)); - end; - end; - WM_NCLBUTTONDOWN: - begin - Application.CancelHint; - - // 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]); - - with TWMNCLButtonDown(Message) do - begin - // want the drag start point in screen coordinates - FDragStart := Point(XCursor, YCursor); - P := Treeview.ScreenToClient(FDragStart); - end; - - if InHeader(P) then - begin - // This is a good opportunity to notify the application. - FOwner.DoHeaderMouseDown(mbLeft, GetShiftState, P.X, P.Y + Integer(FHeight)); - - if DetermineSplitterIndex(P) and (hoColumnResize in FOptions) then - begin - FColumns.FHoverIndex := NoColumn; - FTrackStart := P; - Include(FStates, hsTrackPending); - SetCapture(Treeview.Handle); - Result := True; - Message.Result := 0; - end - else - begin - HitIndex := Columns.AdjustDownColumn(P); - if (hoDrag in FOptions) and (HitIndex > NoColumn) and (coDraggable in FColumns[HitIndex].FOptions) 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; - end; - 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 - FColumns.HandleClick(P, mbRight, True, False); - FOwner.DoHeaderMouseUp(mbRight, GetShiftState, P.X, P.Y + Integer(FHeight)); - FColumns.FDownIndex := NoColumn; - FColumns.FTrackIndex := NoColumn; - - // Trigger header popup if there's one. - if Assigned(FPopupMenu) then - begin - Treeview.StopTimer(ScrollTimer); - Treeview.StopTimer(HeaderTimer); - FColumns.FHoverIndex := NoColumn; - Treeview.DoStateChange([], [tsScrollPending, tsScrolling]); - FPopupMenu.PopupComponent := Treeview; - FPopupMenu.Popup(XCursor, YCursor); - HandleMessage := True; - end; - 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; - if (FDropTarget > -1) and (FDropTarget <> FDragIndex) and PtInRect(R, P) then - begin - OldPosition := FColumns[FDragIndex].Position; - if FColumns.FDropBefore 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.FDownIndex > 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.FTrackIndex > NoColumn then - begin - Invalidate(Columns[FColumns.FTrackIndex]); - FColumns.FTrackIndex := NoColumn; - end; - if FColumns.FDownIndex > NoColumn then - begin - Invalidate(Columns[FColumns.FDownIndex]); - FColumns.FDownIndex := NoColumn; - end; - FStates := FStates - [hsDragging, hsDragPending, hsTracking, hsTrackPending]; - end; - // 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. The best solution available would be the - // TrackMouseEvent API. Unfortunately, it leaves Win95 totally and WinNT4 for non-client stuff out and - // currently I cannot ignore these systems. Hence I go the only other reliable way and use a timer - // (although, I don't like it...). - 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; - Result := True; - Message.Result := 0; - Invalidate(nil); - end; - end; - end; - WM_MOUSEMOVE: // mouse capture and general message redirection - Result := HandleHeaderMouseMove(TWMMouseMove(Message)); - WM_SETCURSOR: - 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? - P := Treeview.ScreenToClient(P); - if InHeader(P) then - begin - NewCursor := Screen.Cursors[Treeview.Cursor]; - if hoColumnResize in FOptions then - begin - if DetermineSplitterIndex(P) then - NewCursor := Screen.Cursors[crHeaderSplit]; - - Treeview.DoGetHeaderCursor(NewCursor); - Result := NewCursor <> Screen.Cursors[crDefault]; - if Result then - begin - Windows.SetCursor(NewCursor); - Message.Result := 1; - end - 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.FDropTarget := NoColumn; - Invalidate(nil); - Result := True; - Message.Result := 0; - end - else - if hsTracking in FStates then - begin - ReleaseCapture; - Exclude(FStates, hsTracking); - Result := True; - Message.Result := 0; - end; - end; - end; - {$endif} -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 - HeaderR: TRect; - Image: TBitmap; - ImagePos: TPoint; - DragColumn: TVirtualTreeColumn; - -begin - // Determine initial position of drag image (screen coordinates). - FColumns.FDropTarget := NoColumn; - Start := Treeview.ScreenToClient(Start); - Inc(Start.Y, FHeight); - FColumns.FDragIndex := FColumns.ColumnFromPosition(Start); - DragColumn := FColumns[FColumns.FDragIndex]; - - HeaderR := Treeview.FHeaderRect; - - // Set right border of the header rectangle to the maximum extent. - // Adjust top border too, it is already covered elsewhere. - HeaderR.Right := FColumns.TotalWidth; - HeaderR.Top := 0; - - // Take out influence of border since we need a seamless drag image. - OffsetRect(HeaderR, -Treeview.BorderWidth, -Treeview.BorderWidth); - if Treeview.UseRightToLeftAlignment then - Dec(HeaderR.Left, Treeview.ComputeRTLOffset); - - Image := TBitmap.Create; - with Image do - try - PixelFormat := pf32Bit; - Width := DragColumn.Width; - Height := 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)); - - // Now move the window origin of bitmap DC so that although the entire header is painted - // only the dragged column becomes visible. - SetWindowOrgEx(Canvas.Handle, DragColumn.FLeft, 0, nil); - FColumns.PaintHeader(Canvas.Handle, HeaderR, 0); - SetWindowOrgEx(Canvas.Handle, 0, 0, nil); - - 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.UpdateMainColumn; - -// Called once the load process of the owner tree is done. - -begin - if FMainColumn < 0 then - FMainColumn := 0; - if FMainColumn > FColumns.Count - 1 then - FMainColumn := FColumns.Count - 1; -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].FOptions = [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].FOptions = [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].FSpringRest + Difference; - // Set new width if at least one pixel size difference is reached. - if NewAccumulator >= 1 then - FColumns[I].SetWidth(FColumns[I].FWidth + (Trunc(NewAccumulator) * Sign)); - FColumns[I].FSpringRest := 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 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 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; - -//---------------------------------------------------------------------------------------------------------------------- - -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; - 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; - end - else - inherited; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTHeader.AutoFitColumns(Animated: Boolean = True); - -var - I: Integer; - -begin - if Animated then - begin - with FColumns do - for I := 0 to Count - 1 do - if [coResizable, coVisible] * Items[FPositionToIndex[I]].FOptions = [coResizable, coVisible] then - AnimatedResize(FPositionToIndex[I], Treeview.GetMaxColumnWidth(FPositionToIndex[I])) - end - else - begin - with FColumns do - for I := 0 to Count - 1 do - if [coResizable, coVisible] * Items[FPositionToIndex[I]].FOptions = [coResizable, coVisible] then - FColumns[FPositionToIndex[I]].Width := Treeview.GetMaxColumnWidth(FPositionToIndex[I]); - 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.TopLeft, 2); - - // Consider the header within this rectangle. - OffsetRect(R, RW.Left, RW.Top); - Result := PtInRect(R, P); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTHeader.Invalidate(Column: TVirtualTreeColumn; ExpandToBorder: 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 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; - -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 - if UseRightToLeftAlignment then - R.Left := FHeaderRect.Left - else - R.Right := FHeaderRect.Right; - end; - - // 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.TopLeft, 2); - RedrawWindow(Handle, @R, 0, RDW_FRAME or RDW_INVALIDATE or RDW_VALIDATE or RDW_NOINTERNALPAINT or - RDW_NOERASE or RDW_NOCHILDREN); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTHeader.LoadFromStream(const Stream: TStream); - -// restore the state of the header from the given stream - -var - Dummy, - Version: Integer; - S: string; - 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(LongWord(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(PChar(S)^, Dummy); - Name := S; - ReadBuffer(Dummy, SizeOf(Dummy)); - Pitch := TFontPitch(Dummy); - ReadBuffer(Dummy, SizeOf(Dummy)); - Style := TFontStyles(LongWord(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; - finally - Exclude(FStates, hsLoading); - Treeview.DoColumnResize(NoColumn); - 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]].FOptions = [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; - -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 := FBackground; - WriteBuffer(Dummy, SizeOf(Dummy)); - Dummy := FHeight; - WriteBuffer(Dummy, SizeOf(Dummy)); - Dummy := LongWord(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)); - Dummy := Height; - WriteBuffer(Dummy, SizeOf(Dummy)); - Dummy := Length(Name); - WriteBuffer(Dummy, SizeOf(Dummy)); - WriteBuffer(PChar(Name)^, Dummy); - Dummy := Ord(Pitch); - WriteBuffer(Dummy, SizeOf(Dummy)); - // need only to write one: size or height, I decided to write height - Dummy := LongWord(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)); - 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; - //todo_lcl_check - if not (csLoading in FOwner.ComponentState) and FOwner.HandleAllocated then - RecreateWnd(FOwner); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TScrollBarOptions.SetScrollBars(Value: TScrollStyle); - -begin - if FScrollbars <> Value then - begin - FScrollBars := Value; - //todo_lcl_check - if not (csLoading in FOwner.ComponentState) and FOwner.HandleAllocated then - RecreateWnd(FOwner); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TScrollBarOptions.SetScrollBarStyle(Value: TScrollBarStyle); - -begin - {$ifndef UseFlatScrollbars} - Assert(Value = sbmRegular, 'Flat scrollbars styles are disabled. Enable UseFlatScrollbars in VTConfig.inc for' + - 'flat scrollbar support.'); - {$endif UseFlatScrollbars} - - if FScrollBarStyle <> Value then - begin - FScrollBarStyle := Value; - {$ifdef UseFlatScrollbars} - if FOwner.HandleAllocated then - begin - // If set to regular style then don't use the emulation mode of the FlatSB APIs but the original APIs. - // This is necessary because the FlatSB APIs don't respect NC paint request with limited update region - // (which is necessary for the transparent drag image). - FOwner.RecreateWnd; - end; - {$endif UseFlatScrollbars} - 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); - -begin - FOwner := AOwner; - FColors[0] := clBtnShadow; // DisabledColor - FColors[1] := clHighlight; // DropMarkColor - FColors[2] := clHighLight; // DropTargetColor - FColors[3] := clHighLight; // FocusedSelectionColor - FColors[4] := clBtnFace; // GridLineColor - FColors[5] := clBtnShadow; // TreeLineColor - FColors[6] := clBtnFace; // UnfocusedSelectionColor - FColors[7] := clBtnFace; // BorderColor - FColors[8] := clWindowText; // HotColor - FColors[9] := clHighLight; // FocusedSelectionBorderColor - FColors[10] := clBtnFace; // UnfocusedSelectionBorderColor - FColors[11] := clHighlight; // DropTargetBorderColor - FColors[12] := clHighlight; // SelectionRectangleBlendColor - FColors[13] := clHighlight; // SelectionRectangleBorderColor - FColors[14] := clBtnShadow; // HeaderHotColor -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVTColors.GetColor(const Index: Integer): TColor; - -begin - Result := FColors[Index]; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTColors.SetColor(const Index: Integer; 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 - 5: - begin - FOwner.PrepareBitmaps(True, False); - FOwner.Invalidate; - end; - 7: - RedrawWindow(FOwner.Handle, nil, 0, RDW_FRAME or RDW_INVALIDATE or RDW_NOERASE or RDW_NOCHILDREN) - else - FOwner.Invalidate; - end; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTColors.Assign(Source: TPersistent); - -begin - if Source is TVTColors then - begin - FColors := TVTColors(Source).FColors; - if FOwner.FUpdateCount = 0 then - FOwner.Invalidate; - end - else - inherited; -end; - -//----------------- TClipboardFormats ---------------------------------------------------------------------------------- - -constructor TClipboardFormats.Create(AOwner: TBaseVirtualTree); - -begin - FOwner := AOwner; - Sorted := True; - Duplicates := dupIgnore; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TClipboardFormats.Add(const S: string): Integer; - -// Restrict additions to the clipbard formats to only those which are registered with the owner tree or one of its -// ancestors. - -var - Format: Word; - RegisteredClass: TVirtualTreeClass; - -begin - RegisteredClass := InternalClipboardFormats.FindFormat(S, Format); - if Assigned(RegisteredClass) and FOwner.ClassType.InheritsFrom(RegisteredClass) then - Result := inherited Add(S) - else - Result := -1; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TClipboardFormats.Insert(Index: Integer; const S: string); - -// Restrict additions to the clipbard formats to only those which are registered with the owner tree or one of its -// ancestors. - -var - Format: Word; - RegisteredClass: TVirtualTreeClass; - -begin - RegisteredClass := InternalClipboardFormats.FindFormat(S, Format); - if Assigned(RegisteredClass) and FOwner.ClassType.InheritsFrom(RegisteredClass) then - inherited Insert(Index, S); -end; - -//----------------- TBaseVirtualTree ----------------------------------------------------------------------------------- - -constructor TBaseVirtualTree.Create(AOwner: TComponent); - -begin - if not Initialized then - InitializeGlobalStructures; - - inherited; - - ControlStyle := ControlStyle - [csSetCaption] + [csCaptureMouse, csOpaque, csReplicatable, csDisplayDragImage, - csReflector]; - FTotalInternalDataSize := 0; - FNodeDataSize := -1; - Width := 200; - Height := 100; - TabStop := True; - ParentColor := False; - FDefaultNodeHeight := 18; - FDragOperations := [doCopy, doMove]; - FHotCursor := crDefault; - FScrollBarOptions := TScrollBarOptions.Create(Self); - FFocusedColumn := NoColumn; - FDragImageKind := diComplete; - FLastSelectionLevel := -1; - FAnimationType := hatSystemDefault; - FSelectionBlendFactor := 128; - - FIndent := 18; - - FPlusBM := TBitmap.Create; - FMinusBM := TBitmap.Create; - - FBorderStyle := bsSingle; - FButtonStyle := bsRectangle; - FButtonFillMode := fmTreeColor; - - FHeader := GetHeaderClass.Create(Self); - - // we have an own double buffer handling - DoubleBuffered := False; - - FCheckImageKind := ckLightCheck; - FCheckImages := LightCheckImages; - - FImageChangeLink := TChangeLink.Create; - FImageChangeLink.OnChange := ImageListChange; - FStateChangeLink := TChangeLink.Create; - FStateChangeLink.OnChange := ImageListChange; - FCustomCheckChangeLink := TChangeLink.Create; - FCustomCheckChangeLink.OnChange := ImageListChange; - - FAutoExpandDelay := 1000; - FAutoScrollDelay := 1000; - FAutoScrollInterval := 1; - - FBackground := TPicture.Create; - - FDefaultPasteMode := amAddChildLast; - FMargin := 4; - FTextMargin := 4; - FDragType := dtOLE; - FDragHeight := 350; - FDragWidth := 200; - - FColors := TVTColors.Create(Self); - FEditDelay := 1000; - - FDragImage := TVTDragImage.Create(Self); - with FDragImage do - begin - Fade := True; - PostBlendBias := 0; - PreBlendBias := 0; - Transparency := 200; - end; - - SetLength(FSingletonNodeArray, 1); - FAnimationDuration := 200; - FSearchTimeout := 1000; - FSearchStart := ssFocusedNode; - FNodeAlignment := naProportional; - FLineStyle := lsDotted; - FIncrementalSearch := isNone; - FClipboardFormats := TClipboardFormats.Create(Self); - FOptions := GetOptionsClass.Create(Self); - - {$ifdef UseLocalMemoryManager} - FNodeMemoryManager := TVTNodeMemoryManager.Create; - {$endif UseLocalMemoryManager} - - AddThreadReference; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -destructor TBaseVirtualTree.Destroy; - -begin - Exclude(FOptions.FMiscOptions, toReadOnly); - ReleaseThreadReference(Self); - StopWheelPanning; - CancelEditNode; - - // Just in case it didn't happen already release the edit link. - FEditLink := nil; - FClipboardFormats.Free; - // Clear will also free the drag manager if it is still alive. - Clear; - FDragImage.Free; - FColors.Free; - FBackground.Free; - FImageChangeLink.Free; - FStateChangeLink.Free; - FCustomCheckChangeLink.Free; - FScrollBarOptions.Free; - FOptions.Free; - - // The window handle must be destroyed before the header is freed because it is needed in WM_NCDESTROY. - //todo_lcl_check - { - if HandleAllocated then - DestroyWindowHandle; - } - FHeader.Free; - FHeader := nil; - - FreeMem(FRoot); - - {$ifdef UseLocalMemoryManager} - FNodeMemoryManager.Free; - {$endif UseLocalMemoryManager} - FPlusBM.Free; - FMinusBM.Free; - - inherited; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.AdjustCoordinatesByIndent(var PaintInfo: TVTPaintInfo; Indent: Integer); - -// During painting of the main column some coordinates must be adjusted due to the tree lines. -// The offset resulting from the tree lines and indentation level is given in Indent. - -var - Offset: Integer; - -begin - with PaintInfo do - begin - Offset := Indent * Integer(FIndent); - if BidiMode = bdLeftToRight then - begin - Inc(ContentRect.Left, Offset); - Inc(ImageInfo[iiNormal].XPos, Offset); - Inc(ImageInfo[iiState].XPos, Offset); - Inc(ImageInfo[iiCheck].XPos, Offset); - end - else - begin - Dec(ContentRect.Right, Offset); - Dec(ImageInfo[iiNormal].XPos, Offset); - Dec(ImageInfo[iiState].XPos, Offset); - Dec(ImageInfo[iiCheck].XPos, Offset); - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.AdjustImageBorder(Images: TCustomImageList; BidiMode: TBidiMode; VAlign: Integer; var R: TRect; - var ImageInfo: TVTImageInfo); - -// Depending on the width of the image list as well as the given bidi mode R must be adjusted. - -begin - if BidiMode = bdLeftToRight then - begin - ImageInfo.XPos := R.Left; - Inc(R.Left, Images.Width + 2); - end - else - begin - ImageInfo.XPos := R.Right - Images.Width; - Dec(R.Right, Images.Width + 2); - end; - ImageInfo.YPos := R.Top + VAlign - Images.Height div 2; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.AdjustTotalCount(Node: PVirtualNode; Value: Integer; relative: Boolean = False); - -// Sets a node's total count to the given value and recursively adjusts the parent's total count -// (actually, the adjustment is done iteratively to avoid function call overheads). - -var - Difference: Integer; - Run: PVirtualNode; - -begin - if relative then - Difference := Value - else - Difference := Integer(Value) - Integer(Node.TotalCount); - if Difference <> 0 then - begin - Run := Node; - // Root node has as parent the tree view. - while Assigned(Run) and (Run <> Pointer(Self)) do - begin - Inc(Integer(Run.TotalCount), Difference); - Run := Run.Parent; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.AdjustTotalHeight(Node: PVirtualNode; Value: Integer; relative: Boolean = False); - -// Sets a node's total height to the given value and recursively adjusts the parent's total height. - -var - Difference: Integer; - Run: PVirtualNode; - -begin - if relative then - Difference := Value - else - Difference := Integer(Value) - Integer(Node.TotalHeight); - if Difference <> 0 then - begin - Run := Node; - repeat - Inc(Integer(Run.TotalHeight), Difference); - // If the node is not visible or the parent node is not expanded or we are already at the top - // then nothing more remains to do. - if not (vsVisible in Run.States) or (Run = FRoot) or - (Run.Parent = nil) or not (vsExpanded in Run.Parent.States) then - Break; - - Run := Run.Parent; - until False; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.CalculateCacheEntryCount: Integer; - -// Calculates the size of the position cache. - -begin - if FVisibleCount > 1 then - Result := Ceil(FVisibleCount / CacheThreshold) - else - Result := 0; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.CalculateVerticalAlignments(ShowImages, ShowStateImages: Boolean; Node: PVirtualNode; - var VAlign, VButtonAlign: Integer); - -// Calculates the vertical alignment of the given node and its associated expand/collapse button during -// a node paint cycle depending on the required node alignment style. - -begin - // For absolute alignment the calculation is trivial. - case FNodeAlignment of - naFromTop: - VAlign := Node.Align; - naFromBottom: - VAlign := NodeHeight[Node] - Node.Align; - else // naProportional - // Consider button and line alignment, but make sure neither the image nor the button (whichever is taller) - // go out of the entire node height (100% means bottom alignment to the node's bounds). - if ShowImages or ShowStateImages then - begin - if ShowImages then - VAlign := FImages.Height - else - VAlign := FStateImages.Height; - VAlign := MulDiv((Integer(NodeHeight[Node]) - VAlign), Node.Align, 100) + VAlign div 2; - end - else - if toShowButtons in FOptions.FPaintOptions then - VAlign := MulDiv((Integer(NodeHeight[Node]) - FPlusBM.Height), Node.Align, 100) + FPlusBM.Height div 2 - else - VAlign := MulDiv(Node.NodeHeight, Node.Align, 100); - end; - - VButtonAlign := VAlign - FPlusBM.Height div 2; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.ChangeCheckState(Node: PVirtualNode; Value: TCheckState): Boolean; - -// Sets the check state of the node according to the given value and the node's check type. -// If the check state must be propagated to the parent nodes and one of them refuses to change then -// nothing happens and False is returned, otherwise True. - -var - Run: PVirtualNode; - UncheckedCount, - MixedCheckCount, - CheckedCount: Cardinal; - -begin - Result := not (vsChecking in Node.States); - with Node^ do - if Result then - begin - Include(States, vsChecking); - if not (vsInitialized in States) then - InitNode(Node); - - // Indicate that we are going to propagate check states up and down the hierarchy. - if FCheckPropagationCount = 0 then // WL, 05.02.2004: Do not enter tsCheckPropagation more than once - DoStateChange([tsCheckPropagation]); - Inc(FCheckPropagationCount); // WL, 05.02.2004 - // Do actions which are associated with the given check state. - case CheckType of - // Check state change with additional consequences for check states of the children. - ctTriStateCheckBox: - begin - // Propagate state down to the children. - if toAutoTristateTracking in FOptions.FAutoOptions then - case Value of - csUncheckedNormal: - if Node.ChildCount > 0 then - begin - Run := FirstChild; - CheckedCount := 0; - MixedCheckCount := 0; - UncheckedCount := 0; - while Assigned(Run) do - begin - if Run.CheckType in [ctCheckBox, ctTriStateCheckBox] then - begin - SetCheckState(Run, csUncheckedNormal); - // Check if the new child state was set successfully, otherwise we have to adjust the - // node's new check state accordingly. - case Run.CheckState of - csCheckedNormal: - Inc(CheckedCount); - csMixedNormal: - Inc(MixedCheckCount); - csUncheckedNormal: - Inc(UncheckedCount); - end; - end; - Run := Run.NextSibling; - end; - - // If there is still a mixed state child node checkbox then this node must be mixed checked too. - if MixedCheckCount > 0 then - Value := csMixedNormal - else - // If nodes are normally checked child nodes then the unchecked count determines what - // to set for the node itself. - if CheckedCount > 0 then - if UncheckedCount > 0 then - Value := csMixedNormal - else - Value := csCheckedNormal; - end; - csCheckedNormal: - if Node.ChildCount > 0 then - begin - Run := FirstChild; - CheckedCount := 0; - MixedCheckCount := 0; - UncheckedCount := 0; - while Assigned(Run) do - begin - if Run.CheckType in [ctCheckBox, ctTriStateCheckBox] then - begin - SetCheckState(Run, csCheckedNormal); - // Check if the new child state was set successfully, otherwise we have to adjust the - // node's new check state accordingly. - case Run.CheckState of - csCheckedNormal: - Inc(CheckedCount); - csMixedNormal: - Inc(MixedCheckCount); - csUncheckedNormal: - Inc(UncheckedCount); - end; - end; - Run := Run.NextSibling; - end; - - // If there is still a mixed state child node checkbox then this node must be mixed checked too. - if MixedCheckCount > 0 then - Value := csMixedNormal - else - // If nodes are normally checked child nodes then the unchecked count determines what - // to set for the node itself. - if CheckedCount > 0 then - if UncheckedCount > 0 then - Value := csMixedNormal - else - Value := csCheckedNormal; - end; - end; - end; - // radio button check state change - ctRadioButton: - if Value = csCheckedNormal then - begin - Value := csCheckedNormal; - // Make sure only this node is checked. - Run := Parent.FirstChild; - while Assigned(Run) do - begin - if Run.CheckType = ctRadioButton then - Run.CheckState := csUncheckedNormal; - Run := Run.NextSibling; - end; - Invalidate; - end; - end; - - if Result then - CheckState := Value // Set new check state - else - CheckState := UnpressedState[CheckState]; // Reset dynamic check state. - - // Propagate state up to the parent. - if not (vsInitialized in Parent.States) then - InitNode(Parent); - if (toAutoTristateTracking in FOptions.FAutoOptions) and ([vsChecking, vsDisabled] * Parent.States = []) and - (CheckType in [ctCheckBox, ctTriStateCheckBox]) and (Parent <> FRoot) and - (Parent.CheckType = ctTriStateCheckBox) then - Result := CheckParentCheckState(Node, Value) - else - Result := True; - - InvalidateNode(Node); - Exclude(States, vsChecking); - - Dec(FCheckPropagationCount); // WL, 05.02.2004 - if FCheckPropagationCount = 0 then // WL, 05.02.2004: Allow state change event after all check operations finished - DoStateChange([], [tsCheckPropagation]); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.CollectSelectedNodesLTR(MainColumn, NodeLeft, NodeRight: Integer; Alignment: TAlignment; - OldRect, NewRect: TRect): Boolean; - -// Helper routine used when a draw selection takes place. This version handles left-to-right directionality. -// In the process of adding or removing nodes the current selection is modified which requires to pack it after -// the function returns. Another side effect of this method is that a temporary list of nodes will be created -// (see also InternalCacheNode) which must be inserted into the current selection by the caller. - -var - Run, - NextNode: PVirtualNode; - TextRight, - TextLeft, - CheckOffset, - CurrentTop, - CurrentRight, - NextTop, - NextColumn, - NodeWidth, - Dummy: Integer; - MinY, MaxY: Integer; - ImageOffset, - StateImageOffset: Integer; - IsInOldRect, - IsInNewRect: Boolean; - - // quick check variables for various parameters - WithCheck, - WithImages, - WithStateImages, - DoSwitch, - AutoSpan: Boolean; - SimpleSelection: Boolean; - -begin - // A priori nothing changes. - Result := False; - - // If the old rectangle is empty then we just started the drag selection. - // So we just copy the new rectangle to the old and get out of here. - if IsRectEmpty(OldRect) then - OldRect := NewRect - else - begin - // Determine minimum and maximum vertical coordinates to limit iteration to. - MinY := Min(OldRect.Top, NewRect.Top); - MaxY := Max(OldRect.Bottom, NewRect.Bottom); - - // Initialize short hand variables to speed up tests below. - DoSwitch := ssCtrl in FDrawSelShiftState; - WithCheck := (toCheckSupport in FOptions.FMiscOptions) and Assigned(FCheckImages); - // Don't check the events here as descendant trees might have overriden the DoGetImageIndex method. - WithImages := Assigned(FImages); - if WithImages then - ImageOffset := FImages.Width + 2 - else - ImageOffset := 0; - WithStateImages := Assigned(FStateImages); - if WithStateImages then - StateImageOffset := FStateImages.Width + 2 - else - StateImageOffset := 0; - if WithCheck then - CheckOffset := FCheckImages.Width + 2 - else - CheckOffset := 0; - AutoSpan := FHeader.UseColumns and (toAutoSpanColumns in FOptions.FAutoOptions); - SimpleSelection := toSimpleDrawSelection in FOptions.FSelectionOptions; - - // This is the node to start with. - Run := GetNodeAt(0, MinY, False, CurrentTop); - - if Assigned(Run) then - begin - // The initial minimal left border is determined by the identation level of the node and is dynamically adjusted. - if toShowRoot in FOptions.FPaintOptions then - Inc(NodeLeft, Integer((GetNodeLevel(Run) + 1) * FIndent) + FMargin) - else - Inc(NodeLeft, Integer(GetNodeLevel(Run) * FIndent) + FMargin); - - // ----- main loop - // Change selection depending on the node's rectangle being in the selection rectangle or not, but - // touch only those nodes which overlap either the old selection rectangle or the new one but not both. - repeat - // Collect offsets for check, normal and state images. - TextLeft := NodeLeft; - if WithCheck and (Run.CheckType <> ctNone) then - Inc(TextLeft, CheckOffset); - if WithImages and HasImage(Run, ikNormal, MainColumn) then - Inc(TextLeft, ImageOffset); - if WithStateImages and HasImage(Run, ikState, MainColumn) then - Inc(TextLeft, StateImageOffset); - - // Ensure the node's height is determined. - MeasureItemHeight(Canvas, Run); - - NextTop := CurrentTop + Integer(NodeHeight[Run]); - - // Simple selection allows to draw the selection rectangle anywhere. No intersection with node captions is - // required. Only top and bottom bounds of the rectangle matter. - if SimpleSelection then - begin - IsInOldRect := (NextTop > OldRect.Top) and (CurrentTop < OldRect.Bottom); - IsInNewRect := (NextTop > NewRect.Top) and (CurrentTop < NewRect.Bottom); - end - else - begin - // The right column border might be extended if column spanning is enabled. - if AutoSpan then - begin - with FHeader.FColumns do - begin - NextColumn := MainColumn; - repeat - Dummy := GetNextVisibleColumn(NextColumn); - if (Dummy = InvalidColumn) or not ColumnIsEmpty(Run, Dummy) or - (Items[Dummy].BidiMode <> bdLeftToRight) then - Break; - NextColumn := Dummy; - until False; - if NextColumn = MainColumn then - CurrentRight := NodeRight - else - GetColumnBounds(NextColumn, Dummy, CurrentRight); - end; - end - else - CurrentRight := NodeRight; - - // Check if we need the node's width. This is the case when the node is not left aligned or the - // left border of the selection rectangle is to the right of the left node border. - if (TextLeft < OldRect.Left) or (TextLeft < NewRect.Left) or (Alignment <> taLeftJustify) then - begin - NodeWidth := DoGetNodeWidth(Run, MainColumn); - if NodeWidth >= (CurrentRight - TextLeft) then - TextRight := CurrentRight - else - case Alignment of - taLeftJustify: - TextRight := TextLeft + NodeWidth; - taCenter: - begin - TextLeft := (TextLeft + CurrentRight - NodeWidth) div 2; - TextRight := TextLeft + NodeWidth; - end; - else - // taRightJustify - TextRight := CurrentRight; - TextLeft := TextRight - NodeWidth; - end; - end - else - TextRight := CurrentRight; - - // Now determine whether we need to change the state. - IsInOldRect := (OldRect.Left <= TextRight) and (OldRect.Right >= TextLeft) and - (NextTop > OldRect.Top) and (CurrentTop < OldRect.Bottom); - IsInNewRect := (NewRect.Left <= TextRight) and (NewRect.Right >= TextLeft) and - (NextTop > NewRect.Top) and (CurrentTop < NewRect.Bottom); - end; - - if IsInOldRect xor IsInNewRect then - begin - Result := True; - if DoSwitch then - begin - if vsSelected in Run.States then - InternalRemoveFromSelection(Run) - else - InternalCacheNode(Run); - end - else - begin - if IsInNewRect then - InternalCacheNode(Run) - else - InternalRemoveFromSelection(Run); - end; - end; - - CurrentTop := NextTop; - // Get next visible node and update left node position. - NextNode := GetNextVisibleNoInit(Run); - if NextNode = nil then - Break; - Inc(NodeLeft, CountLevelDifference(Run, NextNode) * Integer(FIndent)); - Run := NextNode; - until CurrentTop > MaxY; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.CollectSelectedNodesRTL(MainColumn, NodeLeft, NodeRight: Integer; Alignment: TAlignment; - OldRect, NewRect: TRect): Boolean; - -// Helper routine used when a draw selection takes place. This version handles right-to-left directionality. -// See also comments in CollectSelectedNodesLTR. - -var - Run, - NextNode: PVirtualNode; - TextRight, - TextLeft, - CheckOffset, - CurrentTop, - CurrentLeft, - NextTop, - NextColumn, - NodeWidth, - Dummy: Integer; - MinY, MaxY: Integer; - ImageOffset, - StateImageOffset: Integer; - IsInOldRect, - IsInNewRect: Boolean; - - // quick check variables for various parameters - WithCheck, - WithImages, - WithStateImages, - DoSwitch, - AutoSpan: Boolean; - SimpleSelection: Boolean; - -begin - // A priori nothing changes. - Result := False; - // Switch the alignment to the opposite value in RTL context. - ChangeBiDiModeAlignment(Alignment); - - // If the old rectangle is empty then we just started the drag selection. - // So we just copy the new rectangle to the old and get out of here. - if IsRectEmpty(OldRect) then - OldRect := NewRect - else - begin - // Determine minimum and maximum vertical coordinates to limit iteration to. - MinY := Min(OldRect.Top, NewRect.Top); - MaxY := Max(OldRect.Bottom, NewRect.Bottom); - - // Initialize short hand variables to speed up tests below. - DoSwitch := ssCtrl in FDrawSelShiftState; - WithCheck := (toCheckSupport in FOptions.FMiscOptions) and Assigned(FCheckImages); - // Don't check the events here as descendant trees might have overriden the DoGetImageIndex method. - WithImages := Assigned(FImages); - if WithImages then - ImageOffset := FImages.Width + 2 - else - ImageOffset := 0; - WithStateImages := Assigned(FStateImages); - if WithStateImages then - StateImageOffset := FStateImages.Width + 2 - else - StateImageOffset := 0; - if WithCheck then - CheckOffset := FCheckImages.Width + 2 - else - CheckOffset := 0; - AutoSpan := FHeader.UseColumns and (toAutoSpanColumns in FOptions.FAutoOptions); - SimpleSelection := toSimpleDrawSelection in FOptions.FSelectionOptions; - - // This is the node to start with. - Run := GetNodeAt(0, MinY, False, CurrentTop); - - if Assigned(Run) then - begin - // The initial minimal left border is determined by the identation level of the node and is dynamically adjusted. - if toShowRoot in FOptions.FPaintOptions then - Dec(NodeRight, Integer((GetNodeLevel(Run) + 1) * FIndent) + FMargin) - else - Dec(NodeRight, Integer(GetNodeLevel(Run) * FIndent) + FMargin); - - // ----- main loop - // Change selection depending on the node's rectangle being in the selection rectangle or not, but - // touch only those nodes which overlap either the old selection rectangle or the new one but not both. - repeat - // Collect offsets for check, normal and state images. - TextRight := NodeRight; - if WithCheck and (Run.CheckType <> ctNone) then - Dec(TextRight, CheckOffset); - if WithImages and HasImage(Run, ikNormal, MainColumn) then - Dec(TextRight, ImageOffset); - if WithStateImages and HasImage(Run, ikState, MainColumn) then - Dec(TextRight, StateImageOffset); - - // Ensure the node's height is determined. - MeasureItemHeight(Canvas, Run); - - NextTop := CurrentTop + Integer(NodeHeight[Run]); - - // Simple selection allows to draw the selection rectangle anywhere. No intersection with node captions is - // required. Only top and bottom bounds of the rectangle matter. - if SimpleSelection then - begin - IsInOldRect := (NextTop > OldRect.Top) and (CurrentTop < OldRect.Bottom); - IsInNewRect := (NextTop > NewRect.Top) and (CurrentTop < NewRect.Bottom); - end - else - begin - // The left column border might be extended if column spanning is enabled. - if AutoSpan then - begin - NextColumn := MainColumn; - repeat - Dummy := FHeader.FColumns.GetPreviousVisibleColumn(NextColumn); - if (Dummy = InvalidColumn) or not ColumnIsEmpty(Run, Dummy) or - (FHeader.FColumns[Dummy].BiDiMode = bdLeftToRight) then - Break; - NextColumn := Dummy; - until False; - if NextColumn = MainColumn then - CurrentLeft := NodeLeft - else - FHeader.FColumns.GetColumnBounds(NextColumn, CurrentLeft, Dummy); - end - else - CurrentLeft := NodeLeft; - - // Check if we need the node's width. This is the case when the node is not left aligned (in RTL context this - // means actually right aligned) or the right border of the selection rectangle is to the left - // of the right node border. - if (TextRight > OldRect.Right) or (TextRight > NewRect.Right) or (Alignment <> taRightJustify) then - begin - NodeWidth := DoGetNodeWidth(Run, MainColumn); - if NodeWidth >= (TextRight - CurrentLeft) then - TextLeft := CurrentLeft - else - case Alignment of - taLeftJustify: - begin - TextLeft := CurrentLeft; - TextRight := TextLeft + NodeWidth; - end; - taCenter: - begin - TextLeft := (TextRight + CurrentLeft - NodeWidth) div 2; - TextRight := TextLeft + NodeWidth; - end; - else - // taRightJustify - TextLeft := TextRight - NodeWidth; - end; - end - else - TextLeft := CurrentLeft; - - // Now determine whether we need to change the state. - IsInOldRect := (OldRect.Right >= TextLeft) and (OldRect.Left <= TextRight) and - (NextTop > OldRect.Top) and (CurrentTop < OldRect.Bottom); - IsInNewRect := (NewRect.Right >= TextLeft) and (NewRect.Left <= TextRight) and - (NextTop > NewRect.Top) and (CurrentTop < NewRect.Bottom); - end; - - if IsInOldRect xor IsInNewRect then - begin - Result := True; - if DoSwitch then - begin - if vsSelected in Run.States then - InternalRemoveFromSelection(Run) - else - InternalCacheNode(Run); - end - else - begin - if IsInNewRect then - InternalCacheNode(Run) - else - InternalRemoveFromSelection(Run); - end; - end; - - CurrentTop := NextTop; - // Get next visible node and update left node position. - NextNode := GetNextVisibleNoInit(Run); - if NextNode = nil then - Break; - Dec(NodeRight, CountLevelDifference(Run, NextNode) * Integer(FIndent)); - Run := NextNode; - until CurrentTop > MaxY; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.ClearNodeBackground(const PaintInfo: TVTPaintInfo; UseBackground, Floating: Boolean; - R: TRect); - -// Erases a node's background depending on what the application decides to do. -// UseBackground determines whether or not to use the background picture, while Floating indicates -// that R is given in coordinates of the small node bitmap or the superordinated target bitmap used in PaintTree. - -var - BackColor: TColor; - EraseAction: TItemEraseAction; - Offset: TPoint; - -begin - Logger.EnterMethod(lcPaintDetails,'ClearNodeBackground'); - with PaintInfo do - begin - EraseAction := eaDefault; - BackColor := Color; - if Floating then - begin - Offset := Point(-FEffectiveOffsetX, R.Top); - OffsetRect(R, 0, -Offset.Y); - end - else - Offset := Point(0, 0); - - DoBeforeItemErase(Canvas, Node, R, Backcolor, EraseAction); - - with Canvas do - begin - case EraseAction of - eaNone: - ; - eaColor: - begin - // User has given a new background color. - Brush.Color := BackColor; - FillRect(R); - end; - else // eaDefault - if UseBackground then - begin - if toStaticBackground in TreeOptions.PaintOptions then - StaticBackground(FBackground.Bitmap, Canvas, Offset, R) - else - TileBackground(FBackground.Bitmap, Canvas, Offset, R); - end - else - begin - if (poDrawSelection in PaintOptions) and (toFullRowSelect in FOptions.FSelectionOptions) and - (vsSelected in Node.States) and not (toUseBlendedSelection in FOptions.PaintOptions) then - begin - Logger.Send(lcPaintDetails,'Setting the color of a selected node'); - if toShowHorzGridLines in FOptions.PaintOptions then - Dec(R.Bottom); - if Focused or (toPopupMode in FOptions.FPaintOptions) then - begin - Brush.Color := FColors.FocusedSelectionColor; - Pen.Color := FColors.FocusedSelectionBorderColor; - end - else - begin - Brush.Color := FColors.UnfocusedSelectionColor; - Pen.Color := FColors.UnfocusedSelectionBorderColor; - end; - - with R do - RoundRect(Left, Top, Right, Bottom, FSelectionCurveRadius, FSelectionCurveRadius); - end - else - begin - Brush.Color := Self.Color; - Logger.Send(lcPaintDetails,'Setting the color of a NOT selected node - Brush.Color',Brush.Color); - FillRect(R); - end; - end; - end; - DoAfterItemErase(Canvas, Node, R); - end; - end; - Logger.ExitMethod(lcPaintDetails,'ClearNodeBackground'); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.CompareNodePositions(Node1, Node2: PVirtualNode): Integer; - -// Tries hard and smart to quickly determine whether Node1's structural position is before Node2's position -// Returns 0 if Node1 = Node2, < 0 if Node1 is located before Node2 else > 0. - -var - Run1, - Run2: PVirtualNode; - Level1, - Level2: Cardinal; - -begin - Assert(Assigned(Node1) and Assigned(Node2), 'Nodes must never be nil.'); - - if Node1 = Node2 then - Result := 0 - else - begin - if HasAsParent(Node1, Node2) then - Result := 1 - else - if HasAsParent(Node2, Node1) then - Result := -1 - else - begin - // the given nodes are neither equal nor are they parents of each other, so go up to FRoot - // for each node and compare the child indices of the top level parents - // Note: neither Node1 nor Node2 can be FRoot at this point as this (a bit strange) circumstance would - // be caught by the previous code. - - // start lookup at the same level - Level1 := GetNodeLevel(Node1); - Level2 := GetNodeLevel(Node2); - Run1 := Node1; - while Level1 > Level2 do - begin - Run1 := Run1.Parent; - Dec(Level1); - end; - Run2 := Node2; - while Level2 > Level1 do - begin - Run2 := Run2.Parent; - Dec(Level2); - end; - - // now go up until we find a common parent node (loop will safely stop at FRoot if the nodes - // don't share a common parent) - while Run1.Parent <> Run2.Parent do - begin - Run1 := Run1.Parent; - Run2 := Run2.Parent; - end; - Result := Integer(Run1.Index) - Integer(Run2.Index); - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DrawLineImage(const PaintInfo: TVTPaintInfo; X, Y, H, VAlign: Integer; Style: TVTLineType; - Reverse: Boolean); - -// Draws (depending on Style) one of the 5 line types of the tree. -// If Reverse is True then a right-to-left column is being drawn, hence horizontal lines must be mirrored. -// X and Y describe the left upper corner of the line image rectangle, while H denotes its height (and width). - -var - HalfWidth, - TargetX: Integer; - -begin - HalfWidth := Integer(FIndent) div 2; - if Reverse then - TargetX := 0 - else - TargetX := FIndent; - - with PaintInfo.Canvas do - begin - case Style of - ltBottomRight: - begin - DrawDottedVLine(PaintInfo, Y + VAlign, Y + H, X + HalfWidth); - DrawDottedHLine(PaintInfo, X + HalfWidth, X + TargetX, Y + VAlign); - end; - ltTopDown: - DrawDottedVLine(PaintInfo, Y, Y + H, X + HalfWidth); - ltTopDownRight: - begin - DrawDottedVLine(PaintInfo, Y, Y + H, X + HalfWidth); - DrawDottedHLine(PaintInfo, X + HalfWidth, X + TargetX, Y + VAlign); - end; - ltRight: - DrawDottedHLine(PaintInfo, X + HalfWidth, X + TargetX, Y + VAlign); - ltTopRight: - begin - DrawDottedVLine(PaintInfo, Y, Y + VAlign, X + HalfWidth); - DrawDottedHLine(PaintInfo, X + HalfWidth, X + TargetX, Y + VAlign); - end; - ltLeft: // left can also mean right for RTL context - if Reverse then - DrawDottedVLine(PaintInfo, Y, Y + H, X + Integer(FIndent)) - else - DrawDottedVLine(PaintInfo, Y, Y + H, X); - ltLeftBottom: - if Reverse then - begin - DrawDottedVLine(PaintInfo, Y, Y + H, X + Integer(FIndent)); - DrawDottedHLine(PaintInfo, X, X + Integer(FIndent), Y + H); - end - else - begin - DrawDottedVLine(PaintInfo, Y, Y + H, X); - DrawDottedHLine(PaintInfo, X, X + Integer(FIndent), Y + H); - end; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.FindInPositionCache(Node: PVirtualNode; var CurrentPos: Cardinal): PVirtualNode; - -// Looks through the position cache and returns the node whose top position is the largest one which is smaller or equal -// to the position of the given node. - -var - L, H, I: Integer; - -begin - L := 0; - H := High(FPositionCache); - while L <= H do - begin - I := (L + H) shr 1; - if CompareNodePositions(FPositionCache[I].Node, Node) <= 0 then - L := I + 1 - else - H := I - 1; - end; - Result := FPositionCache[L - 1].Node; - CurrentPos := FPositionCache[L - 1].AbsoluteTop; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.FindInPositionCache(Position: Cardinal; var CurrentPos: Cardinal): PVirtualNode; - -// Looks through the position cache and returns the node whose top position is the largest one which is smaller or equal -// to the given vertical position. -// The returned node does not necessarily occupy the given position but is the nearest one to start -// iterating from to approach the real node for a given position. CurrentPos receives the actual position of the found -// node which is needed for further iteration. - -var - L, H, I: Integer; - -begin - L := 0; - H := High(FPositionCache); - while L <= H do - begin - I := (L + H) shr 1; - if FPositionCache[I].AbsoluteTop <= Position then - L := I + 1 - else - H := I - 1; - end; - Result := FPositionCache[L - 1].Node; - CurrentPos := FPositionCache[L - 1].AbsoluteTop; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.FixupTotalCount(Node: PVirtualNode); - -// Called after loading a subtree from stream. The child count in each node is already set but not -// their total count. - -var - Child: PVirtualNode; - -begin - // Initial total count is set to one on node creation. - Child := Node.FirstChild; - while Assigned(Child) do - begin - FixupTotalCount(Child); - Inc(Node.TotalCount, Child.TotalCount); - Child := Child.NextSibling; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.FixupTotalHeight(Node: PVirtualNode); - -// Called after loading a subtree from stream. The individual height of each node is set already, -// but their total height needs an adjustment depending on their visibility state. - -var - Child: PVirtualNode; - -begin - // Initial total height is set to the node height on load. - Child := Node.FirstChild; - - if vsExpanded in Node.States then - begin - while Assigned(Child) do - begin - FixupTotalHeight(Child); - if vsVisible in Child.States then - Inc(Node.TotalHeight, Child.TotalHeight); - Child := Child.NextSibling; - end; - end - else - begin - // The node is collapsed, so just update the total height of its child nodes. - while Assigned(Child) do - begin - FixupTotalHeight(Child); - Child := Child.NextSibling; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetCheckState(Node: PVirtualNode): TCheckState; - -begin - Result := Node.CheckState; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetCheckType(Node: PVirtualNode): TCheckType; - -begin - Result := Node.CheckType; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetChildCount(Node: PVirtualNode): Cardinal; - -begin - if (Node = nil) or (Node = FRoot) then - Result := FRoot.ChildCount - else - Result := Node.ChildCount; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetChildrenInitialized(Node: PVirtualNode): Boolean; - -begin - Result := not (vsHasChildren in Node.States) or (Node.ChildCount > 0); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetDisabled(Node: PVirtualNode): Boolean; - -begin - Result := Assigned(Node) and (vsDisabled in Node.States); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetDragManager: IVTDragManager; - -// Returns the internal drag manager interface. If this does not yet exist then it is created here. - -begin - if FDragManager = nil then - begin - FDragManager := DoCreateDragManager; - if FDragManager = nil then - FDragManager := TVTDragManager.Create(Self); - end; - - Result := FDragManager; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetExpanded(Node: PVirtualNode): Boolean; - -begin - if Assigned(Node) then - Result := vsExpanded in Node.States - else - Result := False; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetFullyVisible(Node: PVirtualNode): Boolean; - -// Determines whether the given node has the visibility flag set as well as all its parents are expanded. - -begin - Assert(Assigned(Node), 'Invalid parameter.'); - Result := vsVisible in Node.States; - if Result and (Node <> FRoot) then - Result := VisiblePath[Node]; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetHasChildren(Node: PVirtualNode): Boolean; - -begin - if Assigned(Node) then - Result := vsHasChildren in Node.States - else - Result := vsHasChildren in FRoot.States; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetMultiline(Node: PVirtualNode): Boolean; - -begin - Result := Assigned(Node) and (Node <> FRoot) and (vsMultiline in Node.States); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetNodeHeight(Node: PVirtualNode): Cardinal; - -begin - if Assigned(Node) and (Node <> FRoot) then - begin - if toVariableNodeHeight in FOptions.FMiscOptions then - begin - if not (vsInitialized in Node.States) then - InitNode(Node); - - // Ensure the node's height is determined. - MeasureItemHeight(Canvas, Node); - end; - Result := Node.NodeHeight - end - else - Result := 0; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetNodeParent(Node: PVirtualNode): PVirtualNode; - -begin - if Assigned(Node) and (Node.Parent <> FRoot) then - Result := Node.Parent - else - Result := nil; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetOffsetXY: TPoint; - -begin - Result := Point(FOffsetX, FOffsetY); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetRootNodeCount: Cardinal; - -begin - Result := FRoot.ChildCount; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetSelected(Node: PVirtualNode): Boolean; - -begin - Result := Assigned(Node) and (vsSelected in Node.States); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetTopNode: PVirtualNode; - -var - Dummy: Integer; - -begin - Result := GetNodeAt(0, 0, True, Dummy); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetTotalCount: Cardinal; - -begin - Inc(FUpdateCount); - try - ValidateNode(FRoot, True); - finally - Dec(FUpdateCount); - end; - // The root node itself doesn't count as node. - Result := FRoot.TotalCount - 1; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetVerticalAlignment(Node: PVirtualNode): Byte; - -begin - Result := Node.Align; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetVisible(Node: PVirtualNode): Boolean; - -// Determines if the given node is marked as being visible. - -begin - if Node = nil then - Node := FRoot; - - if not (vsInitialized in Node.States) then - InitNode(Node); - - Result := vsVisible in Node.States; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetVisiblePath(Node: PVirtualNode): Boolean; - -// Determines if all parents of the given node are expanded and have the visibility flag set. - -begin - Assert(Assigned(Node) and (Node <> FRoot), 'Invalid parameters.'); - - // FRoot is always expanded - repeat - Node := Node.Parent; - until (Node = FRoot) or not (vsExpanded in Node.States) or not (vsVisible in Node.States); - - Result := Node = FRoot; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.HandleClickSelection(LastFocused, NewNode: PVirtualNode; Shift: TShiftState; - DragPending: Boolean); - -// Handles multi-selection with mouse click. - -begin - // Ctrl key down - if ssCtrl in Shift then - begin - if ssShift in Shift then - begin - SelectNodes(FRangeAnchor, NewNode, True); - Invalidate; - end - else - begin - if not (toSiblingSelectConstraint in FOptions.SelectionOptions) then - FRangeAnchor := NewNode; - // Delay selection change if a drag operation is pending. - // Otherwise switch selection state here. - if DragPending then - DoStateChange([tsToggleFocusedSelection]) - else - if vsSelected in NewNode.States then - RemoveFromSelection(NewNode) - else - AddToSelection(NewNode); - end; - end - else - // Shift key down - if ssShift in Shift then - begin - if FRangeAnchor = nil then - FRangeAnchor := FRoot.FirstChild; - - // select node range - if Assigned(FRangeAnchor) then - begin - SelectNodes(FRangeAnchor, NewNode, False); - Invalidate; - end; - end - else - begin - // any other case - if not (vsSelected in NewNode.States) then - begin - AddToSelection(NewNode); - InvalidateNode(NewNode); - end; - // assign new reference item - FRangeAnchor := NewNode; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.HandleDrawSelection(X, Y: Integer): Boolean; - -// Handles multi-selection with a focus rectangle. -// Result is True if something changed in selection. - -var - OldRect, - NewRect: TRect; - MainColumn: TColumnIndex; - MaxValue: Integer; - - // limits of a node and its text - NodeLeft, - NodeRight: Integer; - - // alignment and directionality - CurrentBidiMode: TBidiMode; - CurrentAlignment: TAlignment; - -begin - Result := False; - - // Selection changes are only done if the user drew a selection rectangle large - // enough to exceed the threshold. - if (FRoot.TotalCount > 1) and (tsDrawSelecting in FStates) then - begin - // Effective handling of node selection is done by using two rectangles stored in FSelectRec. - OldRect := OrderRect(FLastSelRect); - NewRect := OrderRect(FNewSelRect); - ClearTempCache; - - MainColumn := FHeader.MainColumn; - - // Alignment and bidi mode determine where the node text is located within a node. - if MainColumn = NoColumn then - begin - CurrentBidiMode := BidiMode; - CurrentAlignment := Alignment; - end - else - begin - CurrentBidiMode := FHeader.FColumns[MainColumn].BidiMode; - CurrentAlignment := FHeader.FColumns[MainColumn].Alignment; - end; - - // Determine initial left border of first node (take column reordering into account). - if FHeader.UseColumns then - begin - // The mouse coordinates don't include any horizontal scrolling hence take this also - // out from the returned column position. - NodeLeft := FHeader.FColumns[MainColumn].Left - FEffectiveOffsetX; - NodeRight := NodeLeft + FHeader.FColumns[MainColumn].Width; - end - else - begin - NodeLeft := 0; - NodeRight := ClientWidth; - end; - if CurrentBidiMode = bdLeftToRight then - Result := CollectSelectedNodesLTR(MainColumn, NodeLeft, NodeRight, CurrentAlignment, OldRect, NewRect) - else - Result := CollectSelectedNodesRTL(MainColumn, NodeLeft, NodeRight, CurrentAlignment, OldRect, NewRect); - end; - - if Result then - begin - // Do some housekeeping if there was a change. - MaxValue := PackArray(FSelection, FSelectionCount); - if MaxValue > -1 then - begin - FSelectionCount := MaxValue; - SetLength(FSelection, FSelectionCount); - end; - if FTempNodeCount > 0 then - begin - AddToSelection(FTempNodeCache, FTempNodeCount); - ClearTempCache; - end; - - Change(nil); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.HasVisibleNextSibling(Node: PVirtualNode): Boolean; - -// Helper method to determine if the given node has a visible sibling. This is needed to -// draw correct tree lines. - -begin - // Check if there is a sibling at all. - Result := Assigned(Node.NextSibling); - - if Result then - begin - repeat - Node := Node.NextSibling; - Result := vsVisible in Node.States; - until Result or (Node.NextSibling = nil); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.ImageListChange(Sender: TObject); - -begin - if not (csDestroying in ComponentState) then - Invalidate; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.InitializeFirstColumnValues(var PaintInfo: TVTPaintInfo); - -// Determines initial index, position and cell size of the first visible column. - -begin - PaintInfo.Column := FHeader.FColumns.GetFirstVisibleColumn; - with FHeader.FColumns, PaintInfo do - begin - if Column > NoColumn then - begin - CellRect.Right := CellRect.Left + Items[Column].Width; - Position := Items[Column].Position; - end - else - Position := 0; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.InitializeLineImageAndSelectLevel(Node: PVirtualNode; var LineImage: TLineImage): Integer; - -// This method is used during paint cycles and initializes an array of line type IDs. These IDs are used to paint -// the tree lines in front of the given node. -// Additionally an initial count of selected parents is determined and returned which is used for specific painting. - -var - X: Integer; - Run: PVirtualNode; - -begin - Result := 0; - if toShowRoot in FOptions.FPaintOptions then - X := 1 - else - X := 0; - Run := Node; - // Determine indentation level of top node. - while Run.Parent <> FRoot do - begin - Inc(X); - Run := Run.Parent; - // Count selected nodes (FRoot is never selected). - if vsSelected in Run.States then - Inc(Result); - end; - - // Set initial size of line index array, this will automatically initialized all entries to ltNone. - SetLength(LineImage, X); - - // Only use lines if requested. - if toShowTreeLines in FOptions.FPaintOptions then - begin - // Start over parent traversal if necessary. - Run := Node; - if Run.Parent <> FRoot then - begin - // The very last image (the one immediately before the item label) is different. - if HasVisibleNextSibling(Run) then - LineImage[X - 1] := ltTopDownRight - else - LineImage[X - 1] := ltTopRight; - Run := Run.Parent; - - // Now go up all parents. - repeat - if Run.Parent = FRoot then - Break; - Dec(X); - if HasVisibleNextSibling(Run) then - LineImage[X - 1] := ltTopDown - else - LineImage[X - 1] := ltNone; - Run := Run.Parent; - until False; - end; - - // Prepare root level. Run points at this stage to a top level node. - if (toShowRoot in FOptions.FPaintOptions) and (toShowTreeLines in FOptions.FPaintOptions) then - begin - // Is the top node a root node? - if Run = Node then - begin - // First child gets the bottom-right bitmap if it isn't also the only child. - if IsFirstVisibleChild(FRoot, Run) then - // Is it the only child? - if IsLastVisibleChild(FRoot, Run) then - LineImage[0] := ltRight - else - LineImage[0] := ltBottomRight - else - // real last child - if IsLastVisibleChild(FRoot, Run) then - LineImage[0] := ltTopRight - else - LineImage[0] := ltTopDownRight; - end - else - begin - // No, top node is not a top level node. So we need different painting. - if HasVisibleNextSibling(Run) then - LineImage[0] := ltTopDown - else - LineImage[0] := ltNone; - end; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.InitRootNode(OldSize: Cardinal = 0); - -// Reinitializes the root node. - -var - NewSize: Cardinal; - -begin - NewSize := TreeNodeSize + FTotalInternalDataSize; - if FRoot = nil then - FRoot := AllocMem(NewSize) - else - begin - ReallocMem(FRoot, NewSize); - FillChar(PChar(PChar(FRoot) + OldSize)^, NewSize - OldSize,0); - end; - - with FRoot^ do - begin - // Indication that this node is the root node. - PrevSibling := FRoot; - NextSibling := FRoot; - Parent := Pointer(Self); - States := [vsInitialized, vsExpanded, vsHasChildren, vsVisible]; - TotalHeight := FDefaultNodeHeight; - TotalCount := 1; - TotalHeight := FDefaultNodeHeight; - NodeHeight := FDefaultNodeHeight; - Align := 50; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.InterruptValidation; - -// Waits until the worker thread has stopped validating the caches of this tree. - -var - Msg: TMsg; - -begin - DoStateChange([tsStopValidation], [tsUseCache]); - - // Check the worker thread existance. It might already be gone (usually on destruction of the last tree). - if Assigned(WorkerThread) then - begin - if tsValidating in FStates then - begin - // Do a hard break until the worker thread has stopped validation. - while (tsValidating in FStates) and (WorkerThread.CurrentTree = Self) and not Application.Terminated do - begin - // Pump our own messages to avoid a deadlock. - //todo_lcl_check - Application.ProcessMessages; - { - if PeekMessage(Msg, Handle, 0, 0, PM_REMOVE) then - begin - if Msg.message = WM_QUIT then - Break; - TranslateMessage(Msg); - DispatchMessage(Msg); - end; - } - end; - DoStateChange([tsValidationNeeded]); - end - else // Remove any pending validation. - WorkerThread.RemoveTree(Self); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.IsFirstVisibleChild(Parent, Node: PVirtualNode): Boolean; - -// Helper method to check if Node is the same as the first visible child of Parent. - -var - Run: PVirtualNode; - -begin - // Find first visible child. - Run := Parent.FirstChild; - while Assigned(Run) and not (vsVisible in Run.States) do - Run := Run.NextSibling; - - Result := Assigned(Run) and (Run = Node); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.IsLastVisibleChild(Parent, Node: PVirtualNode): Boolean; - -// Helper method to check if Node is the same as the last visible child of Parent. - -var - Run: PVirtualNode; - -begin - // Find last visible child. - Run := Parent.LastChild; - while Assigned(Run) and not (vsVisible in Run.States) do - Run := Run.PrevSibling; - - Result := Assigned(Run) and (Run = Node); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.LimitPaintingToArea(Canvas: TCanvas; ClipRect: TRect; VisibleRegion: HRGN = 0); - -// Limits further painting onto the given canvas to the given rectangle. -// VisibleRegion is an optional region which can be used to limit drawing further. - -var - ClipRegion: HRGN; - -begin - // Regions expect their coordinates in device coordinates, hence we have to transform the region rectangle. - LPtoDP(Canvas.Handle, ClipRect, 2); - ClipRegion := CreateRectRgnIndirect(ClipRect); - if VisibleRegion <> 0 then - CombineRgn(ClipRegion, ClipRegion, VisibleRegion, RGN_AND); - SelectClipRgn(Canvas.Handle, ClipRegion); - DeleteObject(ClipRegion); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.MakeNewNode: PVirtualNode; - -var - Size: Cardinal; - -begin - Size := TreeNodeSize; - if not (csDesigning in ComponentState) then - begin - // Make sure FNodeDataSize is valid. - if FNodeDataSize = -1 then - ValidateNodeDataSize(FNodeDataSize); - - // Take record alignment into account. - Inc(Size, FNodeDataSize); - end; - - {$ifdef UseLocalMemoryManager} - Result := FNodeMemoryManager.AllocNode(Size + FTotalInternalDataSize); - {$else} - Result := AllocMem(Size + FTotalInternalDataSize); - {$endif UseLocalMemoryManager} - - // Fill in some default values. - with Result^ do - begin - TotalCount := 1; - TotalHeight := FDefaultNodeHeight; - NodeHeight := FDefaultNodeHeight; - States := [vsVisible]; - Align := 50; - end; -end; - -function TBaseVirtualTree.PackArray(TheArray: TNodeArray; Count: Integer): Integer; -var - i, l: Integer; -begin - //todo_lcl Remove l var and use Result instead. See the differences - Result := -1; - - if Count = 0 then - Exit; - - l := 0; - for i := 0 to Count - 1 do begin - if vsSelected in TheArray[i]^.States then begin - TheArray[l] := TheArray[i]; - Inc(l); - end; - end; - - Result := l; // return length -end; - - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.PackArrayAsm(TheArray: TNodeArray; Count: Integer): Integer; assembler; - -// Removes all entries from the selection array which are no longer in use. The selection array must be sorted for this -// algo to work. Values which must be removed are marked with bit 0 (LSB) set. This little trick works because memory -// is always allocated DWORD aligned. Since the selection array must be sorted while determining the entries to be -// removed it is much more efficient to increment the entry in question instead of setting it to nil (which would break -// the ordered appearance of the list). -// -// On enter EAX contains self reference, EDX the address to TheArray and ECX Count -// The returned value is the number of remaining entries in the array, so the caller can reallocate (shorten) -// the selection array if needed or -1 if nothing needs to be changed. - -asm - PUSH EBX - PUSH EDI - PUSH ESI - MOV ESI, EDX - MOV EDX, -1 - JCXZ @@Finish // Empty list? - INC EDX // init remaining entries counter - MOV EDI, ESI // source and destination point to the list memory - MOV EBX, 1 // use a register instead of immediate operant to check against -@@PreScan: - TEST [ESI], EBX // do the fastest scan possible to find the first entry - // which must be removed - JNZ @@DoMainLoop - INC EDX - ADD ESI, 4 - DEC ECX - JNZ @@PreScan - JMP @@Finish - -@@DoMainLoop: - MOV EDI, ESI -@@MainLoop: - TEST [ESI], EBX // odd entry? - JNE @@Skip // yes, so skip this one - MOVSD // else move the entry to new location - INC EDX // count the moved entries - DEC ECX - JNZ @@MainLoop // do it until all entries are processed - JMP @@Finish - -@@Skip: - ADD ESI, 4 // point to the next entry - DEC ECX - JNZ @@MainLoop // do it until all entries are processed -@@Finish: - MOV EAX, EDX // prepare return value - POP ESI - POP EDI - POP EBX -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.PrepareBitmaps(NeedButtons, NeedLines: Boolean); - -// initializes the contents of the internal bitmaps - -const - LineBitsDotted: array [0..8] of Word = ($55, $AA, $55, $AA, $55, $AA, $55, $AA, $55); - LineBitsSolid: array [0..7] of Word = (0, 0, 0, 0, 0, 0, 0, 0); - -var - PatternBitmap: HBITMAP; - Bits: Pointer; - {$ifdef ThemeSupport} - Details: TThemedElementDetails; - {$endif ThemeSupport} - -begin - if NeedButtons then - begin - with FMinusBM, Canvas do - begin - // box is always of odd size - //The TCanvas of VCL does not has width and height. It cause a conflict here - FMinusBM.Width := 9; - FMinusBM.Height := 9; - - Transparent := True; - TransparentColor := clFuchsia; - Brush.Color := clFuchsia; - FillRect(Rect(0, 0, FMinusBM.Width, FMinusBM.Height)); - if FButtonStyle = bsTriangle then - begin - Brush.Color := clBlack; - Pen.Color := clBlack; - Polygon([Point(0, 2), Point(8, 2), Point(4, 6)]); - end - else - begin - // Button style is rectangular. Now ButtonFillMode determines how to fill the interior. - if FButtonFillMode in [fmTreeColor, fmWindowColor, fmTransparent] then - begin - case FButtonFillMode of - fmTreeColor: - Brush.Color := Self.Color; - fmWindowColor: - Brush.Color := clWindow; - end; - Pen.Color := FColors.TreeLineColor; - Rectangle(0, 0, FMinusBM.Width, FMinusBM.Height); - Pen.Color := Self.Font.Color; - MoveTo(2, FMinusBM.Width div 2); - LineTo(FMinusBM.Width - 2 , FMinusBM.Width div 2); - end - else - FMinusBM.LoadFromLazarusResource('VT_XPBUTTONMINUS'); - end; - end; - Logger.SendBitmap(lcPaintBitmap,'FMinusBM',FMinusBM); - with FPlusBM, Canvas do - begin - FPlusBM.Width := 9; - FPlusBM.Height := 9; - Transparent := True; - TransparentColor := clFuchsia; - Brush.Color := clFuchsia; - FillRect(Rect(0, 0, FPlusBM.Width, FPlusBM.Height)); - if FButtonStyle = bsTriangle then - begin - Brush.Color := clBlack; - Pen.Color := clBlack; - Polygon([Point(2, 0), Point(6, 4), Point(2, 8)]); - end - else - begin - // Button style is rectangular. Now ButtonFillMode determines how to fill the interior. - if FButtonFillMode in [fmTreeColor, fmWindowColor, fmTransparent] then - begin - case FButtonFillMode of - fmTreeColor: - Brush.Color := Self.Color; - fmWindowColor: - Brush.Color := clWindow; - end; - - Pen.Color := FColors.TreeLineColor; - Rectangle(0, 0, FPlusBM.Width, FPlusBM.Height); - Pen.Color := Self.Font.Color; - MoveTo(2, FPlusBM.Width div 2); - LineTo(FPlusBM.Width - 2 , FPlusBM.Width div 2); - MoveTo(FPlusBM.Width div 2, 2); - LineTo(FPlusBM.Width div 2, FPlusBM.Width - 2); - end - else - FPlusBM.LoadFromLazarusResource('VT_XPBUTTONPLUS'); - end; - end; - - {$ifdef ThemeSupport} - // Overwrite glyph images if theme is active. - if tsUseThemes in FStates then - begin - Details := ThemeServices.GetElementDetails(ttGlyphClosed); - ThemeServices.DrawElement(FPlusBM.Canvas.Handle, Details, Rect(0, 0, 9, 9)); - Details := ThemeServices.GetElementDetails(ttGlyphOpened); - ThemeServices.DrawElement(FMinusBM.Canvas.Handle, Details, Rect(0, 0, 9, 9)); - end; - {$endif ThemeSupport} - end; - - if NeedLines then - begin - if FDottedBrush <> 0 then - DeleteObject(FDottedBrush); - - case FLineStyle of - lsDotted: - Bits := @LineBitsDotted; - lsSolid: - Bits := @LineBitsSolid; - else // lsCustomStyle - Bits := @LineBitsDotted; - DoGetLineStyle(Bits); - end; - PatternBitmap := CreateBitmap(8, 8, 1, 1, Bits); - FDottedBrush := CreatePatternBrush(PatternBitmap); - DeleteObject(PatternBitmap); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.PrepareCell(var PaintInfo: TVTPaintInfo; WindowOrgX, MaxWidth: Integer); - -// This method is called immediately before a cell's content is drawn und is responsible to paint selection colors etc. - -var - TextColorBackup, - BackColorBackup: COLORREF; - InnerRect: TRect; - - //---------------------------------------------------------------------------- - - procedure AlphaBlendSelection(Color: TColor); - - var - R: TRect; - - begin - // Take into account any window offset and size limitations in the target bitmap, as this is only as large - // as necessary and might not cover the whole node. For normal painting this does not matter (because of - // clipping) but for the MMX code there is no such check and it will crash badly when bitmap boundaries are - // crossed. - R := InnerRect; - OffsetRect(R, -WindowOrgX, 0); - if R.Left < 0 then - R.Left := 0; - if R.Right > MaxWidth then - R.Right := MaxWidth; - AlphaBlend(0, PaintInfo.Canvas.Handle, R, Point(0, 0), bmConstantAlphaAndColor, - FSelectionBlendFactor, ColorToRGB(Color)); - end; - - //---------------------------------------------------------------------------- - -begin - with PaintInfo, Canvas do - begin - InnerRect := ContentRect; - - // Fill cell background if its color differs from tree background. - with FHeader.FColumns do - if poColumnColor in PaintOptions then - begin - Brush.Color := Items[Column].Color; - FillRect(CellRect); - end; - - // Let the application customize the cell background. - DoBeforeCellPaint(Canvas, Node, Column, CellRect); - - if (Column = FFocusedColumn) or (toFullRowSelect in FOptions.FSelectionOptions) then - begin - // The selection rectangle depends on alignment. - if not (toGridExtensions in FOptions.FMiscOptions) then - begin - case Alignment of - taLeftJustify: - with InnerRect do - if Left + NodeWidth < Right then - Right := Left + NodeWidth; - taCenter: - with InnerRect do - if (Right - Left) > NodeWidth then - begin - Left := (Left + Right - NodeWidth) div 2; - Right := Left + NodeWidth; - end; - taRightJustify: - with InnerRect do - if (Right - Left) > NodeWidth then - Left := Right - NodeWidth; - end; - end; - - // Fill the selection rectangle. - if poDrawSelection in PaintOptions then - begin - if Node = FDropTargetNode then - begin - if (FLastDropMode = dmOnNode) or (vsSelected in Node.States) then - begin - Brush.Color := FColors.DropTargetColor; - Pen.Color := FColors.DropTargetBorderColor; - - if (toGridExtensions in FOptions.FMiscOptions) or - (toFullRowSelect in FOptions.FSelectionOptions) then - InnerRect := CellRect; - if not IsRectEmpty(InnerRect) then - if MMXAvailable and (toUseBlendedSelection in FOptions.PaintOptions) then - AlphaBlendSelection(Brush.Color) - else - with InnerRect do - RoundRect(Left, Top, Right, Bottom, FSelectionCurveRadius, FSelectionCurveRadius); - end - else - begin - Brush.Style := bsClear; - end; - end - else - if vsSelected in Node.States then - begin - if Focused or (toPopupMode in FOptions.FPaintOptions) then - begin - Brush.Color := FColors.FocusedSelectionColor; - Pen.Color := FColors.FocusedSelectionBorderColor; - end - else - begin - Brush.Color := FColors.UnfocusedSelectionColor; - Pen.Color := FColors.UnfocusedSelectionBorderColor; - end; - - if (toGridExtensions in FOptions.FMiscOptions) or (toFullRowSelect in FOptions.FSelectionOptions) then - InnerRect := CellRect; - if not IsRectEmpty(InnerRect) then - if MMXAvailable and (toUseBlendedSelection in FOptions.PaintOptions) then - AlphaBlendSelection(Brush.Color) - else - with InnerRect do - RoundRect(Left, Top, Right, Bottom, FSelectionCurveRadius, FSelectionCurveRadius); - end; - end; - - // draw focus rect - if (poDrawFocusRect in PaintOptions) and (Column = FFocusedColumn) and - (Focused or (toPopupMode in FOptions.FPaintOptions)) and (FFocusedNode = Node) then - begin - TextColorBackup := GetTextColor(Handle); - SetTextColor(Handle, $FFFFFF); - BackColorBackup := GetBkColor(Handle); - SetBkColor(Handle, 0); - - if toGridExtensions in FOptions.FMiscOptions then - LCLIntf.DrawFocusRect(Handle, CellRect) - else - LCLIntf.DrawFocusRect(Handle, InnerRect); - - SetTextColor(Handle, TextColorBackup); - SetBkColor(Handle, BackColorBackup); - end; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -type - TOldVTOption = (voAcceptOLEDrop, voAnimatedToggle, voAutoDropExpand, voAutoExpand, voAutoScroll, - voAutoSort, voAutoSpanColumns, voAutoTristateTracking, voCheckSupport, voDisableDrawSelection, voEditable, - voExtendedFocus, voFullRowSelect, voGridExtensions, voHideFocusRect, voHideSelection, voHotTrack, voInitOnSave, - voLevelSelectConstraint, voMiddleClickSelect, voMultiSelect, voRightClickSelect, voPopupMode, voShowBackground, - voShowButtons, voShowDropmark, voShowHorzGridLines, voShowRoot, voShowTreeLines, voShowVertGridLines, - voSiblingSelectConstraint, voToggleOnDblClick); - -const - OptionMap: array[TOldVTOption] of Integer = ( - Ord(toAcceptOLEDrop), Ord(toAnimatedToggle), Ord(toAutoDropExpand), Ord(toAutoExpand), Ord(toAutoScroll), - Ord(toAutoSort), Ord(toAutoSpanColumns), Ord(toAutoTristateTracking), Ord(toCheckSupport), Ord(toDisableDrawSelection), - Ord(toEditable), Ord(toExtendedFocus), Ord(toFullRowSelect), Ord(toGridExtensions), Ord(toHideFocusRect), - Ord(toHideSelection), Ord(toHotTrack), Ord(toInitOnSave), Ord(toLevelSelectConstraint), Ord(toMiddleClickSelect), - Ord(toMultiSelect), Ord(toRightClickSelect), Ord(toPopupMode), Ord(toShowBackground), - Ord(toShowButtons), Ord(toShowDropmark), Ord(toShowHorzGridLines), Ord(toShowRoot), Ord(toShowTreeLines), - Ord(toShowVertGridLines), Ord(toSiblingSelectConstraint), Ord(toToggleOnDblClick) - ); - -procedure TBaseVirtualTree.ReadOldOptions(Reader: TReader); - -// Migration helper routine to silently convert forms containing the old tree options member into the new -// sub-options structure. - -var - OldOption: TOldVTOption; - EnumName: string; - -begin - // If we are at design time currently then let the designer know we changed something. - UpdateDesigner; - - // It should never happen at this place that there is something different than the old set. - if Reader.ReadValue = vaSet then - begin - // Remove all default values set by the constructor. - FOptions.AnimationOptions := []; - FOptions.AutoOptions := []; - FOptions.MiscOptions := []; - FOptions.PaintOptions := []; - FOptions.SelectionOptions := []; - - while True do - begin - // Sets are stored with their members as simple strings. Read them one by one and map them to the new option - // in the correct sub-option set. - EnumName := Reader.ReadString; - if EnumName = '' then - Break; - OldOption := TOldVTOption(GetEnumValue(TypeInfo(TOldVTOption), EnumName)); - case OldOption of - voAcceptOLEDrop, voCheckSupport, voEditable, voGridExtensions, voInitOnSave, voToggleOnDblClick: - FOptions.MiscOptions := FOptions.FMiscOptions + [TVTMiscOption(OptionMap[OldOption])]; - voAnimatedToggle: - FOptions.AnimationOptions := FOptions.FAnimationOptions + [TVTAnimationOption(OptionMap[OldOption])]; - voAutoDropExpand, voAutoExpand, voAutoScroll, voAutoSort, voAutoSpanColumns, voAutoTristateTracking: - FOptions.AutoOptions := FOptions.FAutoOptions + [TVTAutoOption(OptionMap[OldOption])]; - voDisableDrawSelection, voExtendedFocus, voFullRowSelect, voLevelSelectConstraint, - voMiddleClickSelect, voMultiSelect, voRightClickSelect, voSiblingSelectConstraint: - FOptions.SelectionOptions := FOptions.FSelectionOptions + [TVTSelectionOption(OptionMap[OldOption])]; - voHideFocusRect, voHideSelection, voHotTrack, voPopupMode, voShowBackground, voShowButtons, - voShowDropmark, voShowHorzGridLines, voShowRoot, voShowTreeLines, voShowVertGridLines: - FOptions.PaintOptions := FOptions.FPaintOptions + [TVTPaintOption(OptionMap[OldOption])]; - end; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SetAlignment(const Value: TAlignment); - -begin - if FAlignment <> Value then - begin - FAlignment := Value; - if not (csLoading in ComponentState) then - Invalidate; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SetAnimationDuration(const Value: Cardinal); - -begin - FAnimationDuration := Value; - if FAnimationDuration = 0 then - Exclude(FOptions.FAnimationOptions, toAnimatedToggle) - else - Include(FOptions.FAnimationOptions, toAnimatedToggle); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SetBackground(const Value: TPicture); - -begin - FBackground.Assign(Value); - Invalidate; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SetBackgroundOffset(const Index, Value: Integer); - -begin - case Index of - 0: - if FBackgroundOffsetX <> Value then - begin - FBackgroundOffsetX := Value; - Invalidate; - end; - 1: - if FBackgroundOffsetY <> Value then - begin - FBackgroundOffsetY := Value; - Invalidate; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SetBorderStyle(Value: TBorderStyle); - -begin - if FBorderStyle <> Value then - begin - FBorderStyle := Value; - //todo_lcl_check - RecreateWnd(Self); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SetBottomSpace(const Value: Cardinal); - -begin - if FBottomSpace <> Value then - begin - FBottomSpace := Value; - UpdateVerticalScrollbar(True); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SetButtonFillMode(const Value: TVTButtonFillMode); - -begin - if FButtonFillMode <> Value then - begin - FButtonFillMode := Value; - if not (csLoading in ComponentState) then - begin - PrepareBitmaps(True, False); - if HandleAllocated then - Invalidate; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SetButtonStyle(const Value: TVTButtonStyle); - -begin - if FButtonStyle <> Value then - begin - FButtonStyle := Value; - if not (csLoading in ComponentState) then - begin - PrepareBitmaps(True, False); - if HandleAllocated then - Invalidate; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SetCheckImageKind(Value: TCheckImageKind); - -begin - if FCheckImageKind <> Value then - begin - FCheckImageKind := Value; - FCheckImages := GetCheckImageListFor(Value); - if FCheckImages = nil then - FCheckImages := FCustomCheckImages; - if HandleAllocated and (FUpdateCount = 0) and not (csLoading in ComponentState) then - InvalidateRect(Handle, nil, False); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SetCheckState(Node: PVirtualNode; Value: TCheckState); - -begin - if (Node.CheckState <> Value) and not (vsDisabled in Node.States) and DoChecking(Node, Value) then - DoCheckClick(Node, Value); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SetCheckType(Node: PVirtualNode; Value: TCheckType); - -begin - if (Node.CheckType <> Value) and not (toReadOnly in FOptions.FMiscOptions) then - begin - Node.CheckType := Value; - Node.CheckState := csUncheckedNormal; - // For check boxes with tri-state check box parents we have to initialize differently. - if (toAutoTriStateTracking in FOptions.FAutoOptions) and (Value in [ctCheckBox, ctTriStateCheckBox]) and - (Node.Parent <> FRoot) then - begin - if not (vsInitialized in Node.Parent.States) then - InitNode(Node.Parent); - if (Node.Parent.CheckType = ctTriStateCheckBox) and - (Node.Parent.CheckState in [csUncheckedNormal, csCheckedNormal]) then - CheckState[Node] := Node.Parent.CheckState; - end; - InvalidateNode(Node); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SetChildCount(Node: PVirtualNode; NewChildCount: Cardinal); - -// Changes a node's child structure to accomodate the new child count. This is used to add or delete -// child nodes to/from the end of the node's child list. To insert or delete a specific node a separate -// routine is used. - -var - Count: Integer; - Index: Cardinal; - Child: PVirtualNode; - C: Integer; - NewHeight: Integer; - -begin - if not (toReadOnly in FOptions.FMiscOptions) then - begin - if Node = nil then - Node := FRoot; - - if NewChildCount = 0 then - DeleteChildren(Node) - else - begin - Count := Integer(NewChildCount) - Integer(Node.ChildCount); - - // If nothing changed then do nothing. - if Count <> 0 then - begin - InterruptValidation; - - C := Count; - NewHeight := 0; - - if Count > 0 then - begin - // New nodes to add. - if Assigned(Node.LastChild) then - Index := Node.LastChild.Index + 1 - else - begin - Index := 0; - Include(Node.States, vsHasChildren); - end; - Node.States := Node.States - [vsAllChildrenHidden, vsHeightMeasured]; - - // New nodes are by default always visible, so we don't need to check the visibility. - while Count > 0 do - begin - Child := MakeNewNode; - Child.Index := Index; - Child.PrevSibling := Node.LastChild; - if Assigned(Node.LastChild) then - Node.LastChild.NextSibling := Child; - Child.Parent := Node; - Node.LastChild := Child; - if Node.FirstChild = nil then - Node.FirstChild := Child; - Dec(Count); - Inc(Index); - - // The actual node height will later be computed once it is clear - // whether this node has a variable node height or not. - Inc(NewHeight, Child.NodeHeight); - end; - - if vsExpanded in Node.States then - begin - AdjustTotalHeight(Node, NewHeight, True); - if FullyVisible[Node] then - Inc(Integer(FVisibleCount), C); - end; - - AdjustTotalCount(Node, C, True); - Node.ChildCount := NewChildCount; - if (FUpdateCount = 0) and (toAutoSort in FOptions.FAutoOptions) and (FHeader.FSortColumn > InvalidColumn) then - Sort(Node, FHeader.FSortColumn, FHeader.FSortDirection, True); - - InvalidateCache; - end - else - begin - // Nodes have to be deleted. - while Count < 0 do - begin - DeleteNode(Node.LastChild); - Inc(Count); - end; - end; - - if FUpdateCount = 0 then - begin - ValidateCache; - UpdateScrollBars(True); - Invalidate; - end; - - if Node = FRoot then - StructureChange(nil, crChildAdded) - else - StructureChange(Node, crChildAdded); - end; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SetClipboardFormats(const Value: TClipboardFormats); - -var - I: Integer; - -begin - // Add string by string instead doing an Assign or AddStrings because the list may return -1 for - // invalid entries which cause trouble for the standard implementation. - FClipboardFormats.Clear; - for I := 0 to Value.Count - 1 do - FClipboardFormats.Add(Value[I]); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SetColors(const Value: TVTColors); - -begin - FColors.Assign(Value); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SetCustomCheckImages(const Value: TCustomImageList); - -begin - if FCustomCheckImages <> Value then - begin - if Assigned(FCustomCheckImages) then - begin - FCustomCheckImages.UnRegisterChanges(FCustomCheckChangeLink); - {$ifdef COMPILER_5_UP} - FCustomCheckImages.RemoveFreeNotification(Self); - {$endif COMPILER_5_UP} - // Reset the internal check image list reference too, if necessary. - if FCheckImages = FCustomCheckImages then - FCheckImages := nil; - end; - FCustomCheckImages := Value; - if Assigned(FCustomCheckImages) then - begin - FCustomCheckImages.RegisterChanges(FCustomCheckChangeLink); - FCustomCheckImages.FreeNotification(Self); - end; - // Check if currently custom check images are active. - if FCheckImageKind = ckCustom then - FCheckImages := Value; - if not (csLoading in ComponentState) then - Invalidate; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SetDefaultNodeHeight(Value: Cardinal); - -begin - if Value = 0 then - Value := 18; - if FDefaultNodeHeight <> Value then - begin - DoStateChange([tsNeedScale]); - Inc(Integer(FRoot.TotalHeight), Integer(Value) - Integer(FDefaultNodeHeight)); - Inc(SmallInt(FRoot.NodeHeight), Integer(Value) - Integer(FDefaultNodeHeight)); - FDefaultNodeHeight := Value; - InvalidateCache; - if (FUpdateCount = 0) and HandleAllocated and not (csLoading in ComponentState) then - begin - ValidateCache; - UpdateScrollBars(True); - ScrollIntoView(FFocusedNode, toCenterScrollIntoView in FOptions.SelectionOptions, True); - Invalidate; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SetDisabled(Node: PVirtualNode; Value: Boolean); - -begin - if Assigned(Node) and (Value xor (vsDisabled in Node.States)) then - begin - if Value then - Include(Node.States, vsDisabled) - else - Exclude(Node.States, vsDisabled); - - if FUpdateCount = 0 then - InvalidateNode(Node); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SetExpanded(Node: PVirtualNode; Value: Boolean); - -begin - if Assigned(Node) and (Node <> FRoot) and (Value xor (vsExpanded in Node.States)) then - ToggleNode(Node); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SetFocusedColumn(Value: TColumnIndex); - -begin - if (FFocusedColumn <> Value) and - DoFocusChanging(FFocusedNode, FFocusedNode, FFocusedColumn, Value) then - begin - CancelEditNode; - FFocusedColumn := Value; - if Assigned(FFocusedNode) then - begin - ScrollIntoView(FFocusedNode, toCenterScrollIntoView in FOptions.SelectionOptions, - not (toDisableAutoscrollOnFocus in FOptions.FAutoOptions)); - InvalidateNode(FFocusedNode); - end; - - if Assigned(FDropTargetNode) then - InvalidateNode(FDropTargetNode); - - DoFocusChange(FFocusedNode, FFocusedColumn); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SetFocusedNode(Value: PVirtualNode); - -var - WasDifferent: Boolean; - -begin - WasDifferent := Value <> FFocusedNode; - DoFocusNode(Value, True); - // Do change event only if there was actually a change. - if WasDifferent and (FFocusedNode = Value) then - DoFocusChange(FFocusedNode, FFocusedColumn); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SetFullyVisible(Node: PVirtualNode; Value: Boolean); - -// This method ensures that a node is visible and all its parent nodes are expanded and also visible -// if Value is True. Otherwise the visibility flag of the node is reset but the expand state -// of the parent nodes stays untouched. - -begin - Assert(Assigned(Node) and (Node <> FRoot), 'Invalid parameter'); - - IsVisible[Node] := Value; - if Value then - begin - repeat - Node := Node.Parent; - if Node = FRoot then - Break; - if not (vsExpanded in Node.States) then - ToggleNode(Node); - if not (vsVisible in Node.States) then - IsVisible[Node] := True; - until False; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SetHasChildren(Node: PVirtualNode; Value: Boolean); - -begin - if Assigned(Node) and not (toReadOnly in FOptions.FMiscOptions) then - begin - if Value then - Include(Node.States, vsHasChildren) - else - begin - Exclude(Node.States, vsHasChildren); - DeleteChildren(Node); - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SetHeader(const Value: TVTHeader); - -begin - FHeader.Assign(Value); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SetImages(const Value: TCustomImageList); - -begin - if FImages <> Value then - begin - if Assigned(FImages) then - begin - FImages.UnRegisterChanges(FImageChangeLink); - {$ifdef COMPILER_5_UP} - FImages.RemoveFreeNotification(Self); - {$endif COMPILER_5_UP} - end; - FImages := Value; - if Assigned(FImages) then - begin - FImages.RegisterChanges(FImageChangeLink); - FImages.FreeNotification(Self); - end; - if not (csLoading in ComponentState) then - Invalidate; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SetIndent(Value: Cardinal); - -begin - if FIndent <> Value then - begin - FIndent := Value; - if not (csLoading in ComponentState) and (FUpdateCount = 0) and HandleAllocated then - begin - UpdateScrollBars(True); - Invalidate; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SetLineMode(const Value: TVTLineMode); - -begin - if FLineMode <> Value then - begin - FLineMode := Value; - if HandleAllocated and not (csLoading in ComponentState) then - Invalidate; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SetLineStyle(const Value: TVTLineStyle); - -begin - if FLineStyle <> Value then - begin - FLineStyle := Value; - if not (csLoading in ComponentState) then - begin - PrepareBitmaps(False, True); - if HandleAllocated then - Invalidate; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SetMargin(Value: Integer); - -begin - if FMargin <> Value then - begin - FMargin := Value; - if HandleAllocated and not (csLoading in ComponentState) then - Invalidate; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SetMultiline(Node: PVirtualNode; const Value: Boolean); - -begin - if Assigned(Node) and (Node <> FRoot) then - if Value <> (vsMultiline in Node.States) then - begin - if Value then - Include(Node.States, vsMultiline) - else - Exclude(Node.States, vsMultiline); - - if FUpdateCount = 0 then - InvalidateNode(Node); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SetNodeAlignment(const Value: TVTNodeAlignment); - -begin - if FNodeAlignment <> Value then - begin - FNodeAlignment := Value; - if HandleAllocated and not (csReading in ComponentState) then - Invalidate; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SetNodeDataSize(Value: Integer); - -var - LastRootCount: Cardinal; - -begin - if Value < -1 then - Value := -1; - if FNodeDataSize <> Value then - begin - FNodeDataSize := Value; - if not (csLoading in ComponentState) and not (csDesigning in ComponentState) then - begin - LastRootCount := FRoot.ChildCount; - Clear; - SetRootNodeCount(LastRootCount); - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SetNodeHeight(Node: PVirtualNode; Value: Cardinal); - -var - Difference: Integer; - -begin - if Assigned(Node) and (Node <> FRoot) and (Node.NodeHeight <> Value) and not (toReadOnly in FOptions.FMiscOptions) then - begin - Difference := Integer(Value) - Integer(Node.NodeHeight); - Node.NodeHeight := Value; - AdjustTotalHeight(Node, Difference, True); - - // If an edit operation is currently active then update the editors boundaries as well. - UpdateEditBounds; - - // Stay away from touching the node cache while it is being validated. - if not (tsValidating in FStates) and FullyVisible[Node] then - begin - InvalidateCache; - if FUpdateCount = 0 then - begin - ValidateCache; - InvalidateToBottom(Node); - UpdateScrollBars(True); - end; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SetNodeParent(Node: PVirtualNode; const Value: PVirtualNode); - -begin - if Assigned(Node) and Assigned(Value) and (Node.Parent <> Value) then - MoveTo(Node, Value, amAddChildLast, False); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SetOffsetX(const Value: Integer); - -begin - DoSetOffsetXY(Point(Value, FOffsetY), DefaultScrollUpdateFlags); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SetOffsetXY(const Value: TPoint); - -begin - DoSetOffsetXY(Value, DefaultScrollUpdateFlags); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SetOffsetY(const Value: Integer); - -begin - DoSetOffsetXY(Point(FOffsetX, Value), DefaultScrollUpdateFlags); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SetOptions(const Value: TCustomVirtualTreeOptions); - -begin - FOptions.Assign(Value); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SetRootNodeCount(Value: Cardinal); - -begin - // Don't set the root node count until all other properties (in particular the OnInitNode event) have been set. - if csLoading in ComponentState then - begin - FRoot.ChildCount := Value; - DoStateChange([tsNeedRootCountUpdate]); - end - else - if FRoot.ChildCount <> Value then - begin - BeginUpdate; - InterruptValidation; - SetChildCount(FRoot, Value); - EndUpdate; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SetScrollBarOptions(Value: TScrollBarOptions); - -begin - FScrollBarOptions.Assign(Value); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SetSearchOption(const Value: TVTIncrementalSearch); - -begin - if FIncrementalSearch <> Value then - begin - FIncrementalSearch := Value; - if FIncrementalSearch = isNone then - begin - StopTimer(SearchTimer); - FSearchBuffer := ''; - FLastSearchNode := nil; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SetSelected(Node: PVirtualNode; Value: Boolean); - -begin - if Assigned(Node) and (Node <> FRoot) and (Value xor (vsSelected in Node.States)) then - begin - if Value then - begin - if FSelectionCount = 0 then - FRangeAnchor := Node - else - if not (toMultiSelect in FOptions.FSelectionOptions) then - ClearSelection; - - AddToSelection(Node); - - // Make sure there is a valid column selected (if there are columns at all). - if ((FFocusedColumn < 0) or not (coVisible in FHeader.Columns[FFocusedColumn].Options)) and - (FHeader.MainColumn > NoColumn) then - if coVisible in FHeader.Columns[FHeader.MainColumn].Options then - FFocusedColumn := FHeader.MainColumn - else - FFocusedColumn := FHeader.Columns.GetFirstVisibleColumn; - if FRangeAnchor = nil then - FRangeAnchor := Node; - end - else - begin - RemoveFromSelection(Node); - if FSelectionCount = 0 then - ResetRangeAnchor; - end; - if FullyVisible[Node] then - InvalidateNode(Node); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SetSelectionCurveRadius(const Value: Cardinal); - -begin - if FSelectionCurveRadius <> Value then - begin - FSelectionCurveRadius := Value; - if HandleAllocated and not (csLoading in ComponentState) then - Invalidate; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SetStateImages(const Value: TCustomImageList); - -begin - if FStateImages <> Value then - begin - if Assigned(FStateImages) then - begin - FStateImages.UnRegisterChanges(FStateChangeLink); - {$ifdef COMPILER_5_UP} - FStateImages.RemoveFreeNotification(Self); - {$endif COMPILER_5_UP} - end; - FStateImages := Value; - if Assigned(FStateImages) then - begin - FStateImages.RegisterChanges(FStateChangeLink); - FStateImages.FreeNotification(Self); - end; - if HandleAllocated and not (csLoading in ComponentState) then - Invalidate; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SetTextMargin(Value: Integer); - -begin - if FTextMargin <> Value then - begin - FTextMargin := Value; - if not (csLoading in ComponentState) then - Invalidate; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SetTopNode(Node: PVirtualNode); - -var - R: TRect; - Run: PVirtualNode; - -begin - if Assigned(Node) then - begin - // make sure all parents of the node are expanded - Run := Node.Parent; - while Run <> FRoot do - begin - if not (vsExpanded in Run.States) then - ToggleNode(Run); - Run := Run.Parent; - end; - R := GetDisplayRect(Node, FHeader.MainColumn, True); - SetOffsetY(FOffsetY - R.Top); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SetUpdateState(Updating: Boolean); - -begin - // The check for visibility is necessary otherwise the tree is automatically shown when - // updating is allowed. As this happens internally the VCL does not get notified and - // still assumes the control is hidden. This results in weird "cannot focus invisble control" errors. - //todo_lcl - if Visible and HandleAllocated then - SendMessage(Handle, WM_SETREDRAW, Ord(not Updating), 0); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SetVerticalAlignment(Node: PVirtualNode; Value: Byte); - -begin - if Value > 100 then - Value := 100; - if Node.Align <> Value then - begin - Node.Align := Value; - if FullyVisible[Node] and (FUpdateCount = 0) then - InvalidateNode(Node); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SetVisible(Node: PVirtualNode; Value: Boolean); - -// Sets the visibility style of the given node according to Value. - -var - NeedUpdate: Boolean; - -begin - Assert(Assigned(Node) and (Node <> FRoot), 'Invalid parameter.'); - - if Value <> (vsVisible in Node.States) then - begin - InterruptValidation; - NeedUpdate := False; - if Value then - begin - Include(Node.States, vsVisible); - if vsExpanded in Node.Parent.States then - AdjustTotalHeight(Node.Parent, Node.TotalHeight, True); - if VisiblePath[Node] then - begin - Inc(FVisibleCount, 1 + CountVisibleChildren(Node)); - NeedUpdate := True; - end; - - // Update the hidden children flag of the parent. - // Since this node is now visible we simply have to remove the flag. - Exclude(Node.Parent.States, vsAllChildrenHidden); - end - else - begin - Exclude(Node.States, vsVisible); - if vsExpanded in Node.Parent.States then - AdjustTotalHeight(Node.Parent, -Integer(Node.TotalHeight), True); - if VisiblePath[Node] then - begin - Dec(FVisibleCount, 1 + CountVisibleChildren(Node)); - NeedUpdate := True; - end; - - if FUpdateCount = 0 then - DetermineHiddenChildrenFlag(Node.Parent) - else - Include(FStates, tsUpdateHiddenChildrenNeeded) - end; - - InvalidateCache; - if NeedUpdate and (FUpdateCount = 0) then - begin - ValidateCache; - UpdateScrollBars(True); - Invalidate; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SetVisiblePath(Node: PVirtualNode; Value: Boolean); - -// If Value is True then all parent nodes of Node are expanded. - -begin - Assert(Assigned(Node) and (Node <> FRoot), 'Invalid parameter.'); - - if Value then - begin - repeat - Node := Node.Parent; - if Node = FRoot then - Break; - if not (vsExpanded in Node.States) then - ToggleNode(Node); - until False; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.StaticBackground(Source: TBitmap; Target: TCanvas; Offset: TPoint; R: TRect); - -// Draws the given source graphic so that it stays static in the given rectangle which is relative to the target bitmap. -// The graphic is aligned so that it always starts at the upper left corner of the target canvas. -// Offset gives the position of the target window as a possible superordinated surface. - -const - DST = $00AA0029; // Ternary Raster Operation - Destination unchanged - -var - PicRect: TRect; - AreaRect: TRect; - DrawRect: TRect; - -begin - // clear background - Target.Brush.Color := Color; - Target.FillRect(R); - - // Picture rect in relation to client viewscreen. - PicRect := Rect(FBackgroundOffsetX, FBackgroundOffsetY, FBackgroundOffsetX + Source.Width, FBackgroundOffsetY + Source.Height); - - // Area to be draw in relation to client viewscreen. - AreaRect := Rect(Offset.X + R.Left, Offset.Y + R.Top, Offset.X + R.Right, Offset.Y + R.Bottom); - - // If picture falls in AreaRect, return intersection (DrawRect). - if IntersectRect(DrawRect, PicRect, AreaRect) then - begin - // Draw portion of image which falls in canvas area. - if Source.Transparent then - begin - // Leave transparent area as destination unchanged (DST), copy non-transparent areas to canvas (SRCCOPY). - with DrawRect do - MaskBlt(Target.Handle, Left - Offset.X, Top - Offset.Y, (Right - Offset.X) - (Left - Offset.X), - (Bottom - Offset.Y) - (Top - Offset.Y), Source.Canvas.Handle, Left - PicRect.Left, DrawRect.Top - PicRect.Top, - Source.MaskHandle, Left - PicRect.Left, Top - PicRect.Top, MakeROP4(DST, SRCCOPY)); - end - else - begin - // copy image to destination - with DrawRect do - BitBlt(Target.Handle, Left - Offset.X, Top - Offset.Y, (Right - Offset.X) - (Left - Offset.X), - (Bottom - Offset.Y) - (Top - Offset.Y) + R.Top, Source.Canvas.Handle, Left - PicRect.Left, DrawRect.Top - PicRect.Top, - SRCCOPY); - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.StopTimer(ID: Integer); - -begin - //todo_lcl_block - { - if HandleAllocated then - KillTimer(Handle, ID); - } -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.TileBackground(Source: TBitmap; Target: TCanvas; Offset: TPoint; R: TRect); - -// Draws the given source graphic so that it tiles into the given rectangle which is relative to the target bitmap. -// The graphic is aligned so that it always starts at the upper left corner of the target canvas. -// Offset gives the position of the target window in an possible superordinated surface. - -var - SourceX, - SourceY, - TargetX, - - DeltaY: Integer; - -begin - with Target do - begin - SourceY := (R.Top + Offset.Y + FBackgroundOffsetY) mod Source.Height; - // Always wrap the source coordinates into positive range. - if SourceY < 0 then - SourceY := Source.Height + SourceY; - - // Tile image vertically until target rect is filled. - while R.Top < R.Bottom do - begin - SourceX := (R.Left + Offset.X + FBackgroundOffsetX) mod Source.Width; - // always wrap the source coordinates into positive range - if SourceX < 0 then - SourceX := Source.Width + SourceX; - - TargetX := R.Left; - // height of strip to draw - DeltaY := Min(R.Bottom - R.Top, Source.Height - SourceY); - - // tile the image horizontally - while TargetX < R.Right do - begin - BitBlt(Handle, TargetX, R.Top, Min(R.Right - TargetX, Source.Width - SourceX), DeltaY, - Source.Canvas.Handle, SourceX, SourceY, SRCCOPY); - Inc(TargetX, Source.Width - SourceX); - SourceX := 0; - end; - Inc(R.Top, Source.Height - SourceY); - SourceY := 0; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.ToggleCallback(Step, StepSize: Integer; Data: Pointer): Boolean; - -var - ScrollRect: TRect; - Column: TColumnIndex; - Run: TRect; - - //--------------- local function -------------------------------------------- - - procedure EraseLine; - - var - LocalBrush: HBRUSH; - - begin - with TToggleAnimationData(Data^), FHeader.FColumns do - begin - // Iterate through all columns and erase background in their local color. - // LocalBrush is a brush in the color of the particular column. - Column := ColumnFromPosition(Run.TopLeft); - while (Column > InvalidColumn) and (Run.Left < ClientWidth) do - begin - GetColumnBounds(Column, Run.Left, Run.Right); - if coParentColor in Items[Column].FOptions then - FillRect(DC, Run, Brush) - else - begin - LocalBrush := CreateSolidBrush(ColorToRGB(Items[Column].Color)); - FillRect(DC, Run, LocalBrush); - DeleteObject(LocalBrush); - end; - Column := GetNextVisibleColumn(Column); - end; - end; - end; - - //--------------- end local function ---------------------------------------- - -begin - Result := True; - if StepSize > 0 then - begin - with TToggleAnimationData(Data^) do - begin - ScrollRect := R; - if Expand then - begin - ScrollDC(DC, 0, StepSize, ScrollRect, ScrollRect, 0, nil); - - // In the first step the background must be cleared (only a small stripe) to avoid artefacts. - if Step = 0 then - if not FHeader.UseColumns then - FillRect(DC, Rect(R.Left, R.Top, R.Right, R.Top + StepSize + 1), Brush) - else - begin - Run := Rect(R.Left, R.Top, R.Right, R.Top + StepSize + 1); - EraseLine; - end; - end - else - begin - // Collapse branch. - ScrollDC(DC, 0, -StepSize, ScrollRect, ScrollRect, 0, nil); - - if Step = 0 then - if not FHeader.UseColumns then - FillRect(DC, Rect(R.Left, R.Bottom - StepSize - 1, R.Right, R.Bottom), Brush) - else - begin - Run := Rect(R.Left, R.Bottom - StepSize - 1, R.Right, R.Bottom); - EraseLine; - end; - end; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.CMColorChange(var Message: TLMessage); - -begin - Logger.EnterMethod(lcMessages,'CMColorChange'); - if not (csLoading in ComponentState) then - begin - PrepareBitmaps(True, False); - if HandleAllocated then - Invalidate; - end; - Logger.ExitMethod(lcMessages,'CMColorChange'); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.CMCtl3DChanged(var Message: TLMessage); - -begin - inherited; - if FBorderStyle = bsSingle then - RecreateWnd(Self); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.CMBiDiModeChanged(var Message: TLMessage); - -begin - inherited; - - if UseRightToLeftAlignment then - FEffectiveOffsetX := Integer(FRangeX) - ClientWidth + FOffsetX - else - FEffectiveOffsetX := -FOffsetX; - if FEffectiveOffsetX < 0 then - FEffectiveOffsetX := 0; - - if toAutoBidiColumnOrdering in FOptions.FAutoOptions then - FHeader.FColumns.ReorderColumns(UseRightToLeftAlignment); - FHeader.Invalidate(nil); - Logger.Send(lcPaintDetails,'FEffectiveOffsetX after CMBidiModeChanged',FEffectiveOffsetX); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.CMDenySubclassing(var Message: TLMessage); - -// If a Windows XP Theme Manager component is used in the application it will try to subclass all controls which do not -// explicitly deny this. Virtual Treeview knows how to handle XP themes so it does not need subclassing. - -begin - Message.Result := 1; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.CMDrag(var Message: TCMDrag); - -var - S: TObject; - ShiftState: Integer; - P: TPoint; - Formats: TFormatArray; - -begin - with Message, DragRec^ do - begin - S := Source; - Formats := nil; - - // Let the ancestor handle dock operations. - if S is TDragDockObject then - inherited - else - begin - // We need an extra check for the control drag object as there might be other objects not derived from - // this class (e.g. TActionDragObject). - if not (tsUserDragObject in FStates) and (S is TBaseDragControlObject) then - S := (S as TBaseDragControlObject).Control; - case DragMessage of - dmDragEnter, dmDragLeave, dmDragMove: - begin - if DragMessage = dmDragEnter then - DoStateChange([tsVCLDragging]); - if DragMessage = dmDragLeave then - DoStateChange([], [tsVCLDragging]); - - if DragMessage = dmDragMove then - with ScreenToClient(Pos) do - DoAutoScroll(X, Y); - - ShiftState := 0; - // Alt key will be queried by the KeysToShiftState function in DragOver. - if GetKeyState(VK_SHIFT) < 0 then - ShiftState := ShiftState or MK_SHIFT; - if GetKeyState(VK_CONTROL) < 0 then - ShiftState := ShiftState or MK_CONTROL; - - // Allowed drop effects are simulated for VCL dd. - Result := DROPEFFECT_MOVE or DROPEFFECT_COPY; - DragOver(S, ShiftState, TDragState(DragMessage), Pos, LongWord(Result)); - FLastVCLDragTarget := FDropTargetNode; - FVCLDragEffect := Result; - if (DragMessage = dmDragLeave) and Assigned(FDropTargetNode) then - begin - InvalidateNode(FDropTargetNode); - FDropTargetNode := nil; - end; - end; - dmDragDrop: - begin - ShiftState := 0; - // Alt key will be queried by the KeysToShiftState function in DragOver - if GetKeyState(VK_SHIFT) < 0 then - ShiftState := ShiftState or MK_SHIFT; - if GetKeyState(VK_CONTROL) < 0 then - ShiftState := ShiftState or MK_CONTROL; - - // allowed drop effects are simulated for VCL dd, - // replace target node with cached node from other VCL dd messages - if Assigned(FDropTargetNode) then - InvalidateNode(FDropTargetNode); - FDropTargetNode := FLastVCLDragTarget; - P := Point(Pos.X, Pos.Y); - P := ScreenToClient(P); - DoDragDrop(S, nil, Formats, KeysToShiftState(ShiftState), P, FVCLDragEffect, FLastDropMode); - if Assigned(FDropTargetNode) then - begin - InvalidateNode(FDropTargetNode); - FDropTargetNode := nil; - end; - end; - dmFindTarget: - begin - Result := Integer(ControlAtPos(ScreenToClient(Pos), False)); - if Result = 0 then - Result := Integer(Self); - - // This is a reliable place to check whether VCL drag has - // really begun. - if tsVCLDragPending in FStates then - DoStateChange([tsVCLDragging], [tsVCLDragPending, tsEditPending, tsClearPending]); - end; - end; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.CMEnabledChanged(var Message: TLMessage); - -begin - inherited; - - // Need to invalidate the non-client area as well, since the header must be redrawn too. - if csDesigning in ComponentState then - RedrawWindow(Handle, nil, 0, RDW_FRAME or RDW_INVALIDATE or RDW_NOERASE or RDW_NOCHILDREN); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.CMFontChanged(var Message: TLMessage); - -var - HeaderMessage: TLMessage; - -begin - inherited; - - if not (csLoading in ComponentState) then - begin - PrepareBitmaps(True, False); - if HandleAllocated then - Invalidate; - end; - //todo_lcl Replace this message with a THeader method - HeaderMessage.Msg := CM_PARENTFONTCHANGED; - HeaderMessage.WParam := 0; - HeaderMessage.LParam := 0; - HeaderMessage.Result := 0; - FHeader.HandleMessage(HeaderMessage); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.CMHintShow(var Message: TCMHintShow); - -// Determines hint message (tooltip) and out-of-hint rect. -// Note: A special handling is needed here because we cannot pass wide strings back to the caller. -// I had to introduce the hint data record anyway so we can use this to pass the hint string. -// We still need to set a dummy hint string in the message to make the VCL showing the hint window. - -var - NodeRect: TRect; - SpanColumn, - Dummy, - ColLeft, - ColRight: Integer; - HitInfo: THitInfo; - ShowOwnHint: Boolean; - IsFocusedOrEditing: Boolean; - ParentForm: TCustomForm; - -begin - with Message do - begin - Result := 1; - - if PtInRect(FLastHintRect, HintInfo.CursorPos) then - Exit; - - // Determine node for which to show hint/tooltip. - with HintInfo^ do - GetHitTestInfoAt(CursorPos.X, CursorPos.Y, True, HitInfo); - - // Make sure a hint is only shown if the tree or at least its parent form is active. - // Active editing is ok too as long as we don't want the hint for the current edit node. - if IsEditing then - IsFocusedOrEditing := HitInfo.HitNode <> FFocusedNode - else - begin - IsFocusedOrEditing := Focused; - ParentForm := GetParentForm(Self); - if Assigned(ParentForm) then - IsFocusedOrEditing := ParentForm.Focused or Application.Active; - end; - - if (GetCapture = 0) and ShowHint and not (Dragging or IsMouseSelecting) and ([tsScrolling] * FStates = []) and - (FHeader.States = []) and IsFocusedOrEditing then - begin - with HintInfo^ do - begin - Result := 0; - ShowOwnHint := False; - // Assign a dummy string otherwise the VCL will not show the hint window. - HintStr := ' '; - - // First check whether there is a header hint to show. - if FHeader.UseColumns and (hoShowHint in FHeader.FOptions) and FHeader.InHeader(CursorPos) then - begin - CursorRect := FHeaderRect; - // Convert the cursor rectangle into real client coordinates. - OffsetRect(CursorRect, 0, -Integer(FHeader.FHeight)); - HitInfo.HitColumn := FHeader.FColumns.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); - // Note: the test for the left mouse button in ControlState might cause problems whenever the VCL does not - // realize when the button is released. This, for instance, happens when doing OLE drag'n drop and - // cancel this with ESC. - if (HitInfo.HitColumn > -1) and not (csLButtonDown in ControlState) then - begin - FHintData.DefaultHint := FHeader.FColumns[HitInfo.HitColumn].FHint; - if FHintData.DefaultHint <> '' then - ShowOwnHint := True - else - Result := 1; - end - else - Result := 1; - end - else - begin - // Default mode is handled as would the tree be a usual VCL control (no own hint window necessary). - if FHintMode = hmDefault then - HintStr := GetShortHint(Hint) - else - begin - if Assigned(HitInfo.HitNode) and (HitInfo.HitColumn > InvalidColumn) then - begin - // A draw tree should only display a hint when at least its OnGetHintSize - // event handler is assigned. - if Self is TCustomVirtualDrawTree then - begin - FHintData.HintRect := Rect(0, 0, 0, 0); - with Self as TCustomVirtualDrawTree do - DoGetHintSize(HitInfo.HitNode, HitInfo.HitColumn, FHintData.HintRect); - ShowOwnHint := not IsRectEmpty(FHintData.HintRect); - end - else - // For string trees a decision about showing the hint or not is based - // on the hint string (if it is empty then no hint is shown). - ShowOwnHint := True; - - if ShowOwnHint then - begin - if HitInfo.HitColumn > NoColumn then - begin - FHeader.FColumns.GetColumnBounds(HitInfo.HitColumn, ColLeft, ColRight); - // The right column border might be extended if column spanning is enabled. - if toAutoSpanColumns in FOptions.FAutoOptions then - begin - SpanColumn := HitInfo.HitColumn; - repeat - Dummy := FHeader.FColumns.GetNextVisibleColumn(SpanColumn); - if (Dummy = InvalidColumn) or not ColumnIsEmpty(HitInfo.HitNode, Dummy) then - Break; - SpanColumn := Dummy; - until False; - if SpanColumn <> HitInfo.HitColumn then - FHeader.FColumns.GetColumnBounds(SpanColumn, Dummy, ColRight); - end; - end - else - begin - ColLeft := 0; - ColRight := ClientWidth; - end; - - FHintData.DefaultHint := ''; - if FHintMode <> hmTooltip then - begin - // Node specific hint text. - CursorRect := GetDisplayRect(HitInfo.HitNode, HitInfo.HitColumn, False); - CursorRect.Left := ColLeft; - CursorRect.Right := ColRight; - // Align the vertical hint position on the bottom bound of the node, but - // avoid overlapping of mouse cursor and hint. - HintPos.Y := Max(HintPos.Y, ClientToScreen(CursorRect.BottomRight).Y) + 2; - end - else - begin - // Tool tip to show. This means the full caption of the node must be displayed. - if vsMultiline in HitInfo.HitNode.States then - begin - if hiOnItemLabel in HitInfo.HitPositions then - begin - ShowOwnHint := True; - NodeRect := GetDisplayRect(HitInfo.HitNode, HitInfo.HitColumn, True, False); - end; - end - else - begin - NodeRect := GetDisplayRect(HitInfo.HitNode, HitInfo.HitColumn, True, True); - ShowOwnHint := (HitInfo.HitColumn > InvalidColumn) and PtInRect(NodeRect, CursorPos) and - (CursorPos.X <= ColRight) and (CursorPos.X >= ColLeft) and - ( - // Show hint also if the node text is partially out of the client area. - (NodeRect.Right > Min(ColRight, ClientWidth)) or (NodeRect.Left < Max(ColLeft, 0)) or - (NodeRect.Bottom > ClientHeight) or (NodeRect.Top < 0) - ); - end; - - if ShowOwnHint then - begin - // Node specific hint text given will be retrieved when needed. - FHintData.DefaultHint := ''; - HintPos := ClientToScreen(Point(NodeRect.Left, NodeRect.Top)); - CursorRect := NodeRect; - end - else - // nothing to show - Result := 1; - end; - end - else - Result := 1; // Avoid hint if this is a draw tree returning an empty hint rectangle. - end - else - begin - // No node so fall back to control's hint (if indicated) or show nothing. - if FHintMode = hmHintAndDefault then - begin - FHintData.DefaultHint := GetShortHint(Hint); - if Length(FHintData.DefaultHint) = 0 then - Result := 1 - else - ShowOwnHint := True; - end - else - Result := 1; - end; - end; - end; - - // Set our own hint window class and prepare structure to be passed to the hint window. - if ShowOwnHint and (Result = 0) then - begin - HintWindowClass := GetHintWindowClass; - - FHintData.Tree := Self; - FHintData.Column := HitInfo.HitColumn; - FHintData.Node := HitInfo.HitNode; - FLastHintRect := CursorRect; - HintData := @FHintData; - end - else - FLastHintRect := Rect(0, 0, 0, 0); - end; - - // Remind that a hint is about to show. - if Result = 0 then - DoStateChange([tsHint]) - else - DoStateChange([], [tsHint]); - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.CMHintShowPause(var Message: TCMHintShowPause); - -// Tells the application that the tree (and only the tree) does not want a delayed tool tip. -// Normal hints / header hints use the default delay (except for the first time). - -var - P: TPoint; - -begin - // A little workaround is needed here to make the application class using the correct hint window class. - // Once the application gets ShowHint set to true (which is the case when we want to show hints in the tree) then - // an internal hint window will be created which is not our own class (because we don't set an application wide - // hint window class but only one for the tree). Unfortunately, this default hint window class will prevent - // hints for the non-client area to show up (e.g. for the header) by calling CancelHint whenever certain messages - // arrive. By setting the hint show pause to 0 if our hint class was not used recently we make sure - // that the hint timer (in Forms.pas) is not used and our class is created immediately. - if HintWindowDestroyed then - begin - GetCursorPos(P); - // Check if the mouse is in the header or tool tips are enabled, which must be shown without delay anyway. - if FHeader.UseColumns and (hoShowHint in FHeader.FOptions) and FHeader.InHeader(ScreenToClient(P)) or - (FHintMode = hmToolTip) then - Message.Pause^ := 0 - end - else - if FHintMode = hmToolTip then - Message.Pause^ := 0; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.CMMouseLeave(var Message: TLMessage); - -var - LeaveStates: TVirtualTreeStates; - -begin - Logger.EnterMethod(lcMessages,'CMMouseLeave'); - Logger.Send(lcMessages,'FCurrentHotNode',Integer(Pointer(FCurrentHotNode))); - // Reset the last used hint rectangle in case the mouse enters the window within the bounds - if Assigned(FHintData.Tree) then - FHintData.Tree.FLastHintRect := Rect(0, 0, 0, 0); - - LeaveStates := [tsHint]; - if [tsWheelPanning, tsWheelScrolling] * FStates = [] then - begin - StopTimer(ScrollTimer); - LeaveStates := LeaveStates + [tsScrollPending, tsScrolling]; - end; - DoStateChange([], LeaveStates); - if Assigned(FCurrentHotNode) then - begin - DoHotChange(FCurrentHotNode, nil); - InvalidateNode(FCurrentHotNode); - FCurrentHotNode := nil; - end; - - Header.FColumns.FDownIndex := NoColumn; - Header.FColumns.FHoverIndex := NoColumn; - - inherited CMMouseLeave(Message); - Logger.ExitMethod(lcMessages,'CMMouseLeave'); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.CMMouseWheel(var Message: TLMMouseEvent); - -var - ScrollCount: Integer; - ScrollLines: DWORD; - RTLFactor: Integer; - -begin - //todo: rename to WM* - Logger.EnterMethod(lcScroll,'CMMouseWheel'); - StopWheelPanning; - - //todo: - //The only thing that inherited WMMouseWheel does is to call DoMouseWheel - //in the other hand it call a DefaultHandler that causes bug here. So skip it - //inherited WMMouseWheel(Message); - - if Message.Result = 0 then - begin - with Message do - begin - Result := 1; - if FRangeY > Cardinal(ClientHeight) then - begin - Logger.Send(lcScroll,'Scroll Vertical - WheelDelta', WheelDelta); - // Scroll vertically if there's something to scroll... - if ssCtrl in State then - ScrollCount := WheelDelta div WHEEL_DELTA * (ClientHeight div Integer(FDefaultNodeHeight)) - else - begin - SystemParametersInfo(SPI_GETWHEELSCROLLLINES, 0, @ScrollLines, 0); - if ScrollLines = WHEEL_PAGESCROLL then - ScrollCount := WheelDelta div WHEEL_DELTA * (ClientHeight div Integer(FDefaultNodeHeight)) - else - ScrollCount := Integer(ScrollLines) * WheelDelta div WHEEL_DELTA; - end; - Logger.Send(lcScroll,'ScrollCount',ScrollCount); - SetOffsetY(FOffsetY + ScrollCount * Integer(FDefaultNodeHeight)); - end - else - begin - Logger.Send('Scroll Horizontal - WheelDelta',WheelDelta); - // ...else scroll horizontally. - if UseRightToLeftAlignment then - RTLFactor := -1 - else - RTLFactor := 1; - //todo: State is the same as ShiftState? - if ssCtrl in State then - ScrollCount := WheelDelta div WHEEL_DELTA * ClientWidth - else - ScrollCount := WheelDelta div WHEEL_DELTA; - Logger.Send(lcScroll,'ScrollCount',ScrollCount); - SetOffsetX(FOffsetX + RTLFactor * ScrollCount * Integer(FIndent)); - end; - end; - end; - Logger.ExitMethod(lcScroll,'CMMouseWheel'); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.CMSysColorChange(var Message: TLMessage); - -begin - inherited; - //todo_lcl_block - { - ConvertImageList(LightCheckImages, 'VT_CHECK_LIGHT'); - ConvertImageList(DarkCheckImages, 'VT_CHECK_DARK'); - ConvertImageList(LightTickImages, 'VT_TICK_LIGHT'); - ConvertImageList(DarkTickImages, 'VT_TICK_DARK'); - ConvertImageList(FlatImages, 'VT_FLAT'); - ConvertImageList(UtilityImages, 'VT_UTILITIES'); - } - // XP images do not need to be converted. - // System check images do not need to be converted. - //todo_lcl WM_SYSCOLORCHANGE is not used in lcl - { - Message.Msg := WM_SYSCOLORCHANGE; - DefaultHandler(Message); - } -end; - -//---------------------------------------------------------------------------------------------------------------------- - -{$ifdef EnableNativeTVM} - -procedure TBaseVirtualTree.TVMGetItem(var Message: TLMessage); - -// Screen reader support function. The method returns information about a particular node. - -const - StateMask = TVIS_STATEIMAGEMASK or TVIS_OVERLAYMASK or TVIS_EXPANDED or TVIS_DROPHILITED or TVIS_CUT or - TVIS_SELECTED or TVIS_FOCUSED; - -var - Item: PTVItemEx; - Node: PVirtualNode; - Ghosted: Boolean; - ImageIndex: Integer; - R: TRect; - Text: WideString; - ANSIText: ANSIString; - -begin - // We can only return valid data if a nodes reference is given. - Item := Pointer(Message.LParam); - Message.Result := Ord(((Item.mask and TVIF_HANDLE) <> 0) and Assigned(Item.hItem)); - if Message.Result = 1 then - begin - Node := Pointer(Item.hItem); - // Child count requested? - if (Item.mask and TVIF_CHILDREN) <> 0 then - Item.cChildren := Node.ChildCount; - // Index for normal image requested? - if (Item.mask and TVIF_IMAGE) <> 0 then - begin - Item.iImage := -1; - DoGetImageIndex(Node, ikNormal, -1, Ghosted, Item.iImage); - end; - // Index for selected image requested? - if (Item.mask and TVIF_SELECTEDIMAGE) <> 0 then - begin - Item.iSelectedImage := -1; - DoGetImageIndex(Node, ikSelected, -1, Ghosted, Item.iSelectedImage); - end; - // State info requested? - if (Item.mask and TVIF_STATE) <> 0 then - begin - // Everything, which is possible is returned. - Item.stateMask := StateMask; - Item.state := 0; - if Node = FFocusedNode then - Item.state := Item.state or TVIS_FOCUSED; - if vsSelected in Node.States then - Item.state := Item.state or TVIS_SELECTED; - if vsCutOrCopy in Node.States then - Item.state := Item.state or TVIS_CUT; - if Node = FDropTargetNode then - Item.state := Item.state or TVIS_DROPHILITED; - 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. - ImageIndex := -1; - DoGetImageIndex(Node, ikState, -1, Ghosted, ImageIndex); - Item.state := Item.state or Byte(IndexToStateImageMask(ImageIndex + 1)); - ImageIndex := -1; - DoGetImageIndex(Node, ikOverlay, -1, Ghosted, ImageIndex); - Item.state := Item.state or Byte(IndexToOverlayMask(ImageIndex + 1)); - end; - // Node caption requested? - if (Item.mask and TVIF_TEXT) <> 0 then - begin - GetTextInfo(Node, -1, Font, R, Text); - // Convert the Unicode implicitely to ANSI using the current locale. - ANSIText := Text; - StrLCopy(Item.pszText, PChar(ANSIText), Item.cchTextMax - 1); - Item.pszText[Length(ANSIText)] := #0; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.TVMGetItemRect(var Message: TLMessage); - -// Screen read support function. This method returns a node's display rectangle. - -var - TextOnly: Boolean; - Node: PVirtualNode; - -begin - // The lparam member is used two-way. On enter it contains a pointer to the item (node). - // On exit it is to be considered as pointer to a rectangle structure. - Node := Pointer(Pointer(Message.LParam)^); - Message.Result := Ord(IsVisible[Node]); - if Message.Result <> 0 then - begin - TextOnly := Message.WParam <> 0; - PRect(Message.LParam)^ := GetDisplayRect(Node, -1, TextOnly); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.TVMGetNextItem(var Message: TLMessage); - -// Screen read support function. This method returns a node depending on the requested case. - -var - Node: PVirtualNode; - -begin - // Start with a nil result. - Message.Result := 0; - Node := Pointer(Message.LParam); - case Message.WParam of - TVGN_CARET: - Message.Result := Integer(FFocusedNode); - TVGN_CHILD: - if Assigned(Node) then - Message.Result := Integer(GetFirstChild(Node)); - TVGN_DROPHILITE: - Message.Result := Integer(FDropTargetNode); - TVGN_FIRSTVISIBLE: - Message.Result := Integer(GetFirstVisible); - TVGN_LASTVISIBLE: - Message.Result := Integer(GetLastVisible); - TVGN_NEXT: - if Assigned(Node) then - Message.Result := Integer(GetNextSibling(Node)); - TVGN_NEXTVISIBLE: - if Assigned(Node) then - Message.Result := Integer(GetNextVisible(Node)); - TVGN_PARENT: - if Assigned(Node) and (Node <> FRoot) and (Node.Parent <> FRoot) then - Message.Result := Integer(Node.Parent); - TVGN_PREVIOUS: - if Assigned(Node) then - Message.Result := Integer(GetPreviousSibling(Node)); - TVGN_PREVIOUSVISIBLE: - if Assigned(Node) then - Message.Result := Integer(GetPreviousVisible(Node)); - TVGN_ROOT: - Message.Result := Integer(GetFirst); - end; -end; - -{$endif} - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.WMCancelMode(var Message: TLMNoParams); - -begin - Logger.EnterMethod(lcMessages,'WMCancelMode'); - // Clear any transient state. - StopTimer(ExpandTimer); - StopTimer(EditTimer); - StopTimer(HeaderTimer); - StopTimer(ScrollTimer); - StopTimer(SearchTimer); - FSearchBuffer := ''; - FLastSearchNode := nil; - - DoStateChange([], [tsClearPending, tsEditPending, tsOLEDragPending, tsVCLDragPending, tsDrawSelecting, - tsDrawSelPending, tsIncrementalSearching]); - //lcl does not has a inherited procedure - //inherited WMCancelMode(Message); - Logger.ExitMethod(lcMessages,'WMCancelMode'); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.WMChangeState(var Message: TLMessage); - -var - EnterStates, - LeaveStates: TVirtualTreeStates; - -begin - Logger.EnterMethod(lcMessages,'WMChangeState'); - EnterStates := []; - if csStopValidation in TChangeStates(LongWord(Message.WParam)) then - Include(EnterStates, tsStopValidation); - if csUseCache in TChangeStates(LongWord(Message.WParam)) then - Include(EnterStates, tsUseCache); - if csValidating in TChangeStates(LongWord(Message.WParam)) then - Include(EnterStates, tsValidating); - if csValidationNeeded in TChangeStates(LongWord(Message.WParam)) then - Include(EnterStates, tsValidationNeeded); - - LeaveStates := []; - if csStopValidation in TChangeStates(LongWord(Message.LParam)) then - Include(LeaveStates, tsStopValidation); - if csUseCache in TChangeStates(LongWord(Message.LParam)) then - Include(LeaveStates, tsUseCache); - if csValidating in TChangeStates(LongWord(Message.LParam)) then - Include(LeaveStates, tsValidating); - if csValidationNeeded in TChangeStates(LongWord(Message.LParam)) then - Include(LeaveStates, tsValidationNeeded); - - DoStateChange(EnterStates, LeaveStates); - Logger.ExitMethod(lcMessages,'WMChangeState'); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.WMChar(var Message: TLMChar); - -begin - Logger.EnterMethod(lcMessages,'WMChar'); - if tsIncrementalSearchPending in FStates then - begin - HandleIncrementalSearch(Message.CharCode); - DoStateChange([], [tsIncrementalSearchPending]); - end; - - inherited WMChar(Message); - Logger.ExitMethod(lcMessages,'WMChar'); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.WMContextMenu(var Message: TLMContextMenu); - -// This method is called when a popup menu is about to be displayed. -// We have to cancel some pending states here to avoid interferences. - -begin - Logger.EnterMethod(lcMessages,'WMContextMenu'); - DoStateChange([], [tsClearPending, tsEditPending, tsOLEDragPending, tsVCLDragPending]); - //todo: remove comment after LCL update - //if not (tsPopupMenuShown in FStates) then - // inherited WMContextMenu(Messages); - Logger.ExitMethod(lcMessages,'WMContextMenu'); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.WMCopy(var Message: TLMNoParams); - -begin - Logger.EnterMethod(lcMessages,'WMCopy'); - CopyToClipboard; - Logger.ExitMethod(lcMessages,'WMCopy'); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.WMCut(var Message: TLMNoParams); - -begin - Logger.EnterMethod(lcMessages,'WMCut'); - CutToClipboard; - Logger.ExitMethod(lcMessages,'WMCut'); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.WMEnable(var Message: TLMNoParams); - -begin - Logger.EnterMethod(lcMessages,'WMEnable'); - //LCL does not has inherited WMEnable - //inherited WMEnable(Message); - RedrawWindow(Handle, nil, 0, RDW_FRAME or RDW_INVALIDATE or RDW_NOERASE or RDW_NOCHILDREN); - Logger.EnterMethod(lcMessages,'WMEnable'); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.WMEraseBkgnd(var Message: TLMEraseBkgnd); -var - R: TRect; -begin - Logger.EnterMethod(lcPaint,'WMEraseBkgnd'); - Windows.GetUpdateRect(Handle,R,True); - Logger.Send(lcPaint,'UpdateRect',R); - Message.Result := 1; - Logger.ExitMethod(lcPaint,'WMEraseBkgnd'); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.WMGetDlgCode(var Message: TLMNoParams); - -begin - Logger.Send(lcMessages,'WMGetDlgCode'); - Message.Result := DLGC_WANTCHARS or DLGC_WANTARROWS; - if FWantTabs then - Message.Result := Message.Result or DLGC_WANTTAB; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.WMGetObject(var Message: TLMessage); - -begin - Logger.EnterMethod(lcMessages,'WMGetObject'); - {$ifdef EnableAccessible} - GetAccessibilityFactory; - - // Create the IAccessibles for the tree view and tree view items, if necessary. - if Assigned(VTAccessibleFactory) then - begin - if FAccessible = nil then - FAccessible := VTAccessibleFactory.CreateIAccessible(Self); - if FAccessibleItem = nil then - FAccessibleItem := VTAccessibleFactory.CreateIAccessible(Self); - end; - - if Cardinal(Message.LParam) = OBJID_CLIENT then - if Assigned(Accessible) then - Message.Result := LresultFromObject(IID_IAccessible, Message.WParam, FAccessible) - else - Message.Result := 0; - {$else} - Message.Result := 0; - {$endif} - Logger.ExitMethod(lcMessages,'WMGetObject'); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.WMHScroll(var Message: TLMHScroll); - - //--------------- local functions ------------------------------------------- - - function GetRealScrollPosition: Integer; - - var - SI: TScrollInfo; - Code: Integer; - - begin - SI.cbSize := SizeOf(TScrollInfo); - SI.fMask := SIF_TRACKPOS; - Code := SB_HORZ; - {$ifdef UseFlatScrollbars} - FlatSB_GetScrollInfo(Handle, Code, SI); - {$else} - GetScrollInfo(Handle, Code, SI); - {$endif UseFlatScrollbars} - Result := SI.nTrackPos; - end; - - //--------------- end local functions --------------------------------------- - -var - RTLFactor: Integer; - -begin - Logger.EnterMethod(lcMessages,'WMHScroll'); - if UseRightToLeftAlignment then - RTLFactor := -1 - else - RTLFactor := 1; - - case Message.ScrollCode of - SB_BOTTOM: - SetOffsetX(-Integer(FRangeX)); - SB_ENDSCROLL: - begin - DoStateChange([], [tsThumbTracking]); - // avoiding to adjust the vertical scroll position while tracking makes it much smoother - // but we need to adjust the final position here then - UpdateHorizontalScrollBar(False); - end; - SB_LINELEFT: - SetOffsetX(FOffsetX + RTLFactor * FScrollBarOptions.FIncrementX); - SB_LINERIGHT: - SetOffsetX(FOffsetX - RTLFactor * FScrollBarOptions.FIncrementX); - SB_PAGELEFT: - SetOffsetX(FOffsetX + RTLFactor * ClientWidth); - SB_PAGERIGHT: - SetOffsetX(FOffsetX - RTLFactor * ClientWidth); - SB_THUMBPOSITION, - SB_THUMBTRACK: - begin - DoStateChange([tsThumbTracking]); - if UseRightToLeftAlignment then - SetOffsetX(-Integer(FRangeX) + ClientWidth + GetRealScrollPosition) - else - SetOffsetX(-GetRealScrollPosition); - end; - SB_TOP: - SetOffsetX(0); - end; - - Message.Result := 0; - Logger.ExitMethod(lcMessages,'WMHScroll'); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.WMKeyDown(var Message: TLMKeyDown); - -// Keyboard event handling for node focus, selection, node specific popup menus and help invokation. -// For a detailed description of every action done here read the help. - -var - Shift: TShiftState; - Node, Temp, - LastFocused: PVirtualNode; - Offset: Integer; - ClearPending, - NeedInvalidate, - DoRangeSelect, - HandleMultiSelect: Boolean; - Context: Integer; - ParentControl: TWinControl; - R: TRect; - NewCheckState: TCheckState; - NewColumn: TColumnIndex; - ActAsGrid: Boolean; - ForceSelection: Boolean; - NewHeight: Integer; - RTLFactor: Integer; - - // for tabulator handling - GetStartColumn: function: TColumnIndex of object; - GetNextColumn: function(Column: TColumnIndex): TColumnIndex of object; - GetNextNode: TGetNextNodeProc; - - KeyState: TKeyboardState; - Buffer: array[0..1] of Char; - -begin - Logger.EnterMethod(lcMessages,'WMKeyDown'); - // Make form key preview work and let application modify the key if it wants this. - inherited WMKeyDown(Message); - - with Message do - begin - Shift := KeyDataToShiftState(KeyData); - // Ask the application if the default key handling is desired. - if DoKeyAction(CharCode, Shift) then - begin - if (tsKeyCheckPending in FStates) and (CharCode <> VK_SPACE) then - begin - DoStateChange([], [tskeyCheckPending]); - FCheckNode.CheckState := UnpressedState[FCheckNode.CheckState]; - RepaintNode(FCheckNode); - FCheckNode := nil; - end; - - if CharCode in [VK_HOME, VK_END, VK_PRIOR, VK_NEXT, VK_UP, VK_DOWN, VK_LEFT, VK_RIGHT, VK_BACK, VK_TAB] then - begin - HandleMultiSelect := (ssShift in Shift) and (toMultiSelect in FOptions.FSelectionOptions) and not IsEditing; - - // Flag to avoid range selection in case of single node advance. - DoRangeSelect := (CharCode in [VK_HOME, VK_END, VK_PRIOR, VK_NEXT]) and HandleMultiSelect and not IsEditing; - - NeedInvalidate := DoRangeSelect or (FSelectionCount > 1); - ActAsGrid := toGridExtensions in FOptions.FMiscOptions; - ClearPending := (Shift = []) or (ActAsGrid and not (ssShift in Shift)) or - not (toMultiSelect in FOptions.FSelectionOptions) or (CharCode in [VK_TAB, VK_BACK]); - - // Keep old focused node for range selection. Use a default node if none was focused until now. - LastFocused := FFocusedNode; - if (LastFocused = nil) and (Shift <> []) then - LastFocused := GetFirstVisible; - - // Set an initial range anchor if there is not yet one. - if FRangeAnchor = nil then - FRangeAnchor := GetFirstSelected; - if FRangeAnchor = nil then - FRangeAnchor := GetFirst; - - if UseRightToLeftAlignment then - RTLFactor := -1 - else - RTLFactor := 1; - - // Determine new focused node. - case CharCode of - VK_HOME, VK_END: - begin - if (CharCode = VK_END) xor UseRightToLeftAlignment then - begin - GetStartColumn := FHeader.FColumns.GetLastVisibleColumn; - GetNextColumn := FHeader.FColumns.GetPreviousVisibleColumn; - GetNextNode := GetPreviousVisible; - Node := GetLastVisible; - end - else - begin - GetStartColumn := FHeader.FColumns.GetFirstVisibleColumn; - GetNextColumn := FHeader.FColumns.GetNextVisibleColumn; - GetNextNode := GetNextVisible; - Node := GetFirstVisible; - end; - - // Advance to next/previous visible column. - if FHeader.UseColumns then - NewColumn := GetStartColumn - else - NewColumn := NoColumn; - // Find a column for the new/current node which can be focused. - while (NewColumn > NoColumn) and not DoFocusChanging(FFocusedNode, Node, FFocusedColumn, NewColumn) do - NewColumn := GetNextColumn(NewColumn); - if NewColumn > InvalidColumn then - begin - if (Shift = [ssCtrl]) and not ActAsGrid then - begin - ScrollIntoView(Node, toCenterScrollIntoView in FOptions.SelectionOptions, - not (toDisableAutoscrollOnFocus in FOptions.FAutoOptions)); - if (CharCode = VK_HOME) and not UseRightToLeftAlignment then - SetOffsetX(0) - else - SetOffsetX(-MaxInt); - end - else - begin - if not ActAsGrid or (ssCtrl in Shift) then - FocusedNode := Node; - if ActAsGrid and not (toFullRowSelect in FOptions.FSelectionOptions) then - FocusedColumn := NewColumn; - end; - end; - end; - VK_PRIOR: - if ssCtrl in Shift then - SetOffsetY(FOffsetY + ClientHeight) - else - begin - Offset := 0; - // If there's no focused node then just take the very first visible one. - if FFocusedNode = nil then - Node := GetFirstVisible - else - begin - // Go up as many nodes as comprise together a size of ClientHeight. - Node := FFocusedNode; - while True do - begin - Temp := GetPreviousVisible(Node); - NewHeight := NodeHeight[Node]; - if (Temp = nil) or (Offset + NewHeight >= ClientHeight) then - Break; - Node := Temp; - Inc(Offset, NodeHeight[Node]); - end; - end; - FocusedNode := Node; - end; - VK_NEXT: - if ssCtrl in Shift then - SetOffsetY(FOffsetY - ClientHeight) - else - begin - Offset := 0; - // If there's no focused node then just take the very last one. - if FFocusedNode = nil then - Node := GetLastVisible - else - begin - // Go up as many nodes as comprise together a size of ClientHeight. - Node := FFocusedNode; - while True do - begin - Temp := GetNextVisible(Node); - NewHeight := NodeHeight[Node]; - if (Temp = nil) or (Offset + NewHeight >= ClientHeight) then - Break; - Node := Temp; - Inc(Offset, NewHeight); - end; - end; - FocusedNode := Node; - end; - VK_UP: - begin - // scrolling without selection change - if ssCtrl in Shift then - SetOffsetY(FOffsetY + Integer(FDefaultNodeHeight)) - else - begin - if FFocusedNode = nil then - Node := GetLastVisible - else - Node := GetPreviousVisible(FFocusedNode); - - if Assigned(Node) then - begin - EndEditNode; - if HandleMultiSelect and (CompareNodePositions(LastFocused, FRangeAnchor) > 0) and - Assigned(FFocusedNode) then - RemoveFromSelection(FFocusedNode); - if FFocusedColumn = NoColumn then - FFocusedColumn := FHeader.MainColumn; - FocusedNode := Node; - end - else - if Assigned(FFocusedNode) then - InvalidateNode(FFocusedNode); - end; - end; - VK_DOWN: - begin - // scrolling without selection change - if ssCtrl in Shift then - SetOffsetY(FOffsetY - Integer(FDefaultNodeHeight)) - else - begin - if FFocusedNode = nil then - Node := GetFirstVisible - else - Node := GetNextVisible(FFocusedNode); - - if Assigned(Node) then - begin - EndEditNode; - if HandleMultiSelect and (CompareNodePositions(LastFocused, FRangeAnchor) < 0) and - Assigned(FFocusedNode) then - RemoveFromSelection(FFocusedNode); - if FFocusedColumn = NoColumn then - FFocusedColumn := FHeader.MainColumn; - FocusedNode := Node; - end - else - if Assigned(FFocusedNode) then - InvalidateNode(FFocusedNode); - end; - end; - VK_LEFT: - begin - // special handling - if ssCtrl in Shift then - SetOffsetX(FOffsetX + RTLFactor * Integer(FIndent)) - else - begin - // other special cases - Context := NoColumn; - if (toExtendedFocus in FOptions.FSelectionOptions) and (toGridExtensions in FOptions.FMiscOptions) then - begin - Context := FHeader.Columns.GetPreviousVisibleColumn(FFocusedColumn); - if Context > -1 then - FocusedColumn := Context - end - else - if Assigned(FFocusedNode) and (vsExpanded in FFocusedNode.States) and - (Shift = []) and (vsHasChildren in FFocusedNode.States) then - ToggleNode(FFocusedNode) - else - begin - if FFocusedNode = nil then - FocusedNode := GetFirstVisible - else - begin - if FFocusedNode.Parent <> FRoot then - Node := FFocusedNode.Parent - else - Node := nil; - if Assigned(Node) then - begin - if HandleMultiSelect then - begin - // and a third special case - if FFocusedNode.Index > 0 then - DoRangeSelect := True - else - if CompareNodePositions(Node, FRangeAnchor) > 0 then - RemoveFromSelection(FFocusedNode); - end; - FocusedNode := Node; - end; - end; - end; - end; - end; - VK_RIGHT: - begin - // special handling - if ssCtrl in Shift then - SetOffsetX(FOffsetX - RTLFactor * Integer(FIndent)) - else - begin - // other special cases - Context := NoColumn; - if (toExtendedFocus in FOptions.FSelectionOptions) and (toGridExtensions in FOptions.FMiscOptions) then - begin - Context := FHeader.Columns.GetNextVisibleColumn(FFocusedColumn); - if Context > -1 then - FocusedColumn := Context; - end - else - if Assigned(FFocusedNode) and not (vsExpanded in FFocusedNode.States) and - (Shift = []) and (vsHasChildren in FFocusedNode.States) then - ToggleNode(FFocusedNode) - else - begin - if FFocusedNode = nil then - FocusedNode := GetFirstVisible - else - begin - Node := GetFirstVisibleChild(FFocusedNode); - if Assigned(Node) then - begin - if HandleMultiSelect and (CompareNodePositions(Node, FRangeAnchor) < 0) then - RemoveFromSelection(FFocusedNode); - FocusedNode := Node; - end; - end; - end; - end; - end; - VK_BACK: - if tsIncrementalSearching in FStates then - DoStateChange([tsIncrementalSearchPending]) - else - if Assigned(FFocusedNode) and (FFocusedNode.Parent <> FRoot) then - FocusedNode := FocusedNode.Parent; - VK_TAB: - if (toExtendedFocus in FOptions.FSelectionOptions) and FHeader.UseColumns then - begin - // In order to avoid duplicating source code just to change the direction - // we use function variables. - if ssShift in Shift then - begin - GetStartColumn := FHeader.FColumns.GetLastVisibleColumn; - GetNextColumn := FHeader.FColumns.GetPreviousVisibleColumn; - GetNextNode := GetPreviousVisible; - end - else - begin - GetStartColumn := FHeader.FColumns.GetFirstVisibleColumn; - GetNextColumn := FHeader.FColumns.GetNextVisibleColumn; - GetNextNode := GetNextVisible; - end; - - // Advance to next/previous visible column/node. - Node := FFocusedNode; - NewColumn := GetNextColumn(FFocusedColumn); - repeat - // Find a column for the current node which can be focused. - while (NewColumn > NoColumn) and not DoFocusChanging(FFocusedNode, Node, FFocusedColumn, NewColumn) do - NewColumn := GetNextColumn(NewColumn); - - if NewColumn > NoColumn then - begin - // Set new node and column in one go. - SetFocusedNodeAndColumn(Node, NewColumn); - Break; - end; - - // No next column was accepted for the current node. So advance to next node and try again. - Node := GetNextNode(Node); - NewColumn := GetStartColumn; - until Node = nil; - end; - end; - - // Clear old selection if required but take care to select the new focused node if it was not selected before. - ForceSelection := False; - if ClearPending and ((LastFocused <> FFocusedNode) or (FSelectionCount <> 1)) then - begin - ClearSelection; - ForceSelection := True; - end; - - // Determine new selection anchor. - if Shift = [] then - begin - FRangeAnchor := FFocusedNode; - FLastSelectionLevel := GetNodeLevel(FFocusedNode); - end; - // Finally change the selection for a specific range of nodes. - if DoRangeSelect then - ToggleSelection(LastFocused, FFocusedNode); - - // Make sure the new focused node is also selected. - if Assigned(FFocusedNode) and ((LastFocused <> FFocusedNode) or ForceSelection) then - AddToSelection(FFocusedNode); - - // If a repaint is needed then paint the entire tree because of the ClearSelection call, - if NeedInvalidate then - Invalidate; - end - else - begin - // Second chance for keys not directly concerned with selection changes. - - // For +, -, /, * keys on the main keyboard (not numpad) there is no virtual key code defined. - // We have to do special processing to get them working too. - GetKeyboardState(KeyState); - // Avoid conversion to control characters. We have captured the control key state already in Shift. - KeyState[VK_CONTROL] := 0; - if ToASCII(Message.CharCode, (Message.KeyData shr 16) and 7, KeyState, @Buffer, 0) > 0 then - begin - case Buffer[0] of - '*': - CharCode := VK_MULTIPLY; - '+': - CharCode := VK_ADD; - '/': - CharCode := VK_DIVIDE; - '-': - CharCode := VK_SUBTRACT; - end; - end; - - // According to http://www.it-faq.pl/mskb/99/337.HTM there is a problem with ToASCII when used in conjunction - // with dead chars. The article recommends to call ToASCII twice to restore a deleted flag in the key message - // structure under certain circumstances. It turned out it is best to always call ToASCII twice. - ToASCII(Message.CharCode, (Message.KeyData shr 16) and 7, KeyState, @Buffer, 0); - - case CharCode of - VK_F2: - if (Shift = []) and Assigned(FFocusedNode) and CanEdit(FFocusedNode, FFocusedColumn) then - begin - FEditColumn := FFocusedColumn; - DoEdit; - end; - VK_ADD: - if not (tsIncrementalSearching in FStates) then - begin - if ssCtrl in Shift then - if {$ifdef ReverseFullExpandHotKey} not {$endif ReverseFullExpandHotKey} (ssShift in Shift) then - FullExpand - else - FHeader.AutoFitColumns - else - if Assigned(FFocusedNode) and not (vsExpanded in FFocusedNode.States) then - ToggleNode(FFocusedNode); - end - else - DoStateChange([tsIncrementalSearchPending]); - VK_SUBTRACT: - if not (tsIncrementalSearching in FStates) then - begin - if ssCtrl in Shift then - if {$ifdef ReverseFullExpandHotKey} not {$endif ReverseFullExpandHotKey} (ssShift in Shift) then - FullCollapse - else - FHeader.RestoreColumns - else - if Assigned(FFocusedNode) and (vsExpanded in FFocusedNode.States) then - ToggleNode(FFocusedNode); - end - else - DoStateChange([tsIncrementalSearchPending]); - VK_MULTIPLY: - if not (tsIncrementalSearching in FStates) then - begin - if Assigned(FFocusedNode) then - FullExpand(FFocusedNode); - end - else - DoStateChange([tsIncrementalSearchPending]); - VK_DIVIDE: - if not (tsIncrementalSearching in FStates) then - begin - if Assigned(FFocusedNode) then - FullCollapse(FFocusedNode); - end - else - DoStateChange([tsIncrementalSearchPending]); - VK_ESCAPE: // cancel actions currently in progress - begin - if IsMouseSelecting then - begin - DoStateChange([], [tsDrawSelecting, tsDrawSelPending]); - Invalidate; - end - else - if IsEditing then - CancelEditNode; - end; - VK_SPACE: - if (toCheckSupport in FOptions.FMiscOptions) and Assigned(FFocusedNode) and - (FFocusedNode.CheckType <> ctNone) then - begin - if (FStates * [tsKeyCheckPending, tsMouseCheckPending] = []) and Assigned(FFocusedNode) and - not (vsDisabled in FFocusedNode.States) then - begin - with FFocusedNode^ do - NewCheckState := DetermineNextCheckState(CheckType, CheckState); - if DoChecking(FFocusedNode, NewCheckState) then - begin - DoStateChange([tsKeyCheckPending]); - FCheckNode := FFocusedNode; - FPendingCheckState := NewCheckState; - FCheckNode.CheckState := PressedState[FCheckNode.CheckState]; - RepaintNode(FCheckNode); - end; - end; - end - else - DoStateChange([tsIncrementalSearchPending]); - VK_F1: - if Assigned(FOnGetHelpContext) then - begin - Context := 0; - if Assigned(FFocusedNode) then - begin - Node := FFocusedNode; - // Traverse the tree structure up to the root. - repeat - FOnGetHelpContext(Self, Node, 0, Context); - Node := Node.Parent; - until (Node = FRoot) or (Context <> 0); - end; - - // If no help context could be found try the tree's one or its parent's contexts. - ParentControl := Self; - while Assigned(ParentControl) and (Context = 0) do - begin - Context := ParentControl.HelpContext; - ParentControl := ParentControl.Parent; - end; - if Context <> 0 then - Application.HelpContext(Context); - end; - VK_APPS: - if Assigned(FFocusedNode) then - begin - R := GetDisplayRect(FFocusedNode, FFocusedColumn, True); - Offset := DoGetNodeWidth(FFocusedNode, FFocusedColumn); - if FFocusedColumn >= 0 then - begin - if Offset > FHeader.Columns[FFocusedColumn].Width then - Offset := FHeader.Columns[FFocusedColumn].Width; - end - else - begin - if Offset > ClientWidth then - Offset := ClientWidth; - end; - DoPopupMenu(FFocusedNode, FFocusedColumn, Point(R.Left + Offset div 2, (R.Top + R.Bottom) div 2)); - end; - Ord('a'), Ord('A'): - if ssCtrl in Shift then - SelectAll(True) - else - DoStateChange([tsIncrementalSearchPending]); - else - begin - // Use the key for incremental search. - // Since we are dealing with Unicode all the time there should be a more sophisticated way - // of checking for valid characters for incremental search. - // This is available but would require to include a significant amount of Unicode character - // properties, so we stick with the simple space check. - if (Shift * [ssCtrl, ssAlt] = []) and (CharCode >= 32) then - DoStateChange([tsIncrementalSearchPending]); - end; - end; - end; - end; - end; - Logger.ExitMethod(lcMessages,'WMKeyDown'); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.WMKeyUp(var Message: TLMKeyUp); - -begin - Logger.EnterMethod(lcMessages,'WMKeyUp'); - inherited WMKeyUp(Message); - - case Message.CharCode of - VK_SPACE: - if tsKeyCheckPending in FStates then - begin - DoStateChange([], [tskeyCheckPending]); - if FCheckNode = FFocusedNode then - DoCheckClick(FCheckNode, FPendingCheckState); - InvalidateNode(FCheckNode); - FCheckNode := nil; - end; - end; - Logger.ExitMethod(lcMessages,'WMKeyUp'); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.WMKillFocus(var Msg: TLMKillFocus); - -var - Form: TCustomForm; - Control: TWinControl; - Pos: TSmallPoint; - Unknown: IUnknown; - -begin - Logger.EnterMethod(lcMessages,'WMKillFocus'); - inherited WMKillFocus(Msg); - - // Stop wheel panning if active. - StopWheelPanning; - - // Don't let any timer continue if the tree is no longer the active control (except change timers). - StopTimer(ExpandTimer); - StopTimer(EditTimer); - StopTimer(HeaderTimer); - StopTimer(ScrollTimer); - StopTimer(SearchTimer); - FSearchBuffer := ''; - FLastSearchNode := nil; - - DoStateChange([], [tsScrollPending, tsScrolling, tsEditPending, tsLeftButtonDown, tsRightButtonDown, - tsMiddleButtonDown, tsOLEDragPending, tsVCLDragPending, tsIncrementalSearching]); - - if (FSelectionCount > 0) or not (toGhostedIfUnfocused in FOptions.FPaintOptions) then - Invalidate - else - if Assigned(FFocusedNode) then - InvalidateNode(FFocusedNode); - - // Workaround for wrapped non-VCL controls (like TWebBrowser), which do not use VCL mechanisms and - // leave the ActiveControl property in the wrong state, which causes trouble when the control is refocused. - Form := GetParentForm(Self); - if Assigned(Form) and (Form.ActiveControl = Self) then - begin - //todo_lcl_check Probably this code is not necessary. LCL does not has TOLEControl AFAIK - { - Cardinal(Pos) := GetMessagePos; - Control := FindVCLWindow(SmallPointToPoint(Pos)); - - // Every control derived from TOleControl has potentially the focus problem. In order to avoid including - // the OleCtrls unit (which will, among others, include Variants), which would allow to test for the TOleControl - // class, the IOleClientSite interface is used for the test, which is supported by TOleControl and a good indicator. - - if Assigned(Control) and Control.GetInterface(IOleClientSite, Unknown) then - Form.ActiveControl := nil; - } - // For other classes the active control should not be modified. Otherwise you need two clicks to select it. - end; - Logger.ExitMethod(lcMessages,'WMKillFocus'); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.WMLButtonDblClk(var Message: TLMLButtonDblClk); - -var - HitInfo: THitInfo; - -begin - Logger.EnterMethod(lcMessages,'WMLButtonDblClk'); - DoStateChange([tsLeftDblClick]); - //LCL does not has a inherited WMLButtonDblClick - //inherited WMLButtonDblClick(Message); - - // get information about the hit - GetHitTestInfoAt(Message.XPos, Message.YPos, True, HitInfo); - HandleMouseDblClick(Message, HitInfo); - DoStateChange([], [tsLeftDblClick]); - Logger.ExitMethod(lcMessages,'WMLButtonDblClk'); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.WMLButtonDown(var Message: TLMLButtonDown); - -var - HitInfo: THitInfo; - -begin - Logger.EnterMethod(lcMessages,'WMLButtonDown'); - DoStateChange([tsLeftButtonDown]); - inherited WMLButtonDown(Message); - - // get information about the hit - GetHitTestInfoAt(Message.XPos, Message.YPos, True, HitInfo); - HandleMouseDown(Message, HitInfo); - Logger.ExitMethod(lcMessages,'WMLButtonDown'); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.WMLButtonUp(var Message: TLMLButtonUp); - -var - HitInfo: THitInfo; - -begin - Logger.EnterMethod(lcMessages,'WMLButtonUp'); - DoStateChange([], [tsLeftButtonDown]); - - // get information about the hit - GetHitTestInfoAt(Message.XPos, Message.YPos, True, HitInfo); - HandleMouseUp(Message, HitInfo); - - inherited WMLButtonUp(Message); - Logger.ExitMethod(lcMessages,'WMLButtonUp'); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.WMMButtonDblClk(var Message: TLMMButtonDblClk); - -var - HitInfo: THitInfo; - -begin - Logger.EnterMethod(lcMessages,'WMMButtonDblClk'); - DoStateChange([tsMiddleDblClick]); - inherited WMMButtonDblClk(Message); - - // get information about the hit - if toMiddleClickSelect in FOptions.FSelectionOptions then - begin - GetHitTestInfoAt(Message.XPos, Message.YPos, True, HitInfo); - HandleMouseDblClick(Message, HitInfo); - end; - DoStateChange([], [tsMiddleDblClick]); - Logger.ExitMethod(lcMessages,'WMMButtonDblClk'); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.WMMButtonDown(var Message: TLMMButtonDown); - -var - HitInfo: THitInfo; - -begin - Logger.EnterMethod(lcMessages,'WMMButtonDown'); - DoStateChange([tsMiddleButtonDown]); - - if FHeader.FStates = [] then - begin - inherited WMMButtonDown(Message); - - // Start wheel panning or scrolling if not already active, allowed and scrolling is useful at all. - if (toWheelPanning in FOptions.FMiscOptions) and ([tsWheelScrolling, tsWheelPanning] * FStates = []) and - ((Integer(FRangeX) > ClientWidth) or (Integer(FRangeY) > ClientHeight)) then - begin - FLastClickPos := SmallPointToPoint(Message.Pos); - StartWheelPanning(FLastClickPos); - end - else - begin - StopWheelPanning; - - // Get information about the hit. - if toMiddleClickSelect in FOptions.FSelectionOptions then - begin - GetHitTestInfoAt(Message.XPos, Message.YPos, True, HitInfo); - HandleMouseDown(Message, HitInfo); - end; - end; - end; - Logger.ExitMethod(lcMessages,'WMMButtonDown'); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.WMMButtonUp(var Message: TLMMButtonUp); - -var - HitInfo: THitInfo; - -begin - Logger.EnterMethod(lcMessages,'WMMButtonUp'); - DoStateChange([], [tsMiddleButtonDown]); - - // If wheel panning/scrolling is active and the mouse has not yet been moved then the user starts wheel auto scrolling. - // Indicate this by removing the panning flag. Otherwise (the mouse has moved meanwhile) stop panning. - if [tsWheelPanning, tsWheelScrolling] * FStates <> [] then - begin - if tsWheelScrolling in FStates then - DoStateChange([], [tsWheelPanning]) - else - StopWheelPanning; - end - else - if FHeader.FStates = [] then - begin - inherited WMMButtonUp(Message); - - // get information about the hit - if toMiddleClickSelect in FOptions.FSelectionOptions then - begin - GetHitTestInfoAt(Message.XPos, Message.YPos, True, HitInfo); - HandleMouseUp(Message, HitInfo); - end; - end; - Logger.ExitMethod('WMMButtonUp'); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -{$ifdef EnableNCFunctions} - -procedure TBaseVirtualTree.WMNCCalcSize(var Message: TLMNCCalcSize); - -begin - Logger.EnterMethod(lcMessages,'WMNCCalcSize'); - inherited WMNCCalcSize(Message); - - with FHeader do - if hoVisible in FHeader.FOptions then - with Message.CalcSize_Params^ do - Inc(rgrc[0].Top, FHeight); - Logger.ExitMethod(lcMessages,'WMNCCalcSize'); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.WMNCDestroy(var Message: TWMNCDestroy); - -// Used to release a reference of the drag manager. This is the only reliable way we get notified about -// window destruction, because of the automatic release of a window if its parent window is freed. - -begin - Logger.EnterMethod(lcMessages,'WMNCDestroy'); - InterruptValidation; - - StopTimer(ChangeTimer); - StopTimer(StructureChangeTimer); - - if not (csDesigning in ComponentState) and (toAcceptOLEDrop in FOptions.FMiscOptions) then - RevokeDragDrop(Handle); - - // Clean up other stuff. - DeleteObject(FDottedBrush); - FDottedBrush := 0; - if tsInAnimation in FStates then - HintWindowDestroyed := True; // Stop any pending animation. - - inherited WMNCDestroy(Message); - Logger.ExitMethod(lcMessages,'WMNCDestroy') -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.WMNCHitTest(var Message: TWMNCHitTest); - -begin - Logger.EnterMethod(lcMessages,'WMNCHitTest'); - inherited WMNCHitTest(Message); - if not (csDesigning in ComponentState) and (hoVisible in FHeader.FOptions) and - FHeader.InHeader(ScreenToClient(SmallPointToPoint(Message.Pos))) then - Message.Result := HTBORDER; - Logger.ExitMethod(lcMessages,'WMNCHitTest'); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.WMNCPaint(var Message: TRealWMNCPaint); - -var - DC: HDC; - R: TRect; - Flags: DWORD; - {$ifdef ThemeSupport} - ExStyle: Integer; - TempRgn: HRGN; - BorderWidth, - BorderHeight: Integer; - {$endif ThemeSupport} - -begin - Logger.EnterMethod(lcMessages,'WMNCPaint'); - {$ifdef ThemeSupport} - if tsUseThemes in FStates then - begin - // If theming is enabled and the client edge border is set for the window then prevent the default window proc - // from painting the old border to avoid flickering. - ExStyle := GetWindowLong(Handle, GWL_EXSTYLE); - if (ExStyle and WS_EX_CLIENTEDGE) <> 0 then - begin - GetWindowRect(Handle, R); - // Determine width of the client edge. - BorderWidth := GetSystemMetrics(SM_CXEDGE); - BorderHeight := GetSystemMetrics(SM_CYEDGE); - InflateRect(R, -BorderWidth, -BorderHeight); - TempRgn := CreateRectRgnIndirect(R); - // Exclude the border from the message region if there is one. Otherwise just use the inflated - // window area region. - if Message.Rgn <> 1 then - CombineRgn(TempRgn, Message.Rgn, TempRgn, RGN_AND); - DefWindowProc(Handle, Message.Msg, Integer(TempRgn), 0); - DeleteObject(TempRgn); - end - else - DefaultHandler(Message); - end - else - {$endif ThemeSupport} - DefaultHandler(Message); - - Flags := DCX_CACHE or DCX_CLIPSIBLINGS or DCX_WINDOW or DCX_VALIDATE; - - if (Message.Rgn = 1) or not IsWinNT then - DC := GetDCEx(Handle, 0, Flags) - else - DC := GetDCEx(Handle, Message.Rgn, Flags or DCX_INTERSECTRGN); - - if DC <> 0 then - begin - if hoVisible in FHeader.FOptions then - begin - R := FHeaderRect; - FHeader.FColumns.PaintHeader(DC, R, -FEffectiveOffsetX); - end; - OriginalWMNCPaint(DC); - ReleaseDC(Handle, DC); - end; - {$ifdef ThemeSupport} - if tsUseThemes in FStates then - ThemeServices.PaintBorder(Self, False); - {$endif ThemeSupport} - Logger.ExitMethod(lcMessages,'WMNCPaint'); -end; - -{$endif} - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.WMPaint(var Message: TLMPaint); - -begin - Logger.EnterMethod(lcMessages,'WMPaint'); - //todo: - //Windows.GetUpdateRect is always empty because BeginPaint was called - //see if PaintStruct has the same rect - if tsVCLDragging in FStates then - ImageList_DragShowNolock(False); - if csPaintCopy in ControlState then - FUpdateRect := ClientRect - else - FUpdateRect:=Message.PaintStruct^.rcPaint; - //Windows.GetUpdateRect(Handle,FUpdateRect,True); - - Logger.Send(lcPaint,'FUpdateRect', FUpdateRect); - - inherited WMPaint(Message); - - if tsVCLDragging in FStates then - ImageList_DragShowNolock(True); - Logger.ExitMethod(lcMessages,'WMPaint'); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.WMPaste(var Message: TLMNoParams); - -begin - Logger.EnterMethod(lcMessages,'WMPaste'); - PasteFromClipboard; - Logger.ExitMethod(lcMessages,'WMPaste'); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -{$ifdef EnablePrintFunctions} - -procedure TBaseVirtualTree.WMPrint(var Message: TWMPrint); - -// This message is sent to request that the tree draws itself to a given device context. This includes not only -// the client area but also the non-client area (header!). - -begin - Logger.EnterMethod(lcMessages,'WMPrint'); - // Draw only if the window is visible or visibility is not required. - if ((Message.Flags and PRF_CHECKVISIBLE) = 0) or IsWindowVisible(Handle) then - Header.Columns.PaintHeader(Message.DC, FHeaderRect, -FEffectiveOffsetX); - - inherited WMPrint(Message); - Logger.ExitMethod(lcMessages,'WMPrint'); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.WMPrintClient(var Message: TWMPrintClient); - -var - Window: TRect; - Target: TPoint; - Canvas: TCanvas; - -begin - Logger.EnterMethod(lcMessages,'WMPrintClient'); - // Draw only if the window is visible or visibility is not required. - if ((Message.Flags and PRF_CHECKVISIBLE) = 0) or IsWindowVisible(Handle) then - begin - // Determine area of the entire tree to be displayed in the control. - Window := ClientRect; - Target := Window.TopLeft; - - // The Window rectangle is given in client coordinates. We have to convert it into - // a sliding window of the tree image. - OffsetRect(Window, FEffectiveOffsetX, -FOffsetY); - - Canvas := TCanvas.Create; - try - Canvas.Handle := Message.DC; - PaintTree(Canvas, Window, Target, [poBackground, poDrawFocusRect, poDrawDropMark, poDrawSelection, poGridLines]); - finally - Canvas.Handle := 0; - Canvas.Free; - end; - end; - Logger.ExitMethod(lcMessages,'WMPrintClient'); -end; - -{$endif} -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.WMRButtonDblClk(var Message: TLMRButtonDblClk); - -var - HitInfo: THitInfo; - -begin - Logger.EnterMethod(lcMessages,'WMRButtonDblClk'); - DoStateChange([tsRightDblClick]); - inherited WMRButtonDblClk(Message); - - // get information about the hit - if toMiddleClickSelect in FOptions.FSelectionOptions then - begin - GetHitTestInfoAt(Message.XPos, Message.YPos, True, HitInfo); - HandleMouseDblClick(Message, HitInfo); - end; - DoStateChange([], [tsRightDblClick]); - Logger.ExitMethod(lcMessages,'WMRButtonDblClk'); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.WMRButtonDown(var Message: TLMRButtonDown); - -var - HitInfo: THitInfo; - -begin - Logger.EnterMethod(lcMessages,'WMRButtonDown'); - DoStateChange([tsRightButtonDown]); - - if FHeader.FStates = [] then - begin - inherited WMRButtonDown(Message); - - // get information about the hit - if toRightClickSelect in FOptions.FSelectionOptions then - begin - GetHitTestInfoAt(Message.XPos, Message.YPos, True, HitInfo); - HandleMouseDown(Message, HitInfo); - end; - end; - Logger.ExitMethod(lcMessages,'WMRButtonDown'); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.WMRButtonUp(var Message: TLMRButtonUp); - -// handle right click selection and node specific popup menu - -var - HitInfo: THitInfo; - -begin - Logger.EnterMethod(lcMessages,'WMRButtonUp'); - DoStateChange([], [tsPopupMenuShown, tsRightButtonDown]); - - if FHeader.FStates = [] then - begin - Application.CancelHint; - - if IsMouseSelecting and Assigned(PopupMenu) then - begin - // Reset selection state already here, before the inherited handler opens the default menu. - DoStateChange([], [tsDrawSelecting, tsDrawSelPending]); - Invalidate; - end; - - inherited WMRButtonUp(Message); - - // get information about the hit - GetHitTestInfoAt(Message.XPos, Message.YPos, True, HitInfo); - - if toRightClickSelect in FOptions.FSelectionOptions then - HandleMouseUp(Message, HitInfo); - - if not Assigned(PopupMenu) then - DoPopupMenu(HitInfo.HitNode, HitInfo.HitColumn, Point(Message.XPos, Message.YPos)); - end; - Logger.ExitMethod(lcMessages,'WMRButtonUp'); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.WMSetCursor(var Message: TLMessage); - -// Sets the hot node mouse cursor for the tree. Cursor changes for the header are handled in Header.HandleMessage. - -var - NewCursor: TCursor; - -begin - Logger.EnterMethod(lcSetCursor,'WMSetCursor'); - { - with Message do - begin - if (CursorWnd = Handle) and not (csDesigning in ComponentState) and - ([tsWheelPanning, tsWheelScrolling] * FStates = []) then - begin - if not FHeader.HandleMessage(TLMessage(Message)) then - begin - // Apply own cursors only if there is no global cursor set. - if Screen.Cursor = crDefault then - begin - if (toHotTrack in FOptions.PaintOptions) and Assigned(FCurrentHotNode) and (FHotCursor <> crDefault) then - NewCursor := FHotCursor - else - NewCursor := Cursor; - - DoGetCursor(NewCursor); - LCLIntf.SetCursor(Screen.Cursors[NewCursor]); - Message.Result := 1; - end - else - inherited WMSetCursor(Message); - end; - end - else - inherited WMSetCursor(Message); - end; - } - Logger.ExitMethod(lcSetCursor,'WMSetCursor'); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.WMSetFocus(var Msg: TLMSetFocus); - -begin - Logger.EnterMethod(lcMessages,'WMSetFocus') ; - inherited WMSetFocus(Msg); - if (FSelectionCount > 0) or not (toGhostedIfUnfocused in FOptions.FPaintOptions) then - Invalidate; - Logger.ExitMethod(lcMessages,'WMSetFocus'); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.WMSize(var Message: TLMSize); - -begin - Logger.EnterMethod(lcMessages,'WMSize'); - inherited WMSize(Message); - - // Need to update scroll bars here. This will cause a recursion because of the change of the client area - // when changing a scrollbar. Usually this is no problem since with the second level recursion no change of the - // window size happens (the same values for the scrollbars are set, which shouldn't cause a window size change). - // Appearently, this applies not to all systems, however. - if HandleAllocated and ([tsSizing, tsWindowCreating] * FStates = []) and (ClientHeight > 0) then - try - DoStateChange([tsSizing]); - // This call will invalidate the entire non-client area which needs recalculation on resize. - FHeader.RecalculateHeader; - FHeader.UpdateSpringColumns; - UpdateScrollBars(True); - - if (tsEditing in FStates) and not FHeader.UseColumns then - UpdateEditBounds; - finally - DoStateChange([], [tsSizing]); - end; - Logger.ExitMethod(lcMessages,'WMSize'); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -{$ifdef ThemeSupport} - - procedure TBaseVirtualTree.WMThemeChanged(var Message: TLMessage); - - begin - inherited; - - {$ifndef COMPILER_7_UP} - ThemeServices.UpdateThemes; - {$endif COMPILER_7_UP} - if ThemeServices.ThemesEnabled and (toThemeAware in TreeOptions.PaintOptions) then - DoStateChange([tsUseThemes]) - else - DoStateChange([], [tsUseThemes]); - RedrawWindow(Handle, nil, 0, RDW_INVALIDATE or RDW_VALIDATE or RDW_FRAME); - end; - -{$endif ThemeSupport} - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.WMTimer(var Message: TLMessage); - -// centralized timer handling happens here - -begin - Logger.EnterMethod(lcMessages,'WMTimer'); - {$ifdef EnableTimer} - with Message do - begin - case TimerID of - ExpandTimer: - DoDragExpand; - EditTimer: - DoEdit; - ScrollTimer: - begin - if tsScrollPending in FStates then - begin - Application.CancelHint; - // Scroll delay has elapsed, set to normal scroll interval now. - SetTimer(Handle, ScrollTimer, FAutoScrollInterval, nil); - DoStateChange([tsScrolling], [tsScrollPending]); - end; - DoTimerScroll; - end; - ChangeTimer: - DoChange(FLastChangedNode); - StructureChangeTimer: - DoStructureChange(FLastStructureChangeNode, FLastStructureChangeReason); - SearchTimer: - begin - // When this event triggers then the user did not pressed any key for the specified timeout period. - // Hence incremental searching is stopped. - DoStateChange([], [tsIncrementalSearching]); - StopTimer(SearchTimer); - FSearchBuffer := ''; - FLastSearchNode := nil; - end; - end; - end; - {$endif} - Logger.ExitMethod(lcMessages,'WMTimer'); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.WMVScroll(var Message: TLMVScroll); - - //--------------- local functions ------------------------------------------- - - function GetRealScrollPosition: Integer; - - var - SI: TScrollInfo; - Code: Integer; - - begin - SI.cbSize := SizeOf(TScrollInfo); - SI.fMask := SIF_TRACKPOS; - Code := SB_VERT; - {$ifdef UseFlatScrollbars} - FlatSB_GetScrollInfo(Handle, Code, SI); - {$else} - GetScrollInfo(Handle, Code, SI); - {$endif UseFlatScrollbars} - Result := SI.nTrackPos; - Logger.Send(lcScroll,'GetRealScrollPosition',Result); - end; - - //--------------- end local functions --------------------------------------- - -begin - Logger.EnterMethod(lcScroll,'WMVScroll'); - Logger.SendCallStack(lcScroll,'CallStack'); - case Message.ScrollCode of - SB_BOTTOM: - SetOffsetY(-Integer(FRoot.TotalHeight)); - SB_ENDSCROLL: - begin - DoStateChange([], [tsThumbTracking]); - // Avoiding to adjust the horizontal scroll position while tracking makes scrolling much smoother - // but we need to adjust the final position here then. - UpdateScrollBars(True); - // Really weird invalidation needed here (and I do it only because it happens so rarely), because - // when showing the horizontal scrollbar while scrolling down using the down arrow button, - // the button will be repainted on mouse up (at the wrong place in the far right lower corner)... - RedrawWindow(Handle, nil, 0, RDW_FRAME or RDW_INVALIDATE or RDW_NOERASE or RDW_NOCHILDREN); - end; - SB_LINEUP: - SetOffsetY(FOffsetY + FScrollBarOptions.FIncrementY); - SB_LINEDOWN: - SetOffsetY(FOffsetY - FScrollBarOptions.FIncrementY); - SB_PAGEUP: - SetOffsetY(FOffsetY + ClientHeight); - SB_PAGEDOWN: - SetOffsetY(FOffsetY - ClientHeight); - - SB_THUMBPOSITION, - SB_THUMBTRACK: - begin - DoStateChange([tsThumbTracking]); - SetOffsetY(-GetRealScrollPosition); - end; - SB_TOP: - SetOffsetY(0); - end; - Message.Result := 0; - Logger.ExitMethod(lcScroll,'WMVScroll'); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.AddToSelection(Node: PVirtualNode); - -var - Changed: Boolean; - -begin - Assert(Assigned(Node), 'Node must not be nil!'); - FSingletonNodeArray[0] := Node; - Changed := InternalAddToSelection(FSingletonNodeArray, 1, False); - if Changed then - begin - InvalidateNode(Node); - Change(Node); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.AddToSelection(const NewItems: TNodeArray; NewLength: Integer; ForceInsert: Boolean = False); - -// Adds the given items all at once into the current selection array. NewLength is the amount of -// nodes to add (necessary to allow NewItems to be larger than the actual used entries). -// ForceInsert is True if nodes must be inserted without consideration of level select constraint or -// already set selected flags (e.g. when loading from stream). -// Note: In the case ForceInsert is True the caller is responsible for making sure the new nodes aren't already in the -// selection array! - -var - Changed: Boolean; - -begin - Changed := InternalAddToSelection(NewItems, NewLength, ForceInsert); - if Changed then - begin - if NewLength = 1 then - begin - InvalidateNode(NewItems[0]); - Change(NewItems[0]); - end - else - begin - Invalidate; - Change(nil); - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.AdjustPaintCellRect(var PaintInfo: TVTPaintInfo; var NextNonEmpty: TColumnIndex); - -// Used in descendants to modify the paint rectangle of the current column while painting a certain node. - -begin - // Since cells are always drawn from left to right the next column index is independent of the - // bidi mode, but not the column borders, which might change depending on the cell's content. - NextNonEmpty := FHeader.FColumns.GetNextVisibleColumn(PaintInfo.Column); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.AdjustPanningCursor(X, Y: Integer); - -// Triggered by a mouse move when wheel panning/scrolling is active. -// Loads the proper cursor which indicates into which direction scrolling is done. - -var - Name: string; - NewCursor: HCURSOR; - ScrollHorizontal, - ScrollVertical: Boolean; - -begin - ScrollHorizontal := Integer(FRangeX) > ClientWidth; - ScrollVertical := Integer(FRangeY) > ClientHeight; - - if (Abs(X - FLastClickPos.X) < 8) and (Abs(Y - FLastClickPos.Y) < 8) then - begin - // Mouse is in the neutral zone. - if ScrollHorizontal then - begin - if ScrollVertical then - Name := 'VT_MOVEALL' - else - Name := 'VT_MOVEEW' - end - else - Name := 'VT_MOVENS'; - end - else - begin - // One of 8 directions applies: north, north-east, east, south-east, south, south-west, west and north-west. - // Check also if scrolling in the particular direction is possible. - if ScrollVertical and ScrollHorizontal then - begin - // All directions allowed. - if X - FlastClickPos.X < -8 then - begin - // Left hand side. - if Y - FLastClickPos.Y < -8 then - Name := 'VT_MOVENW' - else - if Y - FLastClickPos.Y > 8 then - Name := 'VT_MOVESW' - else - Name := 'VT_MOVEW'; - end - else - if X - FLastClickPos.X > 8 then - begin - // Right hand side. - if Y - FLastClickPos.Y < -8 then - Name := 'VT_MOVENE' - else - if Y - FLastClickPos.Y > 8 then - Name := 'VT_MOVESE' - else - Name := 'VT_MOVEE'; - end - else - begin - // Up or down. - if Y < FLastClickPos.Y then - Name := 'VT_MOVEN' - else - Name := 'VT_MOVES'; - end; - end - else - if ScrollHorizontal then - begin - // Only horizontal movement allowed. - if X < FlastClickPos.X then - Name := 'VT_MOVEW' - else - Name := 'VT_MOVEE'; - end - else - begin - // Only vertical movement allowed. - if Y < FlastClickPos.Y then - Name := 'VT_MOVEN' - else - Name := 'VT_MOVES'; - end; - end; - - // Now load the cursor and apply it. - //todo_lcl See a way to avoid callig LoadCursor every time. Add a log to see how frequent is - // DeleteObject is necessary - NewCursor := LoadCursorFromLazarusResource(Name); - if FPanningCursor <> NewCursor then - begin - DeleteObject(FPanningCursor); - FPanningCursor := NewCursor; - LCLIntf.SetCursor(FPanningCursor); - end - else - DeleteObject(NewCursor); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.AdviseChangeEvent(StructureChange: Boolean; Node: PVirtualNode; Reason: TChangeReason); - -// Used to register a delayed change event. If StructureChange is False then we have a selection change event (without -// a specific reason) otherwise it is a structure change. - -begin - if StructureChange then - begin - if tsStructureChangePending in FStates then - StopTimer(StructureChangeTimer) - else - DoStateChange([tsStructureChangePending]); - - FLastStructureChangeNode := Node; - if FLastStructureChangeReason = crIgnore then - FLastStructureChangeReason := Reason - else - if Reason <> crIgnore then - FLastStructureChangeReason := crAccumulated; - end - else - begin - if tsChangePending in FStates then - StopTimer(ChangeTimer) - else - DoStateChange([tsChangePending]); - - FLastChangedNode := Node; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.AllocateInternalDataArea(Size: Cardinal): Cardinal; - -// Simple registration method to be called by each descendant to claim their internal data area. -// Result is the offset from the begin of the node to the internal data area of the calling tree class. - -begin - Assert((FRoot = nil) or (FRoot.ChildCount = 0), 'Internal data allocation must be done before any node is created.'); - Logger.Send('FTotalInternalDataSize BEFORE',FTotalInternalDataSize); - Logger.Send('Size',Size); - Logger.Send('TreeNodeSize',TreeNodeSize); - Result := TreeNodeSize + FTotalInternalDataSize; - Logger.Send('Result',Result); - Inc(FTotalInternalDataSize, (Size + 3) and not 3); - Logger.Send('FTotalInternalDataSize AFTER', FTotalInternalDataSize); - InitRootNode(Result); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.Animate(Steps, Duration: Cardinal; Callback: TVTAnimationCallback; Data: Pointer); - -// This method does the calculation part of an animation as used for node toggling and hint animations. -// Steps is the maximum amount of animation steps to do and Duration determines the milliseconds the animation -// has to run. Callback is a task specific method which is called in the loop for every step and Data is simply -// something to pass on to the callback. -// The callback is called with the current step, the current step size and the Data parameter. Since the step amount -// as well as the step size are possibly adjusted during the animation, it is impossible to determine if the current -// step is the last step, even if the original step amount is known. To solve this problem the callback will be -// called after the loop has finished with a step size of 0 indicating so to execute any post processing. - -var - StepSize, - RemainingTime, - RemainingSteps, - NextTimeStep, - CurrentStep, - StartTime, - CurrentTime: Cardinal; - -begin - if not (tsInAnimation in FStates) and (Duration > 0) then - begin - DoStateChange([tsInAnimation]); - try - RemainingTime := Duration; - RemainingSteps := Steps; - - // Determine the initial step size which is either 1 if the needed steps are less than the number of - // steps possible given by the duration or > 1 otherwise. - StepSize := Round(Max(1, RemainingSteps / Duration)); - RemainingSteps := RemainingSteps div StepSize; - CurrentStep := 0; - - while (RemainingSteps > 0) and (RemainingTime > 0) and not Application.Terminated do - begin - StartTime := timeGetTime; - NextTimeStep := StartTime + RemainingTime div RemainingSteps; - if not Callback(CurrentStep, StepSize, Data) then - Break; - - // Keep duration for this step for rest calculation. - CurrentTime := timeGetTime; - // Wait until the calculated time has been reached. - while CurrentTime < NextTimeStep do - CurrentTime := timeGetTime; - - // Subtract the time this step really needed. - if RemainingTime >= CurrentTime - StartTime then - begin - Dec(RemainingTime, CurrentTime - StartTime); - Dec(RemainingSteps); - end - else - begin - RemainingTime := 0; - RemainingSteps := 0; - end; - // If the remaining time per step is less than one time step then we have to decrease the - // step count and increase the step size. - if (RemainingSteps > 0) and ((RemainingTime div RemainingSteps) < 1) then - begin - repeat - Inc(StepSize); - RemainingSteps := RemainingTime div StepSize; - until (RemainingSteps <= 0) or ((RemainingTime div RemainingSteps) >= 1); - end; - CurrentStep := Cardinal(Steps) - RemainingSteps; - end; - - if not Application.Terminated then - Callback(0, 0, Data); - finally - DoStateChange([], [tsCancelHintAnimation, tsInAnimation]); - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.CalculateSelectionRect(X, Y: Integer): Boolean; - -// Recalculates old and new selection rectangle given that X, Y are new mouse coordinates. -// Returns True if there was a change since the last call. - -var - MaxValue: Integer; - -begin - if tsDrawSelecting in FStates then - FLastSelRect := FNewSelRect; - FNewSelRect.BottomRight := Point(X + FEffectiveOffsetX, Y - FOffsetY); - if FNewSelRect.Right < 0 then - FNewSelRect.Right := 0; - if FNewSelRect.Bottom < 0 then - FNewSelRect.Bottom := 0; - MaxValue := ClientWidth; - if FRangeX > Cardinal(MaxValue) then - MaxValue := FRangeX; - if FNewSelRect.Right > MaxValue then - FNewSelRect.Right := MaxValue; - MaxValue := ClientHeight; - if FRangeY > Cardinal(MaxValue) then - MaxValue := FRangeY; - if FNewSelRect.Bottom > MaxValue then - FNewSelRect.Bottom := MaxValue; - - Result := not CompareMem(@FLastSelRect, @FNewSelRect, SizeOf(FNewSelRect)); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.CanAutoScroll: Boolean; - -// Determines if auto scrolling is currently allowed. - -var - IsDropTarget: Boolean; - IsDrawSelecting: Boolean; - IsWheelPanning: Boolean; - -begin - // Don't scroll the client area if the header is currently doing tracking or dragging. - // Do auto scroll only if there is a draw selection in progress or the tree is the current drop target or - // wheel panning/scrolling is active. - IsDropTarget := Assigned(FDragManager) and DragManager.IsDropTarget; - IsDrawSelecting := [tsDrawSelPending, tsDrawSelecting] * FStates <> []; - IsWheelPanning := [tsWheelPanning, tsWheelScrolling] * FStates <> []; - Result := ((toAutoScroll in FOptions.FAutoOptions) or IsWheelPanning) and - (FHeader.FStates = []) and (IsDrawSelecting or IsDropTarget or (tsVCLDragging in FStates) or IsWheelPanning); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.CanEdit(Node: PVirtualNode; Column: TColumnIndex): Boolean; - -// Returns True if the given node can be edited. - -begin - Result := (toEditable in FOptions.FMiscOptions) and Enabled and not (toReadOnly in FOptions.FMiscOptions); - DoCanEdit(Node, Column, Result); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.CanShowDragImage: Boolean; - -// Determines whether a drag image should be shown. - -begin - Result := FDragImageKind <> diNoImage; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.Change(Node: PVirtualNode); - -begin - AdviseChangeEvent(False, Node, crIgnore); - - if FUpdateCount = 0 then - begin - if (FChangeDelay > 0) and not (tsSynchMode in FStates) then - SetTimer(Handle, ChangeTimer, FChangeDelay, nil) - else - DoChange(Node); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.ChangeScale(M, D: Integer); - -var - DoScale: Boolean; - -begin - inherited; - - if (M <> D) and (toAutoChangeScale in FOptions.FAutoOptions) then - begin - if (csLoading in ComponentState) then - DoScale := tsNeedScale in FStates - else - DoScale := True; - if DoScale then - begin - FDefaultNodeHeight := MulDiv(FDefaultNodeHeight, M, D); - FHeader.ChangeScale(M, D); - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.CheckParentCheckState(Node: PVirtualNode; NewCheckState: TCheckState): Boolean; - -// Checks all siblings of node to determine which check state Node's parent must get. - -var - CheckCount, - BoxCount: Cardinal; - PartialCheck: Boolean; - Run: PVirtualNode; - -begin - CheckCount := 0; - BoxCount := 0; - PartialCheck := False; - Run := Node.Parent.FirstChild; - while Assigned(Run) do - begin - if Run = Node then - begin - // The given node cannot be checked because it does not yet have its new check state (as this depends - // on the outcome of this method). Instead NewCheckState is used as this contains the new state the node - // will get if this method returns True. - if Run.CheckType in [ctCheckBox, ctTriStateCheckBox] then - begin - Inc(BoxCount); - if NewCheckState in [csCheckedNormal, csCheckedPressed] then - Inc(CheckCount); - PartialCheck := PartialCheck or (NewCheckState = csMixedNormal); - end; - end - else - if Run.CheckType in [ctCheckBox, ctTriStateCheckBox] then - begin - Inc(BoxCount); - if Run.CheckState in [csCheckedNormal, csCheckedPressed] then - Inc(CheckCount); - PartialCheck := PartialCheck or (Run.CheckState = csMixedNormal); - end; - Run := Run.NextSibling; - end; - - if (CheckCount = 0) and not PartialCheck then - NewCheckState := csUncheckedNormal - else - if CheckCount < BoxCount then - NewCheckState := csMixedNormal - else - NewCheckState := csCheckedNormal; - - Node := Node.Parent; - Result := DoChecking(Node, NewCheckState); - if Result then - begin - DoCheckClick(Node, NewCheckState); - // Recursively adjust parent of parent. - with Node^ do - begin - if not (vsInitialized in Parent.States) then - InitNode(Parent); - if ([vsChecking, vsDisabled] * Parent.States = []) and (Parent <> FRoot) and - (Parent.CheckType = ctTriStateCheckBox) then - Result := CheckParentCheckState(Node, NewCheckState); - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.ClearTempCache; - -// make sure the temporary node cache is in a reliable state - -begin - FTempNodeCache := nil; - FTempNodeCount := 0; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.ColumnIsEmpty(Node: PVirtualNode; Column: TColumnIndex): Boolean; - -// Returns True if the given column is to be considered as being empty. This will usually be determined by -// descendants as the base tree implementation has not enough information to decide. - -begin - Result := True; - if Assigned(FOnGetCellIsEmpty) then - FOnGetCellIsEmpty(Self, Node, Column, Result); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.ComputeRTLOffset(ExcludeScrollbar: Boolean): Integer; - -// Computes the horizontal offset needed when all columns are automatically right aligned (in RTL bidi mode). -// ExcludeScrollbar determines if the left-hand vertical scrollbar is to be included (if visible) or not. - -var - HeaderWidth: Integer; - ScrollbarVisible: Boolean; -begin - ScrollbarVisible := (Integer(FRangeY) > ClientHeight) and (ScrollbarOptions.Scrollbars in [ssVertical, ssBoth]); - if ScrollbarVisible then - Result := GetSystemMetrics(SM_CXVSCROLL) - else - Result := 0; - - // Make everything right aligned. - HeaderWidth := FHeaderRect.Right - FHeaderRect.Left; - if Integer(FRangeX) + Result <= HeaderWidth then - Result := HeaderWidth - Integer(FRangeX); - // Otherwise take only left-hand vertical scrollbar into account. - - if ScrollbarVisible and ExcludeScrollbar then - Dec(Result, GetSystemMetrics(SM_CXVSCROLL)); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.CountLevelDifference(Node1, Node2: PVirtualNode): Integer; - -// This method counts how many indentation levels the given nodes are apart. If both nodes have the same parent then the -// difference is 0 otherwise the result is basically GetNodeLevel(Node2) - GetNodeLevel(Node1), but with sign. -// If the result is negative then Node2 is less intended than Node1. - -var - Level1, Level2: Integer; - -begin - Assert(Assigned(Node1) and Assigned(Node2), 'Both nodes must be Assigned.'); - - Level1 := 0; - while Node1.Parent <> FRoot do - begin - Inc(Level1); - Node1 := Node1.Parent; - end; - - Level2 := 0; - while Node2.Parent <> FRoot do - begin - Inc(Level2); - Node2 := Node2.Parent; - end; - - Result := Level2 - Level1; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.CountVisibleChildren(Node: PVirtualNode): Cardinal; - -// Returns the number of visible child nodes of the given node. - -begin - Result := 0; - - // The node's direct children... - if vsExpanded in Node.States then - begin - // ...and their children. - Node := Node.FirstChild; - while Assigned(Node) do - begin - if vsVisible in Node.States then - Inc(Result, CountVisibleChildren(Node) + 1); - Node := Node.NextSibling; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.CreateParams(var Params: TCreateParams); - -const - ScrollBar: array[TScrollStyle] of Cardinal = (0, WS_HSCROLL, WS_VSCROLL, WS_HSCROLL or WS_VSCROLL, - 0,0,0); - -begin - //todo_lcl - - inherited CreateParams(Params); - - with Params do - begin - Style := Style or WS_CLIPCHILDREN or WS_CLIPSIBLINGS or ScrollBar[ScrollBarOptions.FScrollBars]; - if toFullRepaintOnResize in FOptions.FMiscOptions then - WindowClass.style := WindowClass.style or CS_HREDRAW or CS_VREDRAW - else - WindowClass.style := WindowClass.style and not (CS_HREDRAW or CS_VREDRAW); - if FBorderStyle = bsSingle then - begin - if Ctl3D then - begin - ExStyle := ExStyle or WS_EX_CLIENTEDGE; - Style := Style and not WS_BORDER; - end - else - Style := Style or WS_BORDER; - end - else - Style := Style and not WS_BORDER; - //todo_lcl_low - //AddBiDiModeExStyle(ExStyle); - end; - -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.CreateWnd; - -// Initializes data which depends on a valid window handle. - -begin - DoStateChange([tsWindowCreating]); - inherited; - Logger.Send(lcInfo,'Handle (CreateWnd)',Handle); - DoStateChange([], [tsWindowCreating]); - - {$ifdef ThemeSupport} - if ThemeServices.ThemesEnabled and (toThemeAware in TreeOptions.PaintOptions) then - DoStateChange([tsUseThemes]) - else - {$endif ThemeSupport} - DoStateChange([], [tsUseThemes]); - - // 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 hoAutoResize in FHeader.FOptions then - FHeader.FColumns.AdjustAutoSize(InvalidColumn); - - // Initialize flat scroll bar library if required. - {$ifdef UseFlatScrollbars} - if FScrollBarOptions.FScrollBarStyle <> sbmRegular then - begin - InitializeFlatSB(Handle); - FlatSB_SetScrollProp(Handle, WSB_PROP_HSTYLE, ScrollBarProp[FScrollBarOptions.ScrollBarStyle], False); - FlatSB_SetScrollProp(Handle, WSB_PROP_VSTYLE, ScrollBarProp[FScrollBarOptions.ScrollBarStyle], False); - end; - {$endif UseFlatScrollbars} - - PrepareBitmaps(True, True); - - // Register tree as OLE drop target. - // Somehow calling this code causes a SIGSEG - //if not (csDesigning in ComponentState) and (toAcceptOLEDrop in FOptions.FMiscOptions) then - // RegisterDragDrop(Handle, DragManager as IDropTarget); - - UpdateScrollBars(True); - UpdateHeaderRect; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DefineProperties(Filer: TFiler); - -// There were heavy changes in some properties during development of VT. This method helps to make migration easier -// by reading old properties manually and put them into the new properties as appropriate. -// Note: these old properties are never written again and silently disappear. -// June 2002: Meanwhile another task is done here too: working around the problem that TCollection is not streamed -// correctly when using Visual Form Inheritance (VFI). - -var - StoreIt: Boolean; - -begin - inherited; - - // The header can prevent writing columns altogether. - if FHeader.CanWriteColumns then - begin - // Check if we inherit from an ancestor form (Visual Form Inheritance). - StoreIt := Filer.Ancestor = nil; - // If there is an ancestor then save columns only if they are different to the base set. - if not StoreIt then - StoreIt := not FHeader.Columns.Equals(TBaseVirtualTree(Filer.Ancestor).FHeader.Columns); - end - else - StoreIt := False; - - Filer.DefineProperty('Columns', FHeader.ReadColumns, FHeader.WriteColumns, StoreIt); - Filer.DefineProperty('Options', ReadOldOptions, nil, False); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DetermineHiddenChildrenFlag(Node: PVirtualNode); - -// Update the hidden children flag of the given node. - -var - Run: PVirtualNode; - -begin - if Node.ChildCount = 0 then - begin - if vsHasChildren in Node.States then - Exclude(Node.States, vsAllChildrenHidden) - else - Include(Node.States, vsAllChildrenHidden); - end - else - begin - // Iterate through all siblings and stop when one visible is found. - Run := Node.FirstChild; - while Assigned(Run) and not (vsVisible in Run.States) do - Run := Run.NextSibling; - if Assigned(Run) then - Exclude(Node.States, vsAllChildrenHidden) - else - Include(Node.States, vsAllChildrenHidden); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DetermineHiddenChildrenFlagAllNodes; - -var - Run: PVirtualNode; - -begin - Run := GetFirstNoInit; - while Assigned(Run) do - begin - DetermineHiddenChildrenFlag(Run); - Run := GetNextNoInit(Run); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DetermineHitPositionLTR(var HitInfo: THitInfo; Offset, Right: Integer; - Alignment: TAlignment); - -// This method determines the hit position within a node with left-to-right orientation. - -var - MainColumnHit: Boolean; - Run: PVirtualNode; - Indent, - TextWidth, - ImageOffset: Integer; - -begin - MainColumnHit := HitInfo.HitColumn = FHeader.MainColumn; - Indent := 0; - - // If columns are not used or the main column is hit then the tree indentation must be considered too. - if MainColumnHit then - begin - Run := HitInfo.HitNode; - while (Run.Parent <> FRoot) do - begin - Inc(Indent, FIndent); - Run := Run.Parent; - end; - if toShowRoot in FOptions.FPaintOptions then - Inc(Indent, FIndent); - end; - - if Offset < Indent then - begin - // Position is to the left of calculated indentation which can only happen for the main column. - // Check whether it corresponds to a button/checkbox. - if (toShowButtons in FOptions.FPaintOptions) and (vsHasChildren in HitInfo.HitNode.States) then - begin - // Position of button is interpreted very generously to avoid forcing the user - // to click exactly into the 9x9 pixels area. The entire node height and one full - // indentation level is accepted as button hit. - if Offset >= Indent - Integer(FIndent) then - Include(HitInfo.HitPositions, hiOnItemButton); - end; - // no button hit so position is on indent - if HitInfo.HitPositions = [] then - Include(HitInfo.HitPositions, hiOnItemIndent); - end - else - begin - // The next hit positions can be: - // - on the check box - // - on the state image - // - on the normal image - // - to the left of the text area - // - on the label or - // - to the right of the text area - // (in this order). - - // In report mode no hit other than in the main column is possible. - if MainColumnHit or not (toReportMode in FOptions.FMiscOptions) then - begin - ImageOffset := Indent + FMargin; - - // Check support is only available for the main column. - if MainColumnHit and (toCheckSupport in FOptions.FMiscOptions) and Assigned(FCheckImages) and - (HitInfo.HitNode.CheckType <> ctNone) then - Inc(ImageOffset, FCheckImages.Width + 2); - - if MainColumnHit and (Offset < ImageOffset) then - begin - HitInfo.HitPositions := [hiOnItem]; - if (HitInfo.HitNode.CheckType <> ctNone) then - Include(HitInfo.HitPositions, hiOnItemCheckBox); - end - else - begin - if Assigned(FStateImages) and HasImage(HitInfo.HitNode, ikState, HitInfo.HitColumn) then - Inc(ImageOffset, FStateImages.Width + 2); - if Offset < ImageOffset then - Include(HitInfo.HitPositions, hiOnStateIcon) - else - begin - if Assigned(FImages) and HasImage(HitInfo.HitNode, ikNormal, HitInfo.HitColumn) then - Inc(ImageOffset, FImages.Width + 2); - if Offset < ImageOffset then - Include(HitInfo.HitPositions, hiOnNormalIcon) - else - begin - // ImageOffset contains now the left border of the node label area. This is used to calculate the - // correct alignment in the column. - TextWidth := DoGetNodeWidth(HitInfo.HitNode, HitInfo.HitColumn); - - // Check if the text can be aligned at all. This is only possible if there is enough room - // in the remaining text rectangle. - if TextWidth > Right - ImageOffset then - Include(HitInfo.HitPositions, hiOnItemLabel) - else - begin - case Alignment of - taCenter: - begin - Indent := (ImageOffset + Right - TextWidth) div 2; - if Offset < Indent then - Include(HitInfo.HitPositions, hiOnItemLeft) - else - if Offset < Indent + TextWidth then - Include(HitInfo.HitPositions, hiOnItemLabel) - else - Include(HitInfo.HitPositions, hiOnItemRight) - end; - taRightJustify: - begin - Indent := Right - TextWidth; - if Offset < Indent then - Include(HitInfo.HitPositions, hiOnItemLeft) - else - Include(HitInfo.HitPositions, hiOnItemLabel); - end; - else // taLeftJustify - if Offset < ImageOffset + TextWidth then - Include(HitInfo.HitPositions, hiOnItemLabel) - else - Include(HitInfo.HitPositions, hiOnItemRight); - end; - end; - end; - end; - end; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DetermineHitPositionRTL(var HitInfo: THitInfo; Offset, Right: Integer; Alignment: TAlignment); - -// This method determines the hit position within a node with right-to-left orientation. - -var - MainColumnHit: Boolean; - Run: PVirtualNode; - Indent, - TextWidth, - ImageOffset: Integer; - -begin - MainColumnHit := HitInfo.HitColumn = FHeader.MainColumn; - - // If columns are not used or the main column is hit then the tree indentation must be considered too. - if MainColumnHit then - begin - Run := HitInfo.HitNode; - while (Run.Parent <> FRoot) do - begin - Dec(Right, FIndent); - Run := Run.Parent; - end; - if toShowRoot in FOptions.FPaintOptions then - Dec(Right, FIndent); - end; - - if Offset >= Right then - begin - // Position is to the right of calculated indentation which can only happen for the main column. - // Check whether it corresponds to a button/checkbox. - if (toShowButtons in FOptions.FPaintOptions) and (vsHasChildren in HitInfo.HitNode.States) then - begin - // Position of button is interpreted very generously to avoid forcing the user - // to click exactly into the 9x9 pixels area. The entire node height and one full - // indentation level is accepted as button hit. - if Offset <= Right + Integer(FIndent) then - Include(HitInfo.HitPositions, hiOnItemButton); - end; - // no button hit so position is on indent - if HitInfo.HitPositions = [] then - Include(HitInfo.HitPositions, hiOnItemIndent); - end - else - begin - // The next hit positions can be: - // - on the check box - // - on the state image - // - on the normal image - // - to the left of the text area - // - on the label or - // - to the right of the text area - // (in this order). - - // In report mode no hit other than in the main column is possible. - if MainColumnHit or not (toReportMode in FOptions.FMiscOptions) then - begin - ImageOffset := Right - FMargin; - - // Check support is only available for the main column. - if MainColumnHit and (toCheckSupport in FOptions.FMiscOptions) and Assigned(FCheckImages) and - (HitInfo.HitNode.CheckType <> ctNone) then - Dec(ImageOffset, FCheckImages.Width + 2); - - if MainColumnHit and (Offset > ImageOffset) then - begin - HitInfo.HitPositions := [hiOnItem]; - if (HitInfo.HitNode.CheckType <> ctNone) then - Include(HitInfo.HitPositions, hiOnItemCheckBox); - end - else - begin - if Assigned(FStateImages) and HasImage(HitInfo.HitNode, ikState, HitInfo.HitColumn) then - Dec(ImageOffset, FStateImages.Width + 2); - if Offset > ImageOffset then - Include(HitInfo.HitPositions, hiOnStateIcon) - else - begin - if Assigned(FImages) and HasImage(HitInfo.HitNode, ikNormal, HitInfo.HitColumn) then - Dec(ImageOffset, FImages.Width + 2); - if Offset > ImageOffset then - Include(HitInfo.HitPositions, hiOnNormalIcon) - else - begin - // ImageOffset contains now the right border of the node label area. This is used to calculate the - // correct alignment in the column. - TextWidth := DoGetNodeWidth(HitInfo.HitNode, HitInfo.HitColumn); - - // Check if the text can be aligned at all. This is only possible if there is enough room - // in the remaining text rectangle. - if TextWidth > ImageOffset then - Include(HitInfo.HitPositions, hiOnItemLabel) - else - begin - // Consider bidi mode here. In RTL context does left alignment actually mean right alignment - // and vice versa. - ChangeBiDiModeAlignment(Alignment); - - case Alignment of - taCenter: - begin - Indent := (ImageOffset - TextWidth) div 2; - if Offset < Indent then - Include(HitInfo.HitPositions, hiOnItemLeft) - else - if Offset < Indent + TextWidth then - Include(HitInfo.HitPositions, hiOnItemLabel) - else - Include(HitInfo.HitPositions, hiOnItemRight) - end; - taRightJustify: - begin - Indent := ImageOffset - TextWidth; - if Offset < Indent then - Include(HitInfo.HitPositions, hiOnItemLeft) - else - Include(HitInfo.HitPositions, hiOnItemLabel); - end; - else // taLeftJustify - if Offset > TextWidth then - Include(HitInfo.HitPositions, hiOnItemRight) - else - Include(HitInfo.HitPositions, hiOnItemLabel); - end; - end; - end; - end; - end; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.DetermineNextCheckState(CheckType: TCheckType; CheckState: TCheckState): TCheckState; - -// Determines the next check state in case the user click the check image or pressed the space key. - -begin - case CheckType of - ctTriStateCheckBox, - ctCheckBox: - if CheckState = csCheckedNormal then - Result := csUncheckedNormal - else - Result := csCheckedNormal; - ctRadioButton: - Result := csCheckedNormal; - ctButton: - Result := csUncheckedNormal; - else - Result := csMixedNormal; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.DetermineScrollDirections(X, Y: Integer): TScrollDirections; - -// Determines which direction the client area must be scrolled depending on the given position. - -begin - Result:= []; - - if CanAutoScroll then - begin - // Calculation for wheel panning/scrolling is a bit different to normal auto scroll. - if [tsWheelPanning, tsWheelScrolling] * FStates <> [] then - begin - if (X - FLastClickPos.X) < -8 then - Include(Result, sdLeft); - if (X - FLastClickPos.X) > 8 then - Include(Result, sdRight); - - if (Y - FLastClickPos.Y) < -8 then - Include(Result, sdUp); - if (Y - FLastClickPos.Y) > 8 then - Include(Result, sdDown); - end - else - begin - if (X < Integer(FDefaultNodeHeight)) and (FEffectiveOffsetX <> 0) then - Include(Result, sdLeft); - if (ClientWidth + FEffectiveOffsetX < Integer(FRangeX)) and (X > ClientWidth - Integer(FDefaultNodeHeight)) then - Include(Result, sdRight); - - if (Y < Integer(FDefaultNodeHeight)) and (FOffsetY <> 0) then - Include(Result, sdUp); - if (ClientHeight - FOffsetY < Integer(FRangeY)) and (Y > ClientHeight - Integer(FDefaultNodeHeight)) then - Include(Result, sdDown); - - // Since scrolling during dragging is not handled via the timer we do a check here whether the auto - // scroll timeout already has elapsed or not. - if (Result <> []) and - ((Assigned(FDragManager) and DragManager.IsDropTarget) or - (FindDragTarget(Point(X, Y), False) = Self)) then - begin - if FDragScrollStart = 0 then - FDragScrollStart := timeGetTime; - // Reset any scroll direction to avoid scroll in the case the user is dragging and the auto scroll time has not - // yet elapsed. - if ((timeGetTime - FDragScrollStart) < FAutoScrollDelay) then - Result := []; - end; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoAdvancedHeaderDraw(var PaintInfo: THeaderPaintInfo; const Elements: THeaderPaintElements); - -begin - if Assigned(FOnAdvancedHeaderDraw) then - FOnAdvancedHeaderDraw(FHeader, PaintInfo, Elements); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoAfterCellPaint(Canvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex; CellRect: TRect); - -begin - if Assigned(FOnAfterCellPaint) then - FOnAfterCellPaint(Self, Canvas, Node, Column, CellRect); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoAfterItemErase(Canvas: TCanvas; Node: PVirtualNode; ItemRect: TRect); - -begin - if Assigned(FOnAfterItemErase) then - FOnAfterItemErase(Self, Canvas, Node, ItemRect); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoAfterItemPaint(Canvas: TCanvas; Node: PVirtualNode; ItemRect: TRect); - -begin - if Assigned(FOnAfterItemPaint) then - FOnAfterItemPaint(Self, Canvas, Node, ItemRect); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoAfterPaint(Canvas: TCanvas); - -begin - if Assigned(FOnAfterPaint) then - FOnAfterPaint(Self, Canvas); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoAutoScroll(X, Y: Integer); - -begin - FScrollDirections := DetermineScrollDirections(X, Y); - - if FStates * [tsWheelPanning, tsWheelScrolling] = [] then - begin - if FScrollDirections = [] then - begin - if ((FStates * [tsScrollPending, tsScrolling]) <> []) then - begin - StopTimer(ScrollTimer); - DoStateChange([], [tsScrollPending, tsScrolling]); - end; - end - else - begin - // start auto scroll if not yet done - if (FStates * [tsScrollPending, tsScrolling]) = [] then - begin - DoStateChange([tsScrollPending]); - SetTimer(Handle, ScrollTimer, FAutoScrollDelay, nil); - end; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.DoBeforeDrag(Node: PVirtualNode; Column: TColumnIndex): Boolean; - -begin - Result := False; - if Assigned(FOnDragAllowed) then - FOnDragAllowed(Self, Node, Column, Result); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoBeforeCellPaint(Canvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex; CellRect: TRect); - -begin - if Assigned(FOnBeforeCellPaint) then - FOnBeforeCellPaint(Self, Canvas, Node, Column, CellRect); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoBeforeItemErase(Canvas: TCanvas; Node: PVirtualNode; ItemRect: TRect; var Color: TColor; - var EraseAction: TItemEraseAction); - -begin - if Assigned(FOnBeforeItemErase) then - FOnBeforeItemErase(Self, Canvas, Node, ItemRect, Color, EraseAction); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.DoBeforeItemPaint(Canvas: TCanvas; Node: PVirtualNode; ItemRect: TRect): Boolean; - -begin - // By default custom draw will not be used, so the tree handles drawing the node. - Result := False; - if Assigned(FOnBeforeItemPaint) then - FOnBeforeItemPaint(Self, Canvas, Node, ItemRect, Result); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoBeforePaint(Canvas: TCanvas); - -begin - if Assigned(FOnBeforePaint) then - FOnBeforePaint(Self, Canvas); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.DoCancelEdit: Boolean; - -// Called when the current edit action or a pending edit must be cancelled. - -begin - StopTimer(EditTimer); - DoStateChange([], [tsEditPending]); - Result := (tsEditing in FStates) and FEditLink.CancelEdit; - if Result then - begin - DoStateChange([], [tsEditing]); - if Assigned(FOnEditCancelled) then - FOnEditCancelled(Self, FEditColumn); - if not (csDestroying in ComponentState) then - FEditLink := nil; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoCanEdit(Node: PVirtualNode; Column: TColumnIndex; var Allowed: Boolean); - -begin - if Assigned(FOnEditing) then - FOnEditing(Self, Node, Column, Allowed); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoChange(Node: PVirtualNode); - -begin - StopTimer(ChangeTimer); - if Assigned(FOnChange) then - FOnChange(Self, Node); - - // This is a good place to reset the cached node. This is the same as the node passed in here. - // This is necessary to allow descendants to override this method and get the node then. - DoStateChange([], [tsChangePending]); - FLastChangedNode := nil; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoCheckClick(Node: PVirtualNode; NewCheckState: TCheckState); - -begin - if ChangeCheckState(Node, NewCheckState) then - DoChecked(Node); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoChecked(Node: PVirtualNode); - -begin - if Assigned(FOnChecked) then - FOnChecked(Self, Node); - - {$ifdef EnableAccessible} - NotifyWinEvent(EVENT_OBJECT_STATECHANGE, Handle, OBJID_CLIENT, CHILDID_SELF); - {$endif} -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.DoChecking(Node: PVirtualNode; var NewCheckState: TCheckState): Boolean; - -// Determines if a node is allowed to change its check state to NewCheckState. - -begin - if toReadOnly in FOptions.FMiscOptions then - Result := False - else - begin - Result := True; - if Assigned(FOnChecking) then - FOnChecking(Self, Node, NewCheckState, Result); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoCollapsed(Node: PVirtualNode); - -begin - if Assigned(FOnCollapsed) then - FOnCollapsed(Self, Node); - {$ifdef EnableAccessible} - NotifyWinEvent(EVENT_OBJECT_STATECHANGE, Handle, OBJID_CLIENT, CHILDID_SELF); - {$endif} -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.DoCollapsing(Node: PVirtualNode): Boolean; - -begin - Result := True; - if Assigned(FOnCollapsing) then - FOnCollapsing(Self, Node, Result); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoColumnClick(Column: TColumnIndex; Shift: TShiftState); - -begin - if Assigned(FOnColumnClick) then - FOnColumnClick(Self, Column, Shift); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoColumnDblClick(Column: TColumnIndex; Shift: TShiftState); - -begin - if Assigned(FOnColumnDblClick) then - FOnColumnDblClick(Self, Column, Shift); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoColumnResize(Column: TColumnIndex); - -var - R: TRect; - Run: PVirtualNode; - -begin - if not (csLoading in ComponentState) and HandleAllocated then - begin - // Reset all vsHeightMeasured flags if we are in multiline mode. - Run := GetFirstInitialized; - while Assigned(Run) do - begin - if vsMultiline in Run.States then - Exclude(Run.States, vsHeightMeasured); - Run := GetNextInitialized(Run); - end; - - UpdateHorizontalScrollBar(True); - if Column > NoColumn then - begin - // Invalidate client area from the current column all to the right (or left in RTL mode). - R := ClientRect; - if not (toAutoSpanColumns in FOptions.FAutoOptions) then - if UseRightToLeftAlignment then - R.Right := FHeader.Columns[Column].Left + FHeader.Columns[Column].Width + ComputeRTLOffset - else - R.Left := FHeader.Columns[Column].Left; - InvalidateRect(Handle, @R, False); - FHeader.Invalidate(FHeader.Columns[Column], True); - end; - if hsTracking in FHeader.States then - UpdateWindow(Handle); - - if not (tsUpdating in FStates) then - UpdateDesigner; // design time only - - if Assigned(FOnColumnResize) then - FOnColumnResize(FHeader, Column); - - // If the tree is currently in edit state then notify edit link. - if tsEditing in FStates then - UpdateEditBounds; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.DoCompare(Node1, Node2: PVirtualNode; Column: TColumnIndex): Integer; - -begin - Result := 0; - if Assigned(FOnCompareNodes) then - FOnCompareNodes(Self, Node1, Node2, Column, Result); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.DoCreateDataObject: IDataObject; - -begin - Result := nil; - if Assigned(FOnCreateDataObject) then - FOnCreateDataObject(Self, Result); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.DoCreateDragManager: IVTDragManager; - -begin - Result := nil; - if Assigned(FOnCreateDragManager) then - FOnCreateDragManager(Self, Result); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.DoCreateEditor(Node: PVirtualNode; Column: TColumnIndex): IVTEditLink; - -begin - Result := nil; - if Assigned(FOnCreateEditor) then - begin - FOnCreateEditor(Self, Node, Column, Result); - if Result = nil then - ShowError(SEditLinkIsNil, hcTFEditLinkIsNil); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoDragging(P: TPoint); - -// Initiates finally the drag'n drop operation and returns after DD is finished. - - //--------------- local function -------------------------------------------- - - function GetDragOperations: Integer; - - begin - if FDragOperations = [] then - Result := DROPEFFECT_COPY or DROPEFFECT_MOVE or DROPEFFECT_LINK - else - begin - Result := 0; - if doCopy in FDragOperations then - Result := Result or DROPEFFECT_COPY; - if doLink in FDragOperations then - Result := Result or DROPEFFECT_LINK; - if doMove in FDragOperations then - Result := Result or DROPEFFECT_MOVE; - end; - end; - - //--------------- end local function ---------------------------------------- - -var - DragEffect: LongWord; - I, - AllowedEffects: Integer; - DragObject: TDragObject; - - DataObject: IDataObject; - -begin - DataObject := nil; - // Dragging is dragging, nothing else. - DoCancelEdit; - - if Assigned(FCurrentHotNode) then - begin - InvalidateNode(FCurrentHotNode); - FCurrentHotNode := nil; - end; - // Select the focused node if not already done. - if Assigned(FFocusedNode) and not (vsSelected in FFocusedNode.States) then - begin - InternalAddToSelection(FFocusedNode, False); - InvalidateNode(FFocusedNode); - end; - - UpdateWindow(Handle); - - // Keep a list of all currently selected nodes as this list might change, - // but we have probably to delete currently selected nodes. - FDragSelection := GetSortedSelection(True); - try - DoStateChange([tsOLEDragging], [tsOLEDragPending, tsClearPending]); - - // An application might create a drag object like used during VCL dd. This is not required for OLE dd but - // required as parameter. - DragObject := nil; - DoStartDrag(DragObject); - DragObject.Free; - - DataObject := DragManager.DataObject; - PrepareDragImage(P, DataObject); - - FLastDropMode := dmOnNode; - // Don't forget to initialize the result. It might never be touched. - DragEffect := DROPEFFECT_NONE; - AllowedEffects := GetDragOperations; - try - ActiveX.DoDragDrop(DataObject, DragManager as IDropSource, AllowedEffects, @DragEffect); - DragManager.ForceDragLeave; - finally - GetCursorPos(P); - P := ScreenToClient(P); - DoEndDrag(Self, P.X, P.Y); - - FDragImage.EndDrag; - - // Finish the operation. - if (DragEffect = DROPEFFECT_MOVE) and (toAutoDeleteMovedNodes in TreeOptions.AutoOptions) then - begin - // The operation was a move so delete the previously selected nodes. - BeginUpdate; - try - // The list of selected nodes was retrieved in resolved state. That means there can never be a node - // in the list whose parent (or its parent etc.) is also selected. - for I := 0 to High(FDragSelection) do - DeleteNode(FDragSelection[I]); - finally - EndUpdate; - end; - end; - - DoStateChange([], [tsOLEDragging]); - end; - finally - FDragSelection := nil; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoDragExpand; - -var - SourceTree: TBaseVirtualTree; - -begin - StopTimer(ExpandTimer); - if Assigned(FDropTargetNode) and (vsHasChildren in FDropTargetNode.States) and - not (vsExpanded in FDropTargetNode.States) then - begin - if Assigned(FDragManager) then - SourceTree := DragManager.DragSource - else - SourceTree := nil; - - if not DragManager.DropTargetHelperSupported and Assigned(SourceTree) then - SourceTree.FDragImage.HideDragImage; - ToggleNode(FDropTargetNode); - UpdateWindow(Handle); - if not DragManager.DropTargetHelperSupported and Assigned(SourceTree) then - SourceTree.FDragImage.ShowDragImage; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.DoDragOver(Source: TObject; Shift: TShiftState; State: TDragState; Pt: TPoint; Mode: TDropMode; - var Effect: LongWord): Boolean; - -begin - Result := False; - if Assigned(FOnDragOver) then - FOnDragOver(Self, Source, Shift, State, Pt, Mode, Effect, Result); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoDragDrop(Source: TObject; DataObject: IDataObject; Formats: TFormatArray; - Shift: TShiftState; Pt: TPoint; var Effect: LongWord; Mode: TDropMode); - -begin - if Assigned(FOnDragDrop) then - FOnDragDrop(Self, Source, DataObject, Formats, Shift, Pt, Effect, Mode); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoEdit; - -begin - Application.CancelHint; - StopTimer(ScrollTimer); - StopTimer(EditTimer); - DoStateChange([], [tsEditPending]); - if Assigned(FFocusedNode) and not (vsDisabled in FFocusedNode.States) and - not (toReadOnly in FOptions.FMiscOptions) and (FEditLink = nil) then - begin - FEditLink := DoCreateEditor(FFocusedNode, FEditColumn); - if Assigned(FEditLink) then - begin - DoStateChange([tsEditing], [tsDrawSelecting, tsDrawSelPending, tsToggleFocusedSelection, tsOLEDragPending, - tsOLEDragging, tsClearPending, tsScrollPending, tsScrolling, tsMouseCheckPending]); - ScrollIntoView(FFocusedNode, toCenterScrollIntoView in FOptions.SelectionOptions, - not (toDisableAutoscrollOnEdit in FOptions.AutoOptions)); - if FEditLink.PrepareEdit(Self, FFocusedNode, FEditColumn) then - begin - UpdateEditBounds; - // Node needs repaint because the selection rectangle and static text must disappear. - InvalidateNode(FFocusedNode); - if not FEditLink.BeginEdit then - DoStateChange([], [tsEditing]); - end - else - DoStateChange([], [tsEditing]); - if not (tsEditing in FStates) then - FEditLink := nil; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoEndDrag(Target: TObject; X, Y: Integer); - -// Does some housekeeping for VCL drag'n drop; - -begin - inherited; - - DragFinished; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.DoEndEdit: Boolean; - -begin - StopTimer(EditTimer); - Result := (tsEditing in FStates) and FEditLink.EndEdit; - if Result then - begin - DoStateChange([], [tsEditing]); - FEditLink := nil; - if Assigned(FOnEdited) then - FOnEdited(Self, FFocusedNode, FEditColumn); - end; - DoStateChange([], [tsEditPending]); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoExpanded(Node: PVirtualNode); - -begin - if Assigned(FOnExpanded) then - FOnExpanded(Self, Node); - {$ifdef EnableAccessible} - NotifyWinEvent(EVENT_OBJECT_STATECHANGE, Handle, OBJID_CLIENT, CHILDID_SELF); - {$endif} -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.DoExpanding(Node: PVirtualNode): Boolean; - -begin - Result := True; - if Assigned(FOnExpanding) then - FOnExpanding(Self, Node, Result); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoFocusChange(Node: PVirtualNode; Column: TColumnIndex); - -begin - if Assigned(FOnFocusChanged) then - FOnFocusChanged(Self, Node, Column); - {$ifdef EnableAccessible} - NotifyWinEvent(EVENT_OBJECT_LOCATIONCHANGE, Handle, OBJID_CLIENT, CHILDID_SELF); - NotifyWinEvent(EVENT_OBJECT_NAMECHANGE, Handle, OBJID_CLIENT, CHILDID_SELF); - NotifyWinEvent(EVENT_OBJECT_VALUECHANGE, Handle, OBJID_CLIENT, CHILDID_SELF); - NotifyWinEvent(EVENT_OBJECT_STATECHANGE, Handle, OBJID_CLIENT, CHILDID_SELF); - NotifyWinEvent(EVENT_OBJECT_SELECTION, Handle, OBJID_CLIENT, CHILDID_SELF); - NotifyWinEvent(EVENT_OBJECT_FOCUS, Handle, OBJID_CLIENT, CHILDID_SELF); - {$endif} -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.DoFocusChanging(OldNode, NewNode: PVirtualNode; OldColumn, NewColumn: TColumnIndex): Boolean; - -begin - Result := True; - if Assigned(FOnFocusChanging) then - FOnFocusChanging(Self, OldNode, NewNode, OldColumn, NewColumn, Result); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoFocusNode(Node: PVirtualNode; Ask: Boolean); - -begin - if not (tsEditing in FStates) or EndEditNode then - begin - if Node = FRoot then - Node := nil; - if (FFocusedNode <> Node) and (not Ask or DoFocusChanging(FFocusedNode, Node, FFocusedColumn, FFocusedColumn)) then - begin - if Assigned(FFocusedNode) then - begin - // Do automatic collapsing of last focused node if enabled. This is however only done if - // old and new focused node have a common parent node. - if (toAutoExpand in FOptions.FAutoOptions) and Assigned(Node) and (Node.Parent = FFocusedNode.Parent) and - (vsExpanded in FFocusedNode.States) then - ToggleNode(FFocusedNode) - else - InvalidateNode(FFocusedNode); - end; - FFocusedNode := Node; - end; - - // Have to scroll the node into view, even it is the same node as before. - if Assigned(FFocusedNode) then - begin - // Make sure a valid column is set if columns are used and no column has currently the focus. - if FHeader.UseColumns and ((FFocusedColumn < 0) or (FFocusedColumn >= FHeader.FColumns.Count)) then - FFocusedColumn := 0; - // Do automatic expansion of the newly focused node if enabled. - if (toAutoExpand in FOptions.FAutoOptions) and not (vsExpanded in FFocusedNode.States) then - ToggleNode(FFocusedNode); - InvalidateNode(FFocusedNode); - if FUpdateCount = 0 then - ScrollIntoView(FFocusedNode, (toCenterScrollIntoView in FOptions.SelectionOptions) and - (MouseButtonDown * FStates = []), not (toDisableAutoscrollOnFocus in FOptions.FAutoOptions)); - end; - - // Reset range anchor if necessary. - if FSelectionCount = 0 then - ResetRangeAnchor; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoFreeNode(Node: PVirtualNode); - -begin - if Node = FLastChangedNode then - FLastChangedNode := nil; - if Node = FCurrentHotNode then - FCurrentHotNode := nil; - if Assigned(FOnFreeNode) and ([vsInitialized, vsInitialUserData] * Node.States <> []) then - FOnFreeNode(Self, Node); - {$ifdef UseLocalMemoryManager} - FNodeMemoryManager.FreeNode(Node); - {$else} - FreeMem(Node); - {$endif UseLocalMemoryManager} -end; - -//---------------------------------------------------------------------------------------------------------------------- - -// These constants are defined in the platform SDK for W2K/XP, but not yet in Delphi. -const - SPI_GETTOOLTIPANIMATION = $1016; - SPI_GETTOOLTIPFADE = $1018; - -function TBaseVirtualTree.DoGetAnimationType: THintAnimationType; - -// Determines (depending on the properties settings and the system) which hint -// animation type is to be used. - -var - Animation: BOOL; - -begin - Result := FAnimationType; - if Result = hatSystemDefault then - begin - if not IsWinNT then - Result := hatSlide - else - begin - SystemParametersInfo(SPI_GETTOOLTIPANIMATION, 0, @Animation, 0); - if not Animation then - Result := hatNone - else - begin - SystemParametersInfo(SPI_GETTOOLTIPFADE, 0, @Animation, 0); - if Animation then - Result := hatFade - else - Result := hatSlide; - end; - end; - end; - - // Check availability of MMX if fading is requested. - if not MMXAvailable and (Result = hatFade) then - Result := hatSlide; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoGetCursor(var Cursor: TCursor); - -begin - if Assigned(FOnGetCursor) then - FOnGetCursor(Self, Cursor); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoGetHeaderCursor(var Cursor: HCURSOR); - -begin - if Assigned(FOnGetHeaderCursor) then - FOnGetHeaderCursor(FHeader, Cursor); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.DoGetImageIndex(Node: PVirtualNode; Kind: TVTImageKind; Column: TColumnIndex; - var Ghosted: Boolean; var Index: Integer): TCustomImageList; - -// Queries the application/descendant about certain image properties for a node. -// Returns a custom image list if given by the callee, otherwise nil. - -begin - Result := nil; - - // First try the enhanced event to allow for custom image lists. - if Assigned(FOnGetImageEx) then - FOnGetImageEx(Self, Node, Kind, Column, Ghosted, Index, Result) - else - if Assigned(FOnGetImage) then - FOnGetImage(Self, Node, Kind, Column, Ghosted, Index); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoGetLineStyle(var Bits: Pointer); - -begin - if Assigned(FOnGetLineStyle) then - FOnGetLineStyle(Self, Bits); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.DoGetNodeHint(Node: PVirtualNode; Column: TColumnIndex; - var LineBreakStyle: TVTTooltipLineBreakStyle): WideString; - -begin - Result := Hint; - LineBreakStyle := hlbDefault; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.DoGetNodeTooltip(Node: PVirtualNode; Column: TColumnIndex; - var LineBreakStyle: TVTTooltipLineBreakStyle): WideString; - -begin - Result := Hint; - LineBreakStyle := hlbDefault; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.DoGetNodeWidth(Node: PVirtualNode; Column: TColumnIndex; Canvas: TCanvas = nil): Integer; - -begin - Result := 0; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.DoGetPopupMenu(Node: PVirtualNode; Column: TColumnIndex; Position: TPoint): TPopupMenu; - -// Queries the application whether there is a node specific popup menu. - -var - Run: PVirtualNode; - AskParent: Boolean; - -begin - Result := nil; - if Assigned(FOnGetPopupMenu) then - begin - Run := Node; - - if Assigned(Run) then - begin - AskParent := True; - repeat - FOnGetPopupMenu(Self, Run, Column, Position, AskParent, Result); - Run := Run.Parent; - until (Run = FRoot) or Assigned(Result) or not AskParent; - end - else - FOnGetPopupMenu(Self, nil, -1, Position, AskParent, Result); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoGetUserClipboardFormats(var Formats: TFormatEtcArray); - -begin - if Assigned(FOnGetUserClipboardFormats) then - FOnGetUserClipboardFormats(Self, Formats); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoHeaderClick(Column: TColumnIndex; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); - -begin - if Assigned(FOnHeaderClick) then - FOnHeaderClick(FHeader, Column, Button, Shift, X, Y); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoHeaderDblClick(Column: TColumnIndex; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); - -begin - if Assigned(FOnHeaderDblClick) then - FOnHeaderDblClick(FHeader, Column, Button, Shift, X, Y); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoHeaderDragged(Column: TColumnIndex; OldPosition: TColumnPosition); - -begin - if Assigned(FOnHeaderDragged) then - FOnHeaderDragged(FHeader, Column, OldPosition); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoHeaderDraggedOut(Column: TColumnIndex; DropPosition: TPoint); - -begin - if Assigned(FOnHeaderDraggedOut) then - FOnHeaderDraggedOut(FHeader, Column, DropPosition); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.DoHeaderDragging(Column: TColumnIndex): Boolean; - -begin - Result := True; - if Assigned(FOnHeaderDragging) then - FOnHeaderDragging(FHeader, Column, Result); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoHeaderDraw(Canvas: TCanvas; Column: TVirtualTreeColumn; R: TRect; Hover, Pressed: Boolean; - DropMark: TVTDropMarkMode); - -begin - if Assigned(FOnHeaderDraw) then - FOnHeaderDraw(FHeader, Canvas, Column, R, Hover, Pressed, DropMark); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoHeaderDrawQueryElements(var PaintInfo: THeaderPaintInfo; var Elements: THeaderPaintElements); - -begin - if Assigned(FOnHeaderDrawQueryElements) then - FOnHeaderDrawQueryElements(FHeader, PaintInfo, Elements); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoHeaderMouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); - -begin - if Assigned(FOnHeaderMouseDown) then - FOnHeaderMouseDown(FHeader, Button, Shift, X, Y); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoHeaderMouseMove(Shift: TShiftState; X, Y: Integer); - -begin - if Assigned(FOnHeaderMouseMove) then - FOnHeaderMouseMove(FHeader, Shift, X, Y); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoHeaderMouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); - -begin - if Assigned(FOnHeaderMouseUp) then - FOnHeaderMouseUp(FHeader, Button, Shift, X, Y); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoHotChange(Old, New: PVirtualNode); - -begin - if Assigned(FOnHotChange) then - FOnHotChange(Self, Old, New); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.DoIncrementalSearch(Node: PVirtualNode; const Text: WideString): Integer; - -begin - Result := 0; - if Assigned(FOnIncrementalSearch) then - FOnIncrementalSearch(Self, Node, Text, Result); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoInitChildren(Node: PVirtualNode; var ChildCount: Cardinal); - -begin - if Assigned(FOnInitChildren) then - FOnInitChildren(Self, Node, ChildCount); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoInitNode(Parent, Node: PVirtualNode; var InitStates: TVirtualNodeInitStates); - -begin - if Assigned(FOnInitNode) then - FOnInitNode(Self, Parent, Node, InitStates); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.DoKeyAction(var CharCode: Word; var Shift: TShiftState): Boolean; - -begin - Result := True; - if Assigned(FOnKeyAction) then - FOnKeyAction(Self, CharCode, Shift, Result); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoLoadUserData(Node: PVirtualNode; Stream: TStream); - -begin - if Assigned(FOnLoadNode) then - if Node = FRoot then - FOnLoadNode(Self, nil, Stream) - else - FOnLoadNode(Self, Node, Stream); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoMeasureItem(TargetCanvas: TCanvas; Node: PVirtualNode; var NodeHeight: Integer); - -begin - if Assigned(FOnMeasureItem) then - FOnMeasureItem(Self, TargetCanvas, Node, NodeHeight); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoNodeCopied(Node: PVirtualNode); - -begin - if Assigned(FOnNodeCopied) then - FOnNodeCopied(Self, Node); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.DoNodeCopying(Node, NewParent: PVirtualNode): Boolean; - -begin - Result := True; - if Assigned(FOnNodeCopying) then - FOnNodeCopying(Self, Node, NewParent, Result); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoNodeMoved(Node: PVirtualNode); - -begin - if Assigned(FOnNodeMoved) then - FOnNodeMoved(Self, Node); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.DoNodeMoving(Node, NewParent: PVirtualNode): Boolean; - -begin - Result := True; - if Assigned(FOnNodeMoving) then - FOnNodeMoving(Self, Node, NewParent, Result); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.DoPaintBackground(Canvas: TCanvas; R: TRect): Boolean; - -begin - Result := False; - if Assigned(FOnPaintBackground) then - FOnPaintBackground(Self, Canvas, R, Result); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoPaintDropMark(Canvas: TCanvas; Node: PVirtualNode; R: TRect); - -// draws the drop mark into the given rectangle -// Note: Changed properties of the given canvas should be reset to their previous values. - -var - SaveBrushColor: TColor; - SavePenStyle: TPenStyle; - -begin - if FLastDropMode in [dmAbove, dmBelow] then - with Canvas do - begin - SavePenStyle := Pen.Style; - Pen.Style := psClear; - SaveBrushColor := Brush.Color; - Brush.Color := FColors.DropMarkColor; - - if FLastDropMode = dmAbove then - begin - Polygon([Point(R.Left + 2, R.Top), - Point(R.Right - 2, R.Top), - Point(R.Right - 2, R.Top + 6), - Point(R.Right - 6, R.Top + 2), - Point(R.Left + 6 , R.Top + 2), - Point(R.Left + 2, R.Top + 6) - ]); - end - else - Polygon([Point(R.Left + 2, R.Bottom - 1), - Point(R.Right - 2, R.Bottom - 1), - Point(R.Right - 2, R.Bottom - 8), - Point(R.Right - 7, R.Bottom - 3), - Point(R.Left + 7 , R.Bottom - 3), - Point(R.Left + 2, R.Bottom - 8) - ]); - Brush.Color := SaveBrushColor; - Pen.Style := SavePenStyle; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoPaintNode(var PaintInfo: TVTPaintInfo); - -begin -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoPopupMenu(Node: PVirtualNode; Column: TColumnIndex; Position: TPoint); - -// Support for node dependent popup menus. - -var - Menu: TPopupMenu; - -begin - Menu := DoGetPopupMenu(Node, Column, Position); - - if Assigned(Menu) then - begin - DoStateChange([tsPopupMenuShown]); - StopTimer(EditTimer); - Menu.PopupComponent := Self; - with ClientToScreen(Position) do - Menu.Popup(X, Y); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.DoRenderOLEData(const FormatEtcIn: TFormatEtc; out Medium: TStgMedium; - ForClipboard: Boolean): HRESULT; - -begin - Result := E_FAIL; - if Assigned(FOnRenderOLEData) then - FOnRenderOLEData(Self, FormatEtcIn, Medium, ForClipboard, Result); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoReset(Node: PVirtualNode); - -begin - if Assigned(FOnResetNode) then - FOnResetNode(Self, Node); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoSaveUserData(Node: PVirtualNode; Stream: TStream); - -begin - if Assigned(FOnSaveNode) then - if Node = FRoot then - FOnSaveNode(Self, nil, Stream) - else - FOnSaveNode(Self, Node, Stream); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoScroll(DeltaX, DeltaY: Integer); - -begin - if Assigned(FOnScroll) then - FOnScroll(Self, DeltaX, DeltaY); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.DoSetOffsetXY(Value: TPoint; Options: TScrollUpdateOptions; ClipRect: PRect = nil): Boolean; - -// Actual offset setter used to scroll the client area, update scroll bars and invalidating the header (all optional). -// Returns True if the offset really changed otherwise False is returned. - -var - DeltaX: Integer; - DeltaY: Integer; - DWPStructure: THandle;//HDWP; - I: Integer; - P: TPoint; - R: TRect; - -begin - Logger.EnterMethod(lcScroll,'DoSetOffsetXY'); - Logger.Send(lcScroll,'Value',Value); - Logger.SendCallStack(lcScroll,'CallStack'); - // Range check, order is important here. - if Value.X < (ClientWidth - Integer(FRangeX)) then - Value.X := ClientWidth - Integer(FRangeX); - if Value.X > 0 then - Value.X := 0; - DeltaX := Value.X - FOffsetX; - if UseRightToLeftAlignment then - DeltaX := -DeltaX; - if Value.Y < (ClientHeight - Integer(FRangeY)) then - Value.Y := ClientHeight - Integer(FRangeY); - if Value.Y > 0 then - Value.Y := 0; - DeltaY := Value.Y - FOffsetY; - Logger.Send(lcScroll,'FOffsetX: %d FOffsetY: %d',[FOffsetX,FOffsetY]); - Logger.Send(lcScroll,'DeltaX: %d DeltaY: %d',[DeltaX,DeltaY]); - Result := (DeltaX <> 0) or (DeltaY <> 0); - if Result then - begin - FOffsetX := Value.X; - FOffsetY := Value.Y; - //todo: remove this assignment? - Result := True; - - Application.CancelHint; - if FUpdateCount = 0 then - begin - // The drag image from VCL controls need special consideration. - if tsVCLDragging in FStates then - ImageList_DragShowNolock(False); - - if suoScrollClientArea in Options then - begin - // Have to invalidate the entire window if there's a background. - if (toShowBackground in FOptions.FPaintOptions) and (FBackground.Graphic is TBitmap) then - begin - // Since we don't use ScrollWindow here we have to move all client windows ourselves. - DWPStructure := BeginDeferWindowPos(ControlCount); - for I := 0 to ControlCount - 1 do - if Controls[I] is TWinControl then - begin - with Controls[I] as TWinControl do - DWPStructure := DeferWindowPos(DWPStructure, Handle, 0, Left + DeltaX, Top + DeltaY, 0, 0, - SWP_NOZORDER or SWP_NOACTIVATE or SWP_NOSIZE); - if DWPStructure = 0 then - Break; - end; - if DWPStructure <> 0 then - EndDeferWindowPos(DWPStructure); - InvalidateRect(Handle, nil, False); - end - else - begin - if (DeltaX <> 0) and (Header.Columns.GetVisibleFixedWidth > 0) then - begin - // When fixed columns exists we have to scroll separately horizontally and vertically. - // Horizontally is scroll only the client area not occupied by fixed columns and - // vertically entire client area (or clipping area if one exists). - R := ClientRect; - R.Left := Header.Columns.GetVisibleFixedWidth; - - ScrollWindow(Handle, DeltaX, 0, @R, @R); - if DeltaY <> 0 then - ScrollWindow(Handle, 0, DeltaY, ClipRect, ClipRect); - end - else - ScrollWindow(Handle, DeltaX, DeltaY, ClipRect, ClipRect); - end; - end; - - if suoUpdateNCArea in Options then - begin - if DeltaX <> 0 then - begin - if (suoRepaintHeader in Options) and (hoVisible in FHeader.FOptions) then - FHeader.Invalidate(nil); - if not (tsSizing in FStates) and (FScrollBarOptions.ScrollBars in [ssHorizontal, ssBoth]) then - UpdateHorizontalScrollBar(suoRepaintScrollbars in Options); - end; - - if (DeltaY <> 0) and ([tsThumbTracking, tsSizing] * FStates = []) then - begin - UpdateVerticalScrollBar(suoRepaintScrollbars in Options); - if not (FHeader.UseColumns or IsMouseSelecting) and - (FScrollBarOptions.ScrollBars in [ssHorizontal, ssBoth]) then - UpdateHorizontalScrollBar(suoRepaintScrollbars in Options); - end; - end; - - if tsVCLDragging in FStates then - ImageList_DragShowNolock(True); - end; - - // Finally update "hot" node if hot tracking is activated - GetCursorPos(P); - P := ScreenToClient(P); - if PtInRect(ClientRect, P) then - HandleHotTrack(P.X, P.Y); - - DoScroll(DeltaX, DeltaY); - end; - Logger.ExitMethod(lcScroll,'DoSetOffsetXY'); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoShowScrollbar(Bar: Integer; Show: Boolean); - -begin - {$ifdef UseFlatScrollbars} - FlatSB_ShowScrollBar(Handle, Bar, Show); - {$else} - ShowScrollBar(Handle, Bar, Show); - {$endif UseFlatScrollbars}; - - if Assigned(FOnShowScrollbar) then - FOnShowScrollbar(Self, Bar, Show); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoStartDrag(var DragObject: TDragObject); - -begin - inherited; - - // Check if the application created an own drag object. This is needed to pass the correct source in - // OnDragOver and OnDragDrop. - if Assigned(DragObject) then - DoStateChange([tsUserDragObject]); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoStateChange(Enter: TVirtualTreeStates; Leave: TVirtualTreeStates = []); - -var - ActualEnter, - ActualLeave: TVirtualTreeStates; - -begin - if Assigned(FOnStateChange) then - begin - ActualEnter := Enter - FStates; - ActualLeave := FStates * Leave; - if (ActualEnter + ActualLeave) <> [] then - FOnStateChange(Self, Enter, Leave); - end; - FStates := FStates + Enter - Leave; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoStructureChange(Node: PVirtualNode; Reason: TChangeReason); - -begin - StopTimer(StructureChangeTimer); - if Assigned(FOnStructureChange) then - FOnStructureChange(Self, Node, Reason); - - // This is a good place to reset the cached node and reason. These are the same as the values passed in here. - // This is necessary to allow descendants to override this method and get them. - DoStateChange([], [tsStructureChangePending]); - FLastStructureChangeNode := nil; - FLastStructureChangeReason := crIgnore; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoTimerScroll; - -var - P, - ClientP: TPoint; - InRect, - Panning: Boolean; - R, - ClipRect: TRect; - DeltaX, - DeltaY: Integer; - -begin - GetCursorPos(P); - R := ClientRect; - ClipRect := R; - MapWindowPoints(Handle, 0, @R.TopLeft, 2); - InRect := PtInRect(R, P); - ClientP := ScreenToClient(P); - Panning := [tsWheelPanning, tsWheelScrolling] * FStates <> []; - - if IsMouseSelecting or InRect or Panning then - begin - DeltaX := 0; - DeltaY := 0; - if sdUp in FScrollDirections then - begin - if Panning then - DeltaY := FLastClickPos.Y - ClientP.Y - 8 - else - if InRect then - DeltaY := Min(FScrollBarOptions.FIncrementY, ClientHeight) - else - DeltaY := Min(FScrollBarOptions.FIncrementY, ClientHeight) * Abs(R.Top - P.Y); - if FOffsetY = 0 then - Exclude(FScrollDirections, sdUp); - end; - - if sdDown in FScrollDirections then - begin - if Panning then - DeltaY := FLastClickPos.Y - ClientP.Y + 8 - else - if InRect then - DeltaY := -Min(FScrollBarOptions.FIncrementY, ClientHeight) - else - DeltaY := -Min(FScrollBarOptions.FIncrementY, ClientHeight) * Abs(P.Y - R.Bottom); - if (ClientHeight - FOffsetY) = Integer(FRangeY) then - Exclude(FScrollDirections, sdDown); - end; - - if sdLeft in FScrollDirections then - begin - if Panning then - DeltaX := FLastClickPos.X - ClientP.X - 8 - else - if InRect then - DeltaX := FScrollBarOptions.FIncrementX - else - DeltaX := FScrollBarOptions.FIncrementX * Abs(R.Left - P.X); - if FEffectiveOffsetX = 0 then - Exclude(FScrollDirections, sdleft); - end; - - if sdRight in FScrollDirections then - begin - if Panning then - DeltaX := FLastClickPos.X - ClientP.X + 8 - else - if InRect then - DeltaX := -FScrollBarOptions.FIncrementX - else - DeltaX := -FScrollBarOptions.FIncrementX * Abs(P.X - R.Right); - - if (ClientWidth + FEffectiveOffsetX) = Integer(FRangeX) then - Exclude(FScrollDirections, sdRight); - end; - - if UseRightToLeftAlignment then - DeltaX := - DeltaX; - - if IsMouseSelecting then - begin - // In order to avoid scrolling the area which needs a repaint due to the changed selection rectangle - // we limit the scroll area explicitely. - OffsetRect(ClipRect, DeltaX, DeltaY); - DoSetOffsetXY(Point(FOffsetX + DeltaX, FOffsetY + DeltaY), DefaultScrollUpdateFlags, @ClipRect); - // When selecting with the mouse then either update only the parts of the window which have been uncovered - // by the scroll operation if no change in the selection happend or invalidate and redraw the entire - // client area otherwise (to avoid the time consuming task of determining the display rectangles of every - // changed node). - if CalculateSelectionRect(ClientP.X, ClientP.Y) and HandleDrawSelection(ClientP.X, ClientP.Y) then - InvalidateRect(Handle, nil, False) - else - begin - // The selection did not change so invalidate only the part of the window which really needs an update. - // 1) Invalidate the parts uncovered by the scroll operation. Add another offset range, we have to - // scroll only one stripe but have to update two. - OffsetRect(ClipRect, DeltaX, DeltaY); - SubtractRect(ClipRect, ClientRect, ClipRect); - InvalidateRect(Handle, @ClipRect, False); - - // 2) Invalidate the selection rectangles. - UnionRect(ClipRect, OrderRect(FNewSelRect), OrderRect(FLastSelRect)); - OffsetRect(ClipRect, FOffsetX, FOffsetY); - InvalidateRect(Handle, @ClipRect, False); - end; - end - else - begin - // Scroll only if there is no drag'n drop in progress. Drag'n drop scrolling is handled in DragOver. - if ((FDragManager = nil) or not DragManager.IsDropTarget) and ((DeltaX <> 0) or (DeltaY <> 0)) then - DoSetOffsetXY(Point(FOffsetX + DeltaX, FOffsetY + DeltaY), DefaultScrollUpdateFlags, nil); - end; - UpdateWindow(Handle); - - if (FScrollDirections = []) and ([tsWheelPanning, tsWheelScrolling] * FStates = []) then - begin - StopTimer(ScrollTimer); - DoStateChange([], [tsScrollPending, tsScrolling]); - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DoUpdating(State: TVTUpdateState); - -begin - if Assigned(FOnUpdating) then - FOnUpdating(Self, State); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.DoValidateCache: Boolean; - -// This method fills the cache, which is used to speed up searching for nodes. -// The strategy is simple: Take the current number of visible nodes and distribute evenly a number of marks -// (which are stored in FPositionCache) so that iterating through the tree doesn't cost too much time. -// If there are less than 'CacheThreshold' nodes in the tree then the cache remains empty. -// Result is True if the cache was filled without interruption, otherwise False. -// Note: You can adjust the maximum number of nodes between two cache entries by changing CacheThreshold. - -var - EntryCount, - CurrentTop, - Index: Cardinal; - CurrentNode, - Temp: PVirtualNode; - -begin - EntryCount := 0; - if not (tsStopValidation in FStates) then - begin - if FStartIndex = 0 then - FPositionCache := nil; - - if FVisibleCount > CacheThreshold then - begin - EntryCount := CalculateCacheEntryCount; - SetLength(FPositionCache, EntryCount); - if FStartIndex > EntryCount then - FStartIndex := EntryCount; - - // Optimize validation by starting with FStartIndex if set. - if (FStartIndex > 0) and Assigned(FPositionCache[FStartIndex - 1].Node) then - begin - // Index is the current entry in FPositionCache. - Index := FStartIndex - 1; - // Running term for absolute top value. - CurrentTop := FPositionCache[Index].AbsoluteTop; - // Running node pointer. - CurrentNode := FPositionCache[Index].Node; - end - else - begin - // Index is the current entry in FPositionCache. - Index := 0; - // Running term for absolute top value. - CurrentTop := 0; - // Running node pointer. - CurrentNode := GetFirstVisibleNoInit; - end; - - // EntryCount serves as counter for processed nodes here. This value can always start at 0 as - // the validation either starts also at index 0 or an index which is always a multiple of CacheThreshold - // and EntryCount is only used with modulo CacheThreshold. - EntryCount := 0; - if Assigned(CurrentNode) then - begin - while not (tsStopValidation in FStates) do - begin - if (EntryCount mod CacheThreshold) = 0 then - begin - // New cache entry to set up. - with FPositionCache[Index] do - begin - Node := CurrentNode; - AbsoluteTop := CurrentTop; - end; - Inc(Index); - end; - - Inc(CurrentTop, NodeHeight[CurrentNode]); - // Advance to next visible node. - Temp := GetNextVisibleNoInit(CurrentNode); - // If there is no further node or the cache is full then stop the loop. - if (Temp = nil) or (Integer(Index) = Length(FPositionCache)) then - Break; - - CurrentNode := Temp; - Inc(EntryCount); - end; - end; - // Finalize the position cache so no nil entry remains there. - if not (tsStopValidation in FStates) and (Integer(Index) <= High(FPositionCache)) then - begin - SetLength(FPositionCache, Index + 1); - with FPositionCache[Index] do - begin - Node := CurrentNode; - AbsoluteTop := CurrentTop; - end; - end; - end; - end; - - Result := (EntryCount > 0) and not (tsStopValidation in FStates); - - // In variable node height mode it might have happend that some or all of the nodes have been adjusted in their - // height. During validation updates of the scrollbars is disabled so let's do this here. - if Result and (toVariableNodeHeight in FOptions.FMiscOptions) then - UpdateScrollbars(True); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DragCanceled; - -// Does some housekeeping for VCL drag'n drop; - -begin - inherited; - - DragFinished; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.DragDrop(const DataObject: IDataObject; KeyState: Integer; Pt: TPoint; - var Effect: LongWord): HResult; - -var - Shift: TShiftState; - EnumFormat: IEnumFormatEtc; - Fetched: LongWord; - OLEFormat: TFormatEtc; - Formats: TFormatArray; - -begin - StopTimer(ExpandTimer); - StopTimer(ScrollTimer); - DoStateChange([], [tsScrollPending, tsScrolling]); - Formats := nil; - - // Ask explicitly again whether the action is allowed. Otherwise we may accept a drop which is intentionally not - // allowed but cannot be prevented by the application because when the tree was scrolling while dropping - // no DragOver event is created by the OLE subsystem. - Result := DragOver(DragManager.DragSource, KeyState, dsDragMove, Pt, Effect); - try - if (Result <> NOERROR) or ((Effect and not DROPEFFECT_SCROLL) = DROPEFFECT_NONE) then - Result := E_FAIL - else - begin - try - Shift := KeysToShiftState(KeyState); - if tsLeftButtonDown in FStates then - Include(Shift, ssLeft); - if tsMiddleButtonDown in FStates then - Include(Shift, ssMiddle); - if tsRightButtonDown in FStates then - Include(Shift, ssRight); - Pt := ScreenToClient(Pt); - // Determine which formats we can get and pass them along with the data object to the drop handler. - Result := DataObject.EnumFormatEtc(DATADIR_GET, EnumFormat); - if Failed(Result) then - Abort; - Result := EnumFormat.Reset; - if Failed(Result) then - Abort; - // create a list of available formats - while EnumFormat.Next(1, OLEFormat, Fetched) = S_OK do - begin - SetLength(Formats, Length(Formats) + 1); - Formats[High(Formats)] := OLEFormat.cfFormat; - end; - DoDragDrop(DragManager.DragSource, DataObject, Formats, Shift, Pt, Effect, FLastDropMode); - except - Result := E_UNEXPECTED; - raise; - end; - end; - finally - if Assigned(FDropTargetNode) then - begin - InvalidateNode(FDropTargetNode); - FDropTargetNode := nil; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.DragEnter(KeyState: Integer; Pt: TPoint; var Effect: LongWord): HResult; - -// callback routine for the drop target interface - -var - Shift: TShiftState; - Accept: Boolean; - R: TRect; - HitInfo: THitInfo; - -begin - try - // Determine acceptance of drag operation and reset scroll start time. - FDragScrollStart := 0; - - Shift := KeysToShiftState(KeyState); - if tsLeftButtonDown in FStates then - Include(Shift, ssLeft); - if tsMiddleButtonDown in FStates then - Include(Shift, ssMiddle); - if tsRightButtonDown in FStates then - Include(Shift, ssRight); - Pt := ScreenToClient(Pt); - Effect := SuggestDropEffect(DragManager.DragSource, Shift, Pt, Effect); - Accept := DoDragOver(DragManager.DragSource, Shift, dsDragEnter, Pt, FLastDropMode, Effect); - if not Accept then - Effect := DROPEFFECT_NONE - else - begin - // Set initial drop target node and drop mode. - GetHitTestInfoAt(Pt.X, Pt.Y, True, HitInfo); - if Assigned(HitInfo.HitNode) then - begin - FDropTargetNode := HitInfo.HitNode; - R := GetDisplayRect(HitInfo.HitNode, FHeader.MainColumn, False); - if hiOnItemLabel in HitInfo.HitPositions then - FLastDropMode := dmOnNode - else - if ((R.Top + R.Bottom) div 2) > Pt.Y then - FLastDropMode := dmAbove - else - FLastDropMode := dmBelow; - end - else - FLastDropMode := dmNowhere; - end; - - // If the drag source is a virtual tree then we know how to control the drag image - // and can show it even if the source is not the target tree. - // This is only necessary if we cannot use the drag image helper interfaces. - if not DragManager.DropTargetHelperSupported and Assigned(DragManager.DragSource) then - DragManager.DragSource.FDragImage.ShowDragImage; - Result := NOERROR; - except - Result := E_UNEXPECTED; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DragFinished; - -// Called by DragCancelled or EndDrag to make up for the still missing mouse button up messages. -// These are important for such important things like popup menus. - -var - P: TPoint; - -begin - DoStateChange([], [tsVCLDragPending, tsVCLDragging, tsUserDragObject]); - - GetCursorPos(P); - P := ScreenToClient(P); - if tsRightButtonDown in FStates then - Perform(LM_RBUTTONUP, 0, Longint(PointToSmallPoint(P))) - else - if tsMiddleButtonDown in FStates then - Perform(LM_MBUTTONUP, 0, Longint(PointToSmallPoint(P))) - else - Perform(LM_LBUTTONUP, 0, Longint(PointToSmallPoint(P))); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DragLeave; - -var - Effect: LongWord; - -begin - StopTimer(ExpandTimer); - - if not DragManager.DropTargetHelperSupported and Assigned(DragManager.DragSource) then - DragManager.DragSource.FDragImage.HideDragImage; - - if Assigned(FDropTargetNode) then - begin - InvalidateNode(FDropTargetNode); - FDropTargetNode := nil; - end; - UpdateWindow(Handle); - - Effect := 0; - DoDragOver(nil, [], dsDragLeave, Point(0, 0), FLastDropMode, Effect); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.DragOver(Source: TObject; KeyState: Integer; DragState: TDragState; Pt: TPoint; - var Effect: LongWord): HResult; - -// callback routine for the drop target interface - -var - Shift: TShiftState; - Accept, - DragImageWillMove, - WindowScrolled: Boolean; - OldR, R: TRect; - NewDropMode: TDropMode; - HitInfo: THitInfo; - ImageHit: Boolean; - LabelHit: Boolean; - DragPos: TPoint; - Tree: TBaseVirtualTree; - LastNode: PVirtualNode; - - DeltaX, - DeltaY: Integer; - ScrollOptions: TScrollUpdateOptions; - -begin - if not DragManager.DropTargetHelperSupported and (Source is TBaseVirtualTree) then - begin - Tree := Source as TBaseVirtualTree; - ScrollOptions := [suoUpdateNCArea]; - end - else - begin - Tree := nil; - ScrollOptions := DefaultScrollUpdateFlags; - end; - - try - DragPos := Pt; - Pt := ScreenToClient(Pt); - - // Check if we have to scroll the client area. - FScrollDirections := DetermineScrollDirections(Pt.X, Pt.Y); - DeltaX := 0; - DeltaY := 0; - if FScrollDirections <> [] then - begin - // Determine amount to scroll. - if sdUp in FScrollDirections then - begin - DeltaY := Min(FScrollBarOptions.FIncrementY, ClientHeight); - if FOffsetY = 0 then - Exclude(FScrollDirections, sdUp); - end; - if sdDown in FScrollDirections then - begin - DeltaY := -Min(FScrollBarOptions.FIncrementY, ClientHeight); - if (ClientHeight - FOffsetY) = Integer(FRangeY) then - Exclude(FScrollDirections, sdDown); - end; - if sdLeft in FScrollDirections then - begin - DeltaX := FScrollBarOptions.FIncrementX; - if FEffectiveOffsetX = 0 then - Exclude(FScrollDirections, sdleft); - end; - if sdRight in FScrollDirections then - begin - DeltaX := -FScrollBarOptions.FIncrementX; - if (ClientWidth + FEffectiveOffsetX) = Integer(FRangeX) then - Exclude(FScrollDirections, sdRight); - end; - WindowScrolled := DoSetOffsetXY(Point(FOffsetX + DeltaX, FOffsetY + DeltaY), ScrollOptions, nil); - end - else - WindowScrolled := False; - - // Determine acceptance of drag operation as well as drag target. - Shift := KeysToShiftState(KeyState); - if tsLeftButtonDown in FStates then - Include(Shift, ssLeft); - if tsMiddleButtonDown in FStates then - Include(Shift, ssMiddle); - if tsRightButtonDown in FStates then - Include(Shift, ssRight); - GetHitTestInfoAt(Pt.X, Pt.Y, True, HitInfo); - ImageHit := HitInfo.HitPositions * [hiOnNormalIcon, hiOnStateIcon] <> []; - LabelHit := hiOnItemLabel in HitInfo.HitPositions; - // In report mode only direct hits of the node captions/images in the main column are accepted as hits. - if (toReportMode in FOptions.FMiscOptions) and not ((LabelHit or ImageHit) and - (HitInfo.HitColumn = FHeader.MainColumn)) then - HitInfo.HitNode := nil; - - if Assigned(HitInfo.HitNode) then - begin - R := GetDisplayRect(HitInfo.HitNode, NoColumn, False); - if LabelHit or ImageHit or not (toShowDropmark in FOptions.FPaintOptions) then - NewDropMode := dmOnNode - else - if ((R.Top + R.Bottom) div 2) > Pt.Y then - NewDropMode := dmAbove - else - NewDropMode := dmBelow; - end - else - begin - NewDropMode := dmNowhere; - R := Rect(0, 0, 0, 0); - end; - - if Assigned(Tree) then - DragImageWillMove := Tree.FDragImage.WillMove(DragPos) - else - DragImageWillMove := False; - - if (HitInfo.HitNode <> FDropTargetNode) or (FLastDropMode <> NewDropMode) then - begin - // Something in the tree will change. This requires to update the screen and/or the drag image. - FLastDropMode := NewDropMode; - if HitInfo.HitNode <> FDropTargetNode then - begin - StopTimer(ExpandTimer); - // The last target node is needed for the rectangle determination but must already be set for - // the recapture call, hence it must be stored somewhere. - LastNode := FDropTargetNode; - FDropTargetNode := HitInfo.HitNode; - // In order to show a selection rectangle a column must be focused. - if FFocusedColumn = NoColumn then - FFocusedColumn := FHeader.MainColumn; - - if Assigned(LastNode) and Assigned(FDropTargetNode) then - begin - // Optimize the case that the selection moved between two nodes. - OldR := GetDisplayRect(LastNode, NoColumn, False); - UnionRect(R, R, OldR); - if Assigned(Tree) then - begin - if WindowScrolled then - UpdateWindowAndDragImage(Tree, ClientRect, True, not DragImageWillMove) - else - UpdateWindowAndDragImage(Tree, R, False, not DragImageWillMove); - end - else - InvalidateRect(Handle, @R, False); - end - else - begin - if Assigned(LastNode) then - begin - // Repaint last target node. - OldR := GetDisplayRect(LastNode, NoColumn, False); - if Assigned(Tree) then - begin - if WindowScrolled then - UpdateWindowAndDragImage(Tree, ClientRect, WindowScrolled, not DragImageWillMove) - else - UpdateWindowAndDragImage(Tree, OldR, False, not DragImageWillMove); - end - else - InvalidateRect(Handle, @OldR, False); - end - else - begin - if Assigned(Tree) then - begin - if WindowScrolled then - UpdateWindowAndDragImage(Tree, ClientRect, WindowScrolled, not DragImageWillMove) - else - UpdateWindowAndDragImage(Tree, R, False, not DragImageWillMove); - end - else - InvalidateRect(Handle, @R, False); - end; - end; - - // Start auto expand timer if necessary. - if (toAutoDropExpand in FOptions.FAutoOptions) and Assigned(FDropTargetNode) and - (vsHasChildren in FDropTargetNode.States) then - SetTimer(Handle, ExpandTimer, FAutoExpandDelay, nil); - end - else - begin - // Only the drop mark position changed so invalidate the current drop target node. - if Assigned(Tree) then - begin - if WindowScrolled then - UpdateWindowAndDragImage(Tree, ClientRect, WindowScrolled, not DragImageWillMove) - else - UpdateWindowAndDragImage(Tree, R, False, not DragImageWillMove); - end - else - InvalidateRect(Handle, @R, False); - end; - end - else - begin - // No change in the current drop target or drop mode. This might still mean horizontal or vertical scrolling. - if Assigned(Tree) and ((DeltaX <> 0) or (DeltaY <> 0)) then - UpdateWindowAndDragImage(Tree, ClientRect, WindowScrolled, not DragImageWillMove); - end; - - Update; - - if Assigned(Tree) and DragImageWillMove then - Tree.FDragImage.DragTo(DragPos, False); - - Effect := SuggestDropEffect(Source, Shift, Pt, Effect); - Accept := DoDragOver(Source, Shift, DragState, Pt, FLastDropMode, Effect); - if not Accept then - Effect := DROPEFFECT_NONE; - if WindowScrolled then - Effect := Effect or Integer(DROPEFFECT_SCROLL); - Result := NOERROR; - except - Result := E_UNEXPECTED; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DrawDottedHLine(const PaintInfo: TVTPaintInfo; Left, Right, Top: Integer); - -// Draws a horizontal line with alternating pixels (this style is not supported for pens under Win9x). - -var - R: TRect; - -begin - with PaintInfo, Canvas do - begin - Brush.Color := Color; - R := Rect(Min(Left, Right), Top, Max(Left, Right) + 1, Top + 1); - LCLIntf.FillRect(Handle, R, FDottedBrush); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DrawDottedVLine(const PaintInfo: TVTPaintInfo; Top, Bottom, Left: Integer); - -// Draws a horizontal line with alternating pixels (this style is not supported for pens under Win9x). - -var - R: TRect; - -begin - with PaintInfo, Canvas do - begin - Brush.Color := Self.Color; - R := Rect(Left, Min(Top, Bottom), Left + 1, Max(Top, Bottom) + 1); - LCLIntf.FillRect(Handle, R, FDottedBrush); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.FindNodeInSelection(P: PVirtualNode; var Index: Integer; LowBound, - HighBound: Integer): Boolean; - -// Search routine to find a specific node in the selection array. -// LowBound and HighBound determine the range in which to search the node. -// Either value can be -1 to denote the maximum range otherwise LowBound must be less or equal HighBound. - -var - L, H, - I, C: Integer; - -begin - Result := False; - L := 0; - if LowBound >= 0 then - L := LowBound; - H := FSelectionCount - 1; - if HighBound >= 0 then - H := HighBound; - while L <= H do - begin - I := (L + H) shr 1; - C := Integer(FSelection[I]) - Integer(P); - if C < 0 then - L := I + 1 - else - begin - H := I - 1; - if C = 0 then - begin - Result := True; - L := I; - end; - end; - end; - Index := L; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.FinishChunkHeader(Stream: TStream; StartPos, EndPos: Integer); - -// used while streaming out a node to finally write out the size of the chunk - -var - Size: Integer; - -begin - // seek back to the second entry in the chunk header - Stream.Position := StartPos + SizeOf(Integer); - // determine size of chunk without the chunk header - Size := EndPos - StartPos - SizeOf(TChunkHeader); - // write the size... - Stream.Write(Size, SizeOf(Size)); - // ... and seek to the last endposition - Stream.Position := EndPos; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.FontChanged(AFont: TObject); - -// Little helper function for font changes (as they are not tracked in TBitmap/TCanvas.OnChange). - -begin - FFontChanged := True; - FOldFontChange(AFont); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetBorderDimensions: TSize; - -// Returns the overall width of the current window border, depending on border styles. -// Note: these numbers represent the system's standards not special properties, which can be set for TWinControl -// (e.g. bevels, border width). - -var - Styles: Integer; - -begin - Result.cx := 0; - Result.cy := 0; - - Styles := GetWindowLong(Handle, GWL_STYLE); - if (Styles and WS_BORDER) <> 0 then - begin - Dec(Result.cx); - Dec(Result.cy); - end; - if (Styles and WS_THICKFRAME) <> 0 then - begin - Dec(Result.cx, GetSystemMetrics(SM_CXFIXEDFRAME)); - Dec(Result.cy, GetSystemMetrics(SM_CYFIXEDFRAME)); - end; - Styles := GetWindowLong(Handle, GWL_EXSTYLE); - if (Styles and WS_EX_CLIENTEDGE) <> 0 then - begin - Dec(Result.cx, GetSystemMetrics(SM_CXEDGE)); - Dec(Result.cy, GetSystemMetrics(SM_CYEDGE)); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetCheckImage(Node: PVirtualNode): Integer; - -// Determines the index into the check image list for the given node depending on the check type -// and enabled state. - -const - // Four dimensional array consisting of image indices for the check type, the check state, the enabled state and the - // hot state. - CheckStateToCheckImage: array[ctCheckBox..ctButton, csUncheckedNormal..csMixedPressed, Boolean, Boolean] of Integer = ( - // ctCheckBox, ctTriStateCheckBox - ( - // csUncheckedNormal (disabled [not hot, hot], enabled [not hot, hot]) - ((ckCheckUncheckedDisabled, ckCheckUncheckedDisabled), (ckCheckUncheckedNormal, ckCheckUncheckedHot)), - // csUncheckedPressed (disabled [not hot, hot], enabled [not hot, hot]) - ((ckCheckUncheckedDisabled, ckCheckUncheckedDisabled), (ckCheckUncheckedPressed, ckCheckUncheckedPressed)), - // csCheckedNormal - ((ckCheckCheckedDisabled, ckCheckCheckedDisabled), (ckCheckCheckedNormal, ckCheckCheckedHot)), - // csCheckedPressed - ((ckCheckCheckedDisabled, ckCheckCheckedDisabled), (ckCheckCheckedPressed, ckCheckCheckedPressed)), - // csMixedNormal - ((ckCheckMixedDisabled, ckCheckMixedDisabled), (ckCheckMixedNormal, ckCheckMixedHot)), - // csMixedPressed - ((ckCheckMixedDisabled, ckCheckMixedDisabled), (ckCheckMixedPressed, ckCheckMixedPressed)) - ), - // ctRadioButton - ( - // csUncheckedNormal (disabled [not hot, hot], enabled [not hot, hot]) - ((ckRadioUncheckedDisabled, ckRadioUncheckedDisabled), (ckRadioUncheckedNormal, ckRadioUncheckedHot)), - // csUncheckedPressed (disabled [not hot, hot], enabled [not hot, hot]) - ((ckRadioUncheckedDisabled, ckRadioUncheckedDisabled), (ckRadioUncheckedPressed, ckRadioUncheckedPressed)), - // csCheckedNormal - ((ckRadioCheckedDisabled, ckRadioCheckedDisabled), (ckRadioCheckedNormal, ckRadioCheckedHot)), - // csCheckedPressed - ((ckRadioCheckedDisabled, ckRadioCheckedDisabled), (ckRadioCheckedPressed, ckRadioCheckedPressed)), - // csMixedNormal (should never appear with ctRadioButton) - ((ckCheckMixedDisabled, ckCheckMixedDisabled), (ckCheckMixedNormal, ckCheckMixedHot)), - // csMixedPressed (should never appear with ctRadioButton) - ((ckCheckMixedDisabled, ckCheckMixedDisabled), (ckCheckMixedPressed, ckCheckMixedPressed)) - ), - // ctButton - ( - // csUncheckedNormal (disabled [not hot, hot], enabled [not hot, hot]) - ((ckButtonDisabled, ckButtonDisabled), (ckButtonNormal, ckButtonHot)), - // csUncheckedPressed (disabled [not hot, hot], enabled [not hot, hot]) - ((ckButtonDisabled, ckButtonDisabled), (ckButtonPressed, ckButtonPressed)), - // csCheckedNormal - ((ckButtonDisabled, ckButtonDisabled), (ckButtonNormal, ckButtonHot)), - // csCheckedPressed - ((ckButtonDisabled, ckButtonDisabled), (ckButtonPressed, ckButtonPressed)), - // csMixedNormal (should never appear with ctButton) - ((ckCheckMixedDisabled, ckCheckMixedDisabled), (ckCheckMixedNormal, ckCheckMixedHot)), - // csMixedPressed (should never appear with ctButton) - ((ckCheckMixedDisabled, ckCheckMixedDisabled), (ckCheckMixedPressed, ckCheckMixedPressed)) - ) - ); - -var - AType: TCheckType; - -begin - if Node.CheckType = ctNone then - Result := -1 - else - begin - AType := Node.CheckType; - if AType = ctTriStateCheckBox then - AType := ctCheckBox; - Result := CheckStateToCheckImage[AType, Node.CheckState, not (vsDisabled in Node.States) and Enabled, - Node = FCurrentHotNode]; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -class function TBaseVirtualTree.GetCheckImageListFor(Kind: TCheckImageKind): TCustomImageList; - -begin - case Kind of - ckDarkCheck: - Result := DarkCheckImages; - ckLightTick: - Result := LightTickImages; - ckDarkTick: - Result := DarkTickImages; - ckLightCheck: - Result := LightCheckImages; - ckFlat: - Result := FlatImages; - ckXP: - Result := XPImages; - ckSystem: - Result := SystemCheckImages; - ckSystemFlat: - Result := SystemFlatCheckImages; - else - Result := nil; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetColumnClass: TVirtualTreeColumnClass; - -begin - Result := TVirtualTreeColumn; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetHeaderClass: TVTHeaderClass; - -begin - Result := TVTHeader; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetHintWindowClass: THintWindowClass; - -// Returns the default hint window class used for the tree. Descendants can override it to use their own classes. - -begin - Result := TVirtualTreeHintWindow; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.GetImageIndex(var Info: TVTPaintInfo; Kind: TVTImageKind; InfoIndex: TVTImageInfoIndex; - DefaultImages: TCustomImageList); - -// Retrieves the image index and an eventual customized image list for drawing. - -var - CustomImages: TCustomImageList; - -begin - with Info do - begin - ImageInfo[InfoIndex].Index := -1; - ImageInfo[InfoIndex].Ghosted := False; - - CustomImages := DoGetImageIndex(Node, Kind, Column, ImageInfo[InfoIndex].Ghosted, ImageInfo[InfoIndex].Index); - if Assigned(CustomImages) then - ImageInfo[InfoIndex].Images := CustomImages - else - ImageInfo[InfoIndex].Images := DefaultImages; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetMaxRightExtend: Cardinal; - -// Determines the maximum with of the currently visible part of the tree, depending on the length -// of the node texts. This method is used for determining the horizontal scroll range if no columns are used. - -var - Node, - NextNode: PVirtualNode; - TopPosition: Integer; - NodeLeft, - CurrentWidth: Integer; - WithCheck: Boolean; - CheckOffset: Integer; - -begin - Node := GetNodeAt(0, 0, True, TopPosition); - Result := 0; - if toShowRoot in FOptions.FPaintOptions then - NodeLeft := (GetNodeLevel(Node) + 1) * FIndent - else - NodeLeft := GetNodeLevel(Node) * FIndent; - - if Assigned(FStateImages) then - Inc(NodeLeft, FStateImages.Width + 2); - if Assigned(FImages) then - Inc(NodeLeft, FImages.Width + 2); - WithCheck := (toCheckSupport in FOptions.FMiscOptions) and Assigned(FCheckImages); - if WithCheck then - CheckOffset := FCheckImages.Width + 2 - else - CheckOffset := 0; - - while Assigned(Node) do - begin - if not (vsInitialized in Node.States) then - InitNode(Node); - - if WithCheck and (Node.CheckType <> ctNone) then - Inc(NodeLeft, CheckOffset); - CurrentWidth := DoGetNodeWidth(Node, NoColumn); - if Integer(Result) < (NodeLeft + CurrentWidth) then - Result := NodeLeft + CurrentWidth; - Inc(TopPosition, NodeHeight[Node]); - if TopPosition > Height then - Break; - - if WithCheck and (Node.CheckType <> ctNone) then - Dec(NodeLeft, CheckOffset); - - // Get next visible node and update left node position. - NextNode := GetNextVisible(Node); - if NextNode = nil then - Break; - Inc(NodeLeft, CountLevelDifference(Node, NextNode) * Integer(FIndent)); - Node := NextNode; - end; - - Inc(Result, FMargin); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.GetNativeClipboardFormats(var Formats: TFormatEtcArray); - -// Returns the supported clipboard formats of the tree. - -begin - InternalClipboardFormats.EnumerateFormats(TVirtualTreeClass(ClassType), Formats, FClipboardFormats); - // Ask application/descendants for self defined formats. - DoGetUserClipboardFormats(Formats); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetOptionsClass: TTreeOptionsClass; - -begin - Result := TCustomVirtualTreeOptions; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetTreeFromDataObject(const DataObject: IDataObject): TBaseVirtualTree; - -// Returns the owner/sender of the given data object by means of a special clipboard format -// or nil if the sender is in another process or no virtual tree at all. - -var - Medium: TStgMedium; - Data: PVTReference; - -begin - {$ifdef NeedWindows} - Result := nil; - if Assigned(DataObject) then - begin - StandardOLEFormat.cfFormat := CF_VTREFERENCE; - if DataObject.GetData(StandardOLEFormat, Medium) = S_OK then - begin - Data := GlobalLock(Medium.hGlobal); - if Assigned(Data) then - begin - if Data.Process = GetCurrentProcessID then - Result := Data.Tree; - GlobalUnlock(Medium.hGlobal); - end; - ReleaseStgMedium(@Medium); - end; - end; - {$endif} -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.HandleHotTrack(X, Y: Integer); - -// Updates the current "hot" node. - -var - HitInfo: THitInfo; - DoInvalidate: Boolean; - -begin - // Get information about the hit. - GetHitTestInfoAt(X, Y, True, HitInfo); - // Only make the new node being "hot" if its label is hit or full row selection is enabled. - if ([hiOnItemLabel, hiOnItemCheckbox] * HitInfo.HitPositions = []) and - not (toFullRowSelect in FOptions.FSelectionOptions) then - HitInfo.HitNode := nil; - if HitInfo.HitNode <> FCurrentHotNode then - begin - DoInvalidate := (toHotTrack in FOptions.PaintOptions) or (toCheckSupport in FOptions.FMiscOptions); - DoHotChange(FCurrentHotNode, HitInfo.HitNode); - if Assigned(FCurrentHotNode) and DoInvalidate then - InvalidateNode(FCurrentHotNode); - FCurrentHotNode := HitInfo.HitNode; - if Assigned(FCurrentHotNode) and DoInvalidate then - InvalidateNode(FCurrentHotNode); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.HandleIncrementalSearch(CharCode: Word); - -var - Run, Stop: PVirtualNode; - GetNextNode: TGetNextNodeProc; - NewSearchText: WideString; - SingleLetter, - PreviousSearch: Boolean; // True if VK_BACK was sent. - SearchDirection: TVTSearchDirection; - - //--------------- local functions ------------------------------------------- - - procedure SetupNavigation; - - // If the search buffer is empty then we start searching with the next node after the last one, otherwise - // we continue with the last one. Node navigation function is set up too here, to avoid frequent checks. - - var - FindNextNode: Boolean; - - begin - FindNextNode := (Length(FSearchBuffer) = 0) or (Run = nil) or SingleLetter or PreviousSearch; - case FIncrementalSearch of - isVisibleOnly: - if SearchDirection = sdForward then - begin - GetNextNode := GetNextVisible; - if FindNextNode then - begin - if Run = nil then - Run := GetFirstVisible - else - begin - Run := GetNextVisible(Run); - // Do wrap around. - if Run = nil then - Run := GetFirstVisible; - end; - end; - end - else - begin - GetNextNode := GetPreviousVisible; - if FindNextNode then - begin - if Run = nil then - Run := GetLastVisible - else - begin - Run := GetPreviousVisible(Run); - // Do wrap around. - if Run = nil then - Run := GetLastVisible; - end; - end; - end; - isInitializedOnly: - if SearchDirection = sdForward then - begin - GetNextNode := GetNextNoInit; - if FindNextNode then - begin - if Run = nil then - Run := GetFirstNoInit - else - begin - Run := GetNextNoInit(Run); - // Do wrap around. - if Run = nil then - Run := GetFirstNoInit; - end; - end; - end - else - begin - GetNextNode := GetPreviousNoInit; - if FindNextNode then - begin - if Run = nil then - Run := GetLastNoInit - else - begin - Run := GetPreviousNoInit(Run); - // Do wrap around. - if Run = nil then - Run := GetLastNoInit; - end; - end; - end; - else - // isAll - if SearchDirection = sdForward then - begin - GetNextNode := GetNext; - if FindNextNode then - begin - if Run = nil then - Run := GetFirst - else - begin - Run := GetNext(Run); - // Do wrap around. - if Run = nil then - Run := GetFirst; - end; - end; - end - else - begin - GetNextNode := GetPrevious; - if FindNextNode then - begin - if Run = nil then - Run := GetLast - else - begin - Run := GetPrevious(Run); - // Do wrap around. - if Run = nil then - Run := GetLast; - end; - end; - end; - end; - end; - - //--------------------------------------------------------------------------- - - function CodePageFromLocale(Language: DWord): Integer; - - // Determines the code page for a given locale. - // Unfortunately there is no easier way than this, currently. - - var - Buf: array[0..6] of Char; - - begin - GetLocaleInfo(Language, LOCALE_IDEFAULTANSICODEPAGE, Buf, 6); - Result := StrToIntDef(Buf, GetACP); - end; - - //--------------------------------------------------------------------------- - - function KeyUnicode(C: Char): WideChar; - - // Converts the given character into its corresponding Unicode character - // depending on the active keyboard layout. - - begin - MultiByteToWideChar(CodePageFromLocale(GetKeyboardLayout(0) and $FFFF), - MB_USEGLYPHCHARS, @C, 1, @Result, 1); - end; - - //--------------- end local functions --------------------------------------- - -var - FoundMatch: Boolean; - NewChar: WideChar; - -begin - StopTimer(SearchTimer); - - if FIncrementalSearch <> isNone then - begin - if CharCode <> 0 then - begin - DoStateChange([tsIncrementalSearching]); - - // Convert the given virtual key code into a Unicode character based on the current locale. - NewChar := KeyUnicode(Char(CharCode)); - PreviousSearch := NewChar = WideChar(VK_BACK); - // We cannot do a search with an empty search buffer. - if not PreviousSearch or (Length(FSearchBuffer) > 1) then - begin - // Determine which method to use to advance nodes and the start node to search from. - case FSearchStart of - ssAlwaysStartOver: - Run := nil; - ssFocusedNode: - Run := FFocusedNode; - else // ssLastHit - Run := FLastSearchNode; - end; - - // Make sure the start node corresponds to the search criterion. - if Assigned(Run) then - begin - case FIncrementalSearch of - isInitializedOnly: - if not (vsInitialized in Run.States) then - Run := nil; - isVisibleOnly: - if not FullyVisible[Run] then - Run := nil; - end; - end; - Stop := Run; - - // VK_BACK temporarily changes search direction to opposite mode. - if PreviousSearch then - begin - if SearchDirection = sdBackward then - SearchDirection := sdForward - else - SearchDirection := sdBackward - end - else - SearchDirection := FSearchDirection; - // The "single letter mode" is used to advance quickly from node to node when pressing the same key several times. - SingleLetter := (Length(FSearchBuffer) = 1) and not PreviousSearch and (FSearchBuffer[1] = NewChar); - // However if the current hit (if there is one) would fit also with a repeated character then - // don't use single letter mode. - if SingleLetter and (DoIncrementalSearch(Run, FSearchBuffer + NewChar) = 0) then - SingleLetter := False; - SetupNavigation; - FoundMatch := False; - - if Assigned(Run) then - begin - if SingleLetter then - NewSearchText := FSearchBuffer - else - if PreviousSearch then - begin - SetLength(FSearchBuffer, Length(FSearchBuffer) - 1); - NewSearchText := FSearchBuffer; - end - else - NewSearchText := FSearchBuffer + NewChar; - - repeat - if DoIncrementalSearch(Run, NewSearchText) = 0 then - begin - FoundMatch := True; - Break; - end; - - // Advance to next node if we have not found a match. - Run := GetNextNode(Run); - // Do wrap around start or end of tree. - if (Run <> Stop) and (Run = nil) then - SetupNavigation; - until Run = Stop; - end; - - if FoundMatch then - begin - ClearSelection; - FSearchBuffer := NewSearchText; - FLastSearchNode := Run; - FocusedNode := Run; - Selected[Run] := True; - FLastSearchNode := Run; - end - else - // Play an acoustic signal if nothing could be found but don't beep if only the currently - // focused node matches. - if Assigned(Run) and (DoIncrementalSearch(Run, NewSearchText) <> 0) then - Beep; - end; - end; - - // Restart search timeout interval. - SetTimer(Handle, SearchTimer, FSearchTimeout, nil); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.HandleMouseDblClick(var Message: TLMMouse; const HitInfo: THitInfo); - -var - NewCheckState: TCheckState; - -begin - if tsEditPending in FStates then - begin - StopTimer(EditTimer); - DoStateChange([], [tsEditPending]); - end; - - if not (tsEditing in FStates) or DoEndEdit then - begin - if HitInfo.HitColumn = FHeader.FColumns.FClickIndex then - DoColumnDblClick(HitInfo.HitColumn, KeysToShiftState(Message.Keys)); - - if hiOnItemCheckBox in HitInfo.HitPositions then - begin - if (FStates * [tsMouseCheckPending, tsKeyCheckPending] = []) and not (vsDisabled in HitInfo.HitNode.States) then - begin - with HitInfo.HitNode^ do - NewCheckState := DetermineNextCheckState(CheckType, CheckState); - if DoChecking(HitInfo.HitNode, NewCheckState) then - begin - DoStateChange([tsMouseCheckPending]); - FCheckNode := HitInfo.HitNode; - FPendingCheckState := NewCheckState; - FCheckNode.CheckState := PressedState[FCheckNode.CheckState]; - InvalidateNode(HitInfo.HitNode); - end; - end; - end - else - begin - if hiOnItemButton in HitInfo.HitPositions then - ToggleNode(HitInfo.HitNode) - else - begin - if toToggleOnDblClick in FOptions.FMiscOptions then - begin - if ((([hiOnItemButton, hiOnItemLabel, hiOnNormalIcon, hiOnStateIcon] * HitInfo.HitPositions) <> []) or - ((toFullRowSelect in FOptions.FSelectionOptions) and Assigned(HitInfo.HitNode))) then - ToggleNode(HitInfo.HitNode); - end; - end; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.HandleMouseDown(var Message: TLMMouse; const HitInfo: THitInfo); - -// centralized mouse button down handling - -var - LastFocused: PVirtualNode; - Column: TColumnIndex; - ShiftState: TShiftState; - - // helper variables to shorten boolean equations/expressions - AutoDrag, // automatic (or allowed) drag start - IsHit, // the node's caption or images are hit - IsCellHit, // for grid extension or full row select (but not check box, button) - IsAnyHit, // either IsHit or IsCellHit - MultiSelect, // multiselection is enabled - ShiftEmpty, // ShiftState = [] - NodeSelected: Boolean; // the new node (if any) is selected - NewColumn: Boolean; // column changed - NewNode: Boolean; // Node changed. - NeedChange: Boolean; // change event is required for selection change - CanClear: Boolean; - NewCheckState: TCheckState; - AltPressed: Boolean; // Pressing the Alt key enables special processing for selection. - FullRowDrag: Boolean; // Start dragging anywhere within a node's bound. - -begin - if [tsWheelPanning, tsWheelScrolling] * FStates <> [] then - begin - StopWheelPanning; - Exit; - end; - - if tsEditPending in FStates then - begin - StopTimer(EditTimer); - DoStateChange([], [tsEditPending]); - end; - - if not (tsEditing in FStates) or DoEndEdit then - begin - // Focus change. Don't use the SetFocus method as this does not work for MDI windows. - if not Focused and CanFocus then - LCLIntf.SetFocus(Handle); - - // Keep clicked column in case the application needs it. - FHeader.FColumns.FClickIndex := HitInfo.HitColumn; - - // Change column only if we have hit the node label. - if (hiOnItemLabel in HitInfo.HitPositions) or - (toFullRowSelect in FOptions.FSelectionOptions) or - (toGridExtensions in FOptions.FMiscOptions) then - begin - NewColumn := FFocusedColumn <> HitInfo.HitColumn; - if toExtendedFocus in FOptions.FSelectionOptions then - Column := HitInfo.HitColumn - else - Column := FHeader.MainColumn; - end - else - begin - NewColumn := False; - Column := FFocusedColumn; - end; - - NewNode := FFocusedNode <> HitInfo.HitNode; - - // Translate keys and filter out shift and control key. - ShiftState := KeysToShiftState(Message.Keys) * [ssShift, ssCtrl, ssAlt]; - if ssAlt in ShiftState then - begin - AltPressed := True; - // Remove the Alt key from the shift state. It is not meaningful there. - Exclude(ShiftState, ssAlt); - end - else - AltPressed := False; - - // Various combinations determine what states the tree enters now. - // We initialize shorthand variables to avoid the following expressions getting too large - // and to avoid repeative expensive checks. - IsHit := not AltPressed and ((hiOnItemLabel in HitInfo.HitPositions) or (hiOnNormalIcon in HitInfo.HitPositions)); - IsCellHit := not AltPressed and not IsHit and Assigned(HitInfo.HitNode) and - ([hiOnItemButton, hiOnItemCheckBox] * HitInfo.HitPositions = []) and - ((toFullRowSelect in FOptions.FSelectionOptions) or (toGridExtensions in FOptions.FMiscOptions)); - IsAnyHit := IsHit or IsCellHit; - MultiSelect := toMultiSelect in FOptions.FSelectionOptions; - ShiftEmpty := ShiftState = []; - NodeSelected := IsAnyHit and (vsSelected in HitInfo.HitNode.States); - FullRowDrag := toFullRowDrag in FOptions.FMiscOptions; - - // Dragging might be started in the inherited handler manually (which is discouraged for stability reasons) - // the test for manual mode is done below (after the focused node is set). - AutoDrag := ((DragMode = dmAutomatic) or Dragging) and (not IsCellHit or FullRowDrag); - - // Query the application to learn if dragging may start now (if set to dmManual). - if Assigned(HitInfo.HitNode) and not AutoDrag and (DragMode = dmManual) then - AutoDrag := DoBeforeDrag(HitInfo.HitNode, Column) and (not IsCellHit or FullRowDrag); - - // handle button clicks - if (hiOnItemButton in HitInfo.HitPositions) and (vsHasChildren in HitInfo.HitNode.States) then - begin - ToggleNode(HitInfo.HitNode); - Exit; - end; - - // check event - if hiOnItemCheckBox in HitInfo.HitPositions then - begin - if (FStates * [tsMouseCheckPending, tsKeyCheckPending] = []) and not (vsDisabled in HitInfo.HitNode.States) then - begin - with HitInfo.HitNode^ do - NewCheckState := DetermineNextCheckState(CheckType, CheckState); - if DoChecking(HitInfo.HitNode, NewCheckState) then - begin - DoStateChange([tsMouseCheckPending]); - FCheckNode := HitInfo.HitNode; - FPendingCheckState := NewCheckState; - FCheckNode.CheckState := PressedState[FCheckNode.CheckState]; - InvalidateNode(HitInfo.HitNode); - end; - end; - Exit; - end; - - // Keep this node's level in case we need it for constraint selection. - if (FRoot.ChildCount > 0) and ShiftEmpty or (FSelectionCount = 0) then - if Assigned(HitInfo.HitNode) then - FLastSelectionLevel := GetNodeLevel(HitInfo.HitNode) - else - FLastSelectionLevel := GetNodeLevel(GetLastVisibleNoInit); - - // pending clearance - if MultiSelect and ShiftEmpty and not (hiOnItemCheckbox in HitInfo.HitPositions) and IsAnyHit and AutoDrag and - NodeSelected then - DoStateChange([tsClearPending]); - - // immediate clearance - // Determine for the right mouse button if there is a popup menu. In this case and if drag'n drop is pending - // the current selection has to stay as it is. - with HitInfo, Message do - CanClear := not AutoDrag and - (not (tsRightButtonDown in FStates) or not HasPopupMenu(HitNode, HitColumn, Point(XPos, YPos))); - if (not (IsAnyHit or FullRowDrag) and MultiSelect and ShiftEmpty) or - (IsAnyHit and (not NodeSelected or (NodeSelected and CanClear)) and (ShiftEmpty or not MultiSelect)) then - begin - Assert(not (tsClearPending in FStates), 'Pending and direct clearance are mutual exclusive!'); - - // If the currently hit node was already selected then we have to reselect it again after clearing the current - // selection, but without a change event if it is the only selected node. - // The same applies if the Alt key is pressed, which allows to start drawing the selection rectangle also - // on node captions and images. Here the previous selection state does not matter, though. - if NodeSelected or (AltPressed and Assigned(HitInfo.HitNode) and (HitInfo.HitColumn = FHeader.MainColumn)) then - begin - NeedChange := FSelectionCount > 1; - InternalClearSelection; - InternalAddToSelection(HitInfo.HitNode, True); - if NeedChange then - begin - Invalidate; - Change(nil); - end; - end - else - ClearSelection; - end; - - // pending node edit - if Focused and - ((hiOnItemLabel in HitInfo.HitPositions) or ((toGridExtensions in FOptions.FMiscOptions) and - (hiOnItem in HitInfo.HitPositions))) and NodeSelected and not NewColumn and ShiftEmpty then - DoStateChange([tsEditPending]); - - // User starts a selection with a selection rectangle. - if not (toDisableDrawSelection in FOptions.FSelectionOptions) and not (IsHit or FullRowDrag) and MultiSelect then - begin - SetCapture(Handle); - DoStateChange([tsDrawSelPending]); - FDrawSelShiftState := ShiftState; - FNewSelRect := Rect(Message.XPos + FEffectiveOffsetX, Message.YPos - FOffsetY, Message.XPos + FEffectiveOffsetX, - Message.YPos - FOffsetY); - FLastSelRect := Rect(0, 0, 0, 0); - if not IsCellHit then - Exit; - end; - - // Keep current mouse position. - FLastClickPos := Point(Message.XPos, Message.YPos); - - // Handle selection and node focus change. - if (IsHit or IsCellHit) and - DoFocusChanging(FFocusedNode, HitInfo.HitNode, FFocusedColumn, Column) then - begin - if NewColumn then - begin - InvalidateColumn(FFocusedColumn); - InvalidateColumn(Column); - FFocusedColumn := Column; - end; - if DragKind = dkDock then - begin - StopTimer(ScrollTimer); - DoStateChange([], [tsScrollPending, tsScrolling]); - end; - // Get the currently focused node to make multiple multi-selection blocks possible. - LastFocused := FFocusedNode; - if NewNode or NewColumn then - DoFocusNode(HitInfo.HitNode, False); - - if MultiSelect and not ShiftEmpty then - HandleClickSelection(LastFocused, HitInfo.HitNode, ShiftState, AutoDrag) - else - begin - if ShiftEmpty then - FRangeAnchor := HitInfo.HitNode; - - // If the hit node is not yet selected then do it now. - if not NodeSelected then - AddToSelection(HitInfo.HitNode); - end; - - if NewNode or NewColumn then - DoFocusChange(FFocusedNode, FFocusedColumn); - end; - - // Drag'n drop initiation - // If we lost focus in the interim the button states would be cleared in WM_KILLFOCUS. - if AutoDrag and IsAnyHit and (FStates * [tsLeftButtonDown, tsRightButtonDown, tsMiddleButtonDown] <> []) then - BeginDrag(False); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.HandleMouseUp(var Message: TLMMouse; const HitInfo: THitInfo); - -// Counterpart to the mouse down handler. - -var - ReselectFocusedNode: Boolean; - -begin - ReleaseCapture; - - if not (tsVCLDragPending in FStates) then - begin - // reset pending or persistent states - if IsMouseSelecting then - begin - DoStateChange([], [tsDrawSelecting, tsDrawSelPending, tsToggleFocusedSelection]); - Invalidate; - end; - - if tsClearPending in FStates then - begin - ReselectFocusedNode := Assigned(FFocusedNode) and (vsSelected in FFocusedNode.States); - ClearSelection; - if ReselectFocusedNode then - AddToSelection(FFocusedNode); - end; - - if (tsToggleFocusedSelection in FStates) and (HitInfo.HitNode = FFocusedNode) then - begin - if vsSelected in HitInfo.HitNode.States then - RemoveFromSelection(HitInfo.HitNode) - else - AddToSelection(HitInfo.HitNode); - InvalidateNode(HitInfo.HitNode); - end; - - DoStateChange([], [tsOLEDragPending, tsOLEDragging, tsClearPending, tsDrawSelPending, tsToggleFocusedSelection, - tsScrollPending, tsScrolling]); - StopTimer(ScrollTimer); - - if tsMouseCheckPending in FStates then - begin - DoStateChange([], [tsMouseCheckPending]); - // Is the mouse still over the same node? - if (HitInfo.HitNode = FCheckNode) and (hiOnItem in HitInfo.HitPositions) then - DoCheckClick(FCheckNode, FPendingCheckState) - else - FCheckNode.CheckState := UnpressedState[FCheckNode.CheckState]; - InvalidateNode(FCheckNode); - FCheckNode := nil; - end; - - if (FHeader.FColumns.FClickIndex > NoColumn) and (FHeader.FColumns.FClickIndex = HitInfo.HitColumn) then - DoColumnClick(HitInfo.HitColumn, KeysToShiftState(Message.Keys)); - - // handle a pending edit event - if tsEditPending in FStates then - begin - // Is the mouse still over the same node? - if (HitInfo.HitNode = FFocusedNode) and (hiOnItem in HitInfo.HitPositions) and - CanEdit(FFocusedNode, HitInfo.HitColumn) then - begin - FEditColumn := FFocusedColumn; - SetTimer(Handle, EditTimer, FEditDelay, nil); - end - else - DoStateChange([], [tsEditPending]); - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.HasImage(Node: PVirtualNode; Kind: TVTImageKind; Column: TColumnIndex): Boolean; - -// Determines whether the given node has got an image of the given kind in the given column. -// Returns True if so, otherwise False. - -var - Ghosted: Boolean; - Index: Integer; - -begin - Index := -1; - Ghosted := False; - DoGetImageIndex(Node, Kind, Column, Ghosted, Index); - Result := Index > -1; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.HasPopupMenu(Node: PVirtualNode; Column: TColumnIndex; Pos: TPoint): Boolean; - -// Determines whether the tree got a popup menu, either in its PopupMenu property, via the OnGetPopupMenu event or -// through inheritannce. The latter case must be checked by the descendant which must override this method. - -begin - Result := Assigned(PopupMenu) or Assigned(DoGetPopupMenu(Node, Column, Pos)); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.InitChildren(Node: PVirtualNode); - -// Initiates the initialization of the child number of the given node. - -var - Count: Cardinal; - -begin - if Assigned(Node) and (Node <> FRoot) and (vsHasChildren in Node.States) then - begin - Count := Node.ChildCount; - DoInitChildren(Node, Count); - if Count = 0 then - begin - // Remove any child node which is already there. - DeleteChildren(Node); - Exclude(Node.States, vsHasChildren); - end - else - SetChildCount(Node, Count); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.InitNode(Node: PVirtualNode); - -// Initiates the initialization of the given node to allow the application to load needed data for it. - -var - InitStates: TVirtualNodeInitStates; - -begin - with Node^ do - begin - Include(States, vsInitialized); - InitStates := []; - if Parent = FRoot then - DoInitNode(nil, Node, InitStates) - else - DoInitNode(Parent, Node, InitStates); - if ivsDisabled in InitStates then - Include(States, vsDisabled); - if ivsHasChildren in InitStates then - Include(States, vsHasChildren); - if ivsSelected in InitStates then - begin - FSingletonNodeArray[0] := Node; - InternalAddToSelection(FSingletonNodeArray, 1, False); - end; - if ivsMultiline in InitStates then - Include(States, vsMultiline); - - // Expanded may already be set (when called from ReinitNode) or be set in DoInitNode, allow both. - if (vsExpanded in Node.States) xor (ivsExpanded in InitStates) then - begin - // Expand node if not yet done (this will automatically initialize child nodes). - if ivsExpanded in InitStates then - ToggleNode(Node) - else - // If the node already was expanded then explicitly trigger child initialization. - if vsHasChildren in Node.States then - InitChildren(Node); - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.InternalAddFromStream(Stream: TStream; Version: Integer; Node: PVirtualNode); - -// Loads all details for Node (including its children) from the given stream. -// Because the new nodes might be selected this method also fixes the selection array. - -var - Stop: PVirtualNode; - Index: Integer; - LastTotalHeight: Cardinal; - WasFullyVisible: Boolean; - -begin - Assert(Node <> FRoot, 'The root node cannot be loaded from stream.'); - - // Keep the current total height value of Node as it has already been applied - // but might change in the load and fixup code. We have to adjust that afterwards. - LastTotalHeight := Node.TotalHeight; - WasFullyVisible := FullyVisible[Node]; - - // Read in the new nodes. - ReadNode(Stream, Version, Node); - - // One time update of node-internal states and the global visibility counter. - // This is located here to ease and speed up the loading process. - FixupTotalCount(Node); - AdjustTotalCount(Node.Parent, Node.TotalCount - 1, True); // -1 because Node itself was already set. - FixupTotalHeight(Node); - AdjustTotalHeight(Node.Parent, Node.TotalHeight - LastTotalHeight, True); - - // New nodes are always visible, so the visible node count has been increased already. - // If Node is now invisible we have to take back this increment and don't need to add any visible child node. - if not FullyVisible[Node] then - begin - if WasFullyVisible then - Dec(FVisibleCount); - end - else - // It can never happen that the node is now fully visible but was not before as this would require - // that the visibility state of one of its parents has changed, which cannot happen during loading. - Inc(FVisibleCount, CountVisibleChildren(Node)); - - // Fix selection array. - ClearTempCache; - if Node = FRoot then - Stop := nil - else - Stop := Node.NextSibling; - - if toMultiSelect in FOptions.FSelectionOptions then - begin - // Add all nodes which were selected before to the current selection (unless they are already there). - while Node <> Stop do - begin - if (vsSelected in Node.States) and not FindNodeInSelection(Node, Index, 0, High(FSelection)) then - InternalCacheNode(Node); - Node := GetNextNoInit(Node); - end; - if FTempNodeCount > 0 then - AddToSelection(FTempNodeCache, FTempNodeCount, True); - ClearTempCache; - end - else // No further selected nodes allowed so delete the corresponding flag in all new nodes. - while Node <> Stop do - begin - Exclude(Node.States, vsSelected); - Node := GetNextNoInit(Node); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.InternalAddToSelection(Node: PVirtualNode; ForceInsert: Boolean): Boolean; - -begin - Assert(Assigned(Node), 'Node must not be nil!'); - FSingletonNodeArray[0] := Node; - Result := InternalAddToSelection(FSingletonNodeArray, 1, ForceInsert); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.InternalAddToSelection(const NewItems: TNodeArray; NewLength: Integer; - ForceInsert: Boolean): Boolean; - -// Internal version of method AddToSelection which does not trigger OnChange events - -var - I, J: Integer; - CurrentEnd: Integer; - Constrained, - SiblingConstrained: Boolean; - -begin - // The idea behind this code is to use a kind of reverse merge sort. QuickSort is quite fast - // and would do the job here too but has a serious problem with already sorted lists like FSelection. - - // 1) Remove already selected items, mark all other as being selected. - if ForceInsert then - begin - for I := 0 to NewLength - 1 do - Include(NewItems[I].States, vsSelected); - end - else - begin - Constrained := toLevelSelectConstraint in FOptions.FSelectionOptions; - if Constrained and (FLastSelectionLevel = -1) then - FLastSelectionLevel := GetNodeLevel(NewItems[0]); - SiblingConstrained := toSiblingSelectConstraint in FOptions.FSelectionOptions; - if SiblingConstrained and (FRangeAnchor = nil) then - FRangeAnchor := NewItems[0]; - - for I := 0 to NewLength - 1 do - if ([vsSelected, vsDisabled] * NewItems[I].States <> []) or - (Constrained and (Cardinal(FLastSelectionLevel) <> GetNodeLevel(NewItems[I]))) or - (SiblingConstrained and (FRangeAnchor.Parent <> NewItems[I].Parent)) then - Inc(Cardinal(NewItems[I])) - else - Include(NewItems[I].States, vsSelected); - end; - - I := PackArray(NewItems, NewLength); - if I > -1 then - NewLength := I; - - Result := NewLength > 0; - if Result then - begin - // 2) Sort the new item list so we can easily traverse it. - if NewLength > 1 then - QuickSort(NewItems, 0, NewLength - 1); - // 3) Make room in FSelection for the new items. - if FSelectionCount + NewLength >= Length(FSelection) then - SetLength(FSelection, FSelectionCount + NewLength); - - // 4) Merge in new items - J := NewLength - 1; - CurrentEnd := FSelectionCount - 1; - - while J >= 0 do - begin - // First insert all new entries which are greater than the greatest entry in the old list. - // If the current end marker is < 0 then there's nothing more to move in the selection - // array and only the remaining new items must be inserted. - if CurrentEnd >= 0 then - begin - while (J >= 0) and (Cardinal(NewItems[J]) > Cardinal(FSelection[CurrentEnd])) do - begin - FSelection[CurrentEnd + J + 1] := NewItems[J]; - Dec(J); - end; - // early out if nothing more needs to be copied - if J < 0 then - Break; - end - else - begin - // insert remaining new entries at position 0 - Move(NewItems[0], FSelection[0], (J + 1) * SizeOf(Pointer)); - // nothing more to do so exit main loop - Break; - end; - - // find the last entry in the remaining selection list which is smaller then the largest - // entry in the remaining new items list - FindNodeInSelection(NewItems[J], I, 0, CurrentEnd); - Dec(I); - // move all entries which are greater than the greatest entry in the new items list up - // so the remaining gap travels down to where new items must be inserted - Move(FSelection[I + 1], FSelection[I + J + 2], (CurrentEnd - I) * SizeOf(Pointer)); - CurrentEnd := I; - end; - - Inc(FSelectionCount, NewLength); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.InternalCacheNode(Node: PVirtualNode); - -// Adds the given node to the temporary node cache (used when collecting possibly large amounts of nodes). - -var - Len: Cardinal; - -begin - Len := Length(FTempNodeCache); - if FTempNodeCount = Len then - begin - if Len < 100 then - Len := 100 - else - Len := Len + Len div 10; - SetLength(FTempNodeCache, Len); - end; - FTempNodeCache[FTempNodeCount] := Node; - Inc(FTempNodeCount); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.InternalClearSelection; - -var - Count: Integer; - -begin - // It is possible that there are invalid node references in the selection array - // if the tree update is locked and changes in the structure were made. - // Handle this potentially dangerous situation by packing the selection array explicitely. - if FUpdateCount > 0 then - begin - Count := PackArray(FSelection, FSelectionCount); - if Count > -1 then - begin - FSelectionCount := Count; - SetLength(FSelection, FSelectionCount); - end; - end; - - while FSelectionCount > 0 do - begin - Dec(FSelectionCount); - Exclude(FSelection[FSelectionCount].States, vsSelected); - end; - ResetRangeAnchor; - FSelection := nil; - DoStateChange([], [tsClearPending]); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.InternalConnectNode(Node, Destination: PVirtualNode; Target: TBaseVirtualTree; - Mode: TVTNodeAttachMode); - -// Connects Node with Destination depending on Mode. -// No error checking takes place. Node as well as Destination must be valid. Node must never be a root node and -// Destination must not be a root node if Mode is amInsertBefore or amInsertAfter. - -var - Run: PVirtualNode; - -begin - // Keep in mind that the destination node might belong to another tree. - with Target do - begin - case Mode of - amInsertBefore: - begin - Node.PrevSibling := Destination.PrevSibling; - Destination.PrevSibling := Node; - Node.NextSibling := Destination; - Node.Parent := Destination.Parent; - Node.Index := Destination.Index; - if Node.PrevSibling = nil then - Node.Parent.FirstChild := Node - else - Node.PrevSibling.NextSibling := Node; - - // reindex all following nodes - Run := Destination; - while Assigned(Run) do - begin - Inc(Run.Index); - Run := Run.NextSibling; - end; - - Inc(Destination.Parent.ChildCount); - Include(Destination.Parent.States, vsHasChildren); - AdjustTotalCount(Destination.Parent, Node.TotalCount, True); - - // Add the new node's height only if its parent is expanded. - if (vsExpanded in Destination.Parent.States) and (vsVisible in Node.States) then - AdjustTotalHeight(Destination.Parent, Node.TotalHeight, True); - if FullyVisible[Node] then - Inc(FVisibleCount, CountVisibleChildren(Node) + 1); - end; - amInsertAfter: - begin - Node.NextSibling := Destination.NextSibling; - Destination.NextSibling := Node; - Node.PrevSibling := Destination; - Node.Parent := Destination.Parent; - if Node.NextSibling = nil then - Node.Parent.LastChild := Node - else - Node.NextSibling.PrevSibling := Node; - Node.Index := Destination.Index; - - // reindex all following nodes - Run := Node; - while Assigned(Run) do - begin - Inc(Run.Index); - Run := Run.NextSibling; - end; - - Inc(Destination.Parent.ChildCount); - Include(Destination.Parent.States, vsHasChildren); - AdjustTotalCount(Destination.Parent, Node.TotalCount, True); - - // Add the new node's height only if its parent is expanded. - if vsExpanded in Destination.Parent.States then - AdjustTotalHeight(Destination.Parent, Node.TotalHeight, True); - if FullyVisible[Node] then - Inc(FVisibleCount, CountVisibleChildren(Node) + 1); - end; - amAddChildFirst: - begin - if Assigned(Destination.FirstChild) then - begin - // If there's a first child then there must also be a last child. - Destination.FirstChild.PrevSibling := Node; - Node.NextSibling := Destination.FirstChild; - Destination.FirstChild := Node; - end - else - begin - // First child node at this location. - Destination.FirstChild := Node; - Destination.LastChild := Node; - Node.NextSibling := nil; - end; - Node.PrevSibling := nil; - Node.Parent := Destination; - Node.Index := 0; - // reindex all following nodes - Run := Node.NextSibling; - while Assigned(Run) do - begin - Inc(Run.Index); - Run := Run.NextSibling; - end; - - Inc(Destination.ChildCount); - Include(Destination.States, vsHasChildren); - AdjustTotalCount(Destination, Node.TotalCount, True); - // Add the new node's height only if its parent is expanded. - if (vsExpanded in Destination.States) and (vsVisible in Node.States) then - AdjustTotalHeight(Destination, Node.TotalHeight, True); - if FullyVisible[Node] then - Inc(FVisibleCount, CountVisibleChildren(Node) + 1); - end; - amAddChildLast: - begin - if Assigned(Destination.LastChild) then - begin - // If there's a last child then there must also be a first child. - Destination.LastChild.NextSibling := Node; - Node.PrevSibling := Destination.LastChild; - Destination.LastChild := Node; - end - else - begin - // first child node at this location - Destination.FirstChild := Node; - Destination.LastChild := Node; - Node.PrevSibling := nil; - end; - Node.NextSibling := nil; - Node.Parent := Destination; - if Assigned(Node.PrevSibling) then - Node.Index := Node.PrevSibling.Index + 1 - else - Node.Index := 0; - Inc(Destination.ChildCount); - Include(Destination.States, vsHasChildren); - AdjustTotalCount(Destination, Node.TotalCount, True); - // Add the new node's height only if its parent is expanded. - if (vsExpanded in Destination.States) and (vsVisible in Node.States) then - AdjustTotalHeight(Destination, Node.TotalHeight, True); - if FullyVisible[Node] then - Inc(FVisibleCount, CountVisibleChildren(Node) + 1); - end; - else - // amNoWhere: do nothing - end; - - // Remove temporary states. - Node.States := Node.States - [vsChecking, vsCutOrCopy, vsDeleting, vsClearing]; - - // Update the hidden children flag of the parent. - if (Mode <> amNoWhere) and (Node.Parent <> FRoot) then - begin - // If we have added a visible node then simply remove the all-children-hidden flag. - if vsVisible in Node.States then - Exclude(Node.Parent.States, vsAllChildrenHidden) - else - // If we have added an invisible node and this is the only child node then - // make sure the all-children-hidden flag is in a determined state. - // If there were child nodes before then no action is needed. - if Node.Parent.ChildCount = 1 then - Include(Node.Parent.States, vsAllChildrenHidden); - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.InternalData(Node: PVirtualNode): Pointer; - -begin - Result := nil; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.InternalDisconnectNode(Node: PVirtualNode; KeepFocus: Boolean; Reindex: Boolean = True); - -// Disconnects the given node from its parent and siblings. The node's pointer are not reset so they can still be used -// after return from this method (probably a very short time only!). -// If KeepFocus is True then the focused node is not reset. This is useful if the given node is reconnected to the tree -// immediately after return of this method and should stay being the focused node if it was it before. -// Note: Node must not be nil or the root node. - -var - Parent, - Run: PVirtualNode; - Index: Integer; - AdjustHeight: Boolean; - -begin - Assert(Assigned(Node) and (Node <> FRoot), 'Node must neither be nil nor the root node.'); - - if (Node = FFocusedNode) and not KeepFocus then - begin - DoFocusNode(nil, False); - DoFocusChange(FFocusedNode, FFocusedColumn); - end; - - if Node = FRangeAnchor then - ResetRangeAnchor; - - // Update the hidden children flag of the parent. - if (Node.Parent <> FRoot) and not (vsClearing in Node.Parent.States) then - if FUpdateCount = 0 then - DetermineHiddenChildrenFlag(Node.Parent) - else - Include(FStates, tsUpdateHiddenChildrenNeeded); - - if not (vsDeleting in Node.States) then - begin - // Some states are only temporary so take them out. - Node.States := Node.States - [vsChecking]; - Parent := Node.Parent; - Dec(Parent.ChildCount); - AdjustHeight := (vsExpanded in Parent.States) and (vsVisible in Node.States); - if Parent.ChildCount = 0 then - begin - Parent.States := Parent.States - [vsAllChildrenHidden, vsHasChildren]; - if (Parent <> FRoot) and (vsExpanded in Parent.States) then - begin - AdjustHeight := vsVisible in Node.States; - Exclude(Parent.States, vsExpanded); - end; - end; - AdjustTotalCount(Parent, -Integer(Node.TotalCount), True); - if AdjustHeight then - AdjustTotalHeight(Parent, -Integer(Node.TotalHeight), True); - if FullyVisible[Node] then - Dec(FVisibleCount, CountVisibleChildren(Node) + 1); - if Assigned(Node.PrevSibling) then - Node.PrevSibling.NextSibling := Node.NextSibling - else - Parent.FirstChild := Node.NextSibling; - - if Assigned(Node.NextSibling) then - begin - Node.NextSibling.PrevSibling := Node.PrevSibling; - // Reindex all following nodes. - if Reindex then - begin - Run := Node.NextSibling; - Index := Node.Index; - while Assigned(Run) do - begin - Run.Index := Index; - Inc(Index); - Run := Run.NextSibling; - end; - end; - end - else - Parent.LastChild := Node.PrevSibling; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.InternalRemoveFromSelection(Node: PVirtualNode); - -// Special version to mark a node to be no longer in the current selection. PackArray must -// be used to remove finally those entries. - -var - Index: Integer; - -begin - // Because pointers are always DWORD aligned we can simply increment all those - // which we want to have removed (see also PackArray) and still have the - // order in the list preserved. - if FindNodeInSelection(Node, Index, -1, -1) then - begin - Exclude(Node.States, vsSelected); - Inc(Cardinal(FSelection[Index])); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.InvalidateCache; - -// Marks the cache as invalid. - -begin - DoStateChange([tsValidationNeeded], [tsUseCache]); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.MarkCutCopyNodes; - -// Sets the vsCutOrCopy style in every currently selected but not disabled node to indicate it is -// now part of a clipboard operation. - -var - Nodes: TNodeArray; - I: Integer; - -begin - Nodes := nil; - if FSelectionCount > 0 then - begin - // need the current selection sorted to exclude selected nodes which are children, grandchildren etc. of - // already selected nodes - Nodes := GetSortedSelection(False); - for I := 0 to High(Nodes) do - with Nodes[I]^ do - if not (vsDisabled in States) then - Include(States, vsCutOrCopy); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.Loaded; - -var - LastRootCount: Cardinal; - IsReadOnly: Boolean; - -begin - inherited; - - // If a root node count has been set during load of the tree then update its child structure now - // as this hasn't been done yet in this case. - if (tsNeedRootCountUpdate in FStates) and (FRoot.ChildCount > 0) then - begin - DoStateChange([], [tsNeedRootCountUpdate]); - IsReadOnly := toReadOnly in FOptions.FMiscOptions; - Exclude(FOptions.FMiscOptions, toReadOnly); - LastRootCount := FRoot.ChildCount; - FRoot.ChildCount := 0; - BeginUpdate; - SetChildCount(FRoot, LastRootCount); - EndUpdate; - if IsReadOnly then - Include(FOptions.FMiscOptions, toReadOnly); - end; - - // Prevent the object inspector at design time from marking the header as being modified - // when auto resize is enabled. - Updating; - try - FHeader.UpdateMainColumn; - FHeader.FColumns.FixPositions; - if toAutoBidiColumnOrdering in FOptions.FAutoOptions then - FHeader.FColumns.ReorderColumns(UseRightToLeftAlignment); - FHeader.RecalculateHeader; - if hoAutoResize in FHeader.FOptions then - FHeader.FColumns.AdjustAutoSize(InvalidColumn, True); - finally - Updated; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.MainColumnChanged; - -begin - DoCancelEdit; - {$ifdef EnableAccessible} - NotifyWinEvent(EVENT_OBJECT_NAMECHANGE, Handle, OBJID_CLIENT, CHILDID_SELF); - {$endif} -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.MouseMove(Shift: TShiftState; X, Y: Integer); - -var - R: TRect; - -begin - // Remove current selection in case the user clicked somewhere in the window (but not a node) - // and moved the mouse. - if tsDrawSelPending in FStates then - begin - if CalculateSelectionRect(X, Y) then - begin - InvalidateRect(Handle, @FNewSelRect, False); - UpdateWindow(Handle); - if (Abs(FNewSelRect.Right - FNewSelRect.Left) > Mouse.DragThreshold) or - (Abs(FNewSelRect.Bottom - FNewSelRect.Top) > Mouse.DragThreshold) then - begin - if tsClearPending in FStates then - begin - DoStateChange([], [tsClearPending]); - ClearSelection; - end; - DoStateChange([tsDrawSelecting], [tsDrawSelPending]); - // reset to main column for multiselection - FocusedColumn := FHeader.MainColumn; - - // The current rectangle may already include some node captions. Handle this. - if HandleDrawSelection(X, Y) then - InvalidateRect(Handle, nil, False); - end; - end; - end - else - begin - // If both wheel panning and auto scrolling are pending then the user moved the mouse while holding down the - // middle mouse button. This means panning is being used, hence remove the wheel scroll flag. - if [tsWheelPanning, tsWheelScrolling] * FStates = [tsWheelPanning, tsWheelScrolling] then - begin - if ((Abs(FLastClickPos.X - X) >= Mouse.DragThreshold) or (Abs(FLastClickPos.Y - Y) >= Mouse.DragThreshold)) then - DoStateChange([], [tsWheelScrolling]); - end; - - // Really start dragging if the mouse has been moved more than the threshold. - if (tsOLEDragPending in FStates) and ((Abs(FLastClickPos.X - X) >= FDragThreshold) or - (Abs(FLastClickPos.Y - Y) >= FDragThreshold)) then - DoDragging(FLastClickPos) - else - begin - if CanAutoScroll then - DoAutoScroll(X, Y); - if [tsWheelPanning, tsWheelScrolling] * FStates <> [] then - AdjustPanningCursor(X, Y); - if not IsMouseSelecting then - begin - HandleHotTrack(X, Y); - inherited MouseMove(Shift, X, Y); - end - else - begin - // Handle draw selection if required, but don't do the work twice if the - // auto scrolling code already cares about the selection. - if not (tsScrolling in FStates) and CalculateSelectionRect(X, Y) then - begin - // If something in the selection changed then invalidate the entire - // tree instead trying to figure out the display rects of all changed nodes. - if HandleDrawSelection(X, Y) then - InvalidateRect(Handle, nil, False) - else - begin - UnionRect(R, OrderRect(FNewSelRect), OrderRect(FLastSelRect)); - OffsetRect(R, -FEffectiveOffsetX, FOffsetY); - InvalidateRect(Handle, @R, False); - end; - UpdateWindow(Handle); - end; - end; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.Notification(AComponent: TComponent; Operation: TOperation); - -begin - if (AComponent <> Self) and (Operation = opRemove) then - begin - // Check for components linked to the tree. - if AComponent = FImages then - begin - Images := nil; - if not (csDestroying in ComponentState) then - Invalidate; - end - else - if AComponent = FStateImages then - begin - StateImages := nil; - if not (csDestroying in ComponentState) then - Invalidate; - end - else - if AComponent = FCustomCheckImages then - begin - CustomCheckImages := nil; - FCheckImageKind := ckLightCheck; - if not (csDestroying in ComponentState) then - Invalidate; - end - else - if AComponent = PopupMenu then - PopupMenu := nil - else - // Check for components linked to the header. - if Assigned(FHeader) then - begin - if AComponent = FHeader.FImages then - FHeader.Images := nil - else - if AComponent = FHeader.PopupMenu then - FHeader.PopupMenu := nil; - end; - end; - inherited; -end; - -//---------------------------------------------------------------------------------------------------------------------- -{$ifdef EnableNCFunctions} -procedure TBaseVirtualTree.OriginalWMNCPaint(DC: HDC); - -// Unfortunately, the painting for the non-client area in TControl is not always correct and does also not consider -// existing clipping regions, so it has been modified here to take this into account. - -const - InnerStyles: array[TBevelCut] of Integer = (0, BDR_SUNKENINNER, BDR_RAISEDINNER, 0); - OuterStyles: array[TBevelCut] of Integer = (0, BDR_SUNKENOUTER, BDR_RAISEDOUTER, 0); - EdgeStyles: array[TBevelKind] of Integer = (0, 0, BF_SOFT, BF_FLAT); - Ctl3DStyles: array[Boolean] of Integer = (BF_MONO, 0); - -var - RC, RW: TRect; - EdgeSize: Integer; - Size: TSize; - -begin - if (BevelKind <> bkNone) or (BorderWidth > 0) then - begin - RC := Rect(0, 0, Width, Height); - Size := GetBorderDimensions; - InflateRect(RC, Size.cx, Size.cy); - - RW := RC; - - if BevelKind <> bkNone then - begin - DrawEdge(DC, RC, InnerStyles[BevelInner] or OuterStyles[BevelOuter], Byte(BevelEdges) or EdgeStyles[BevelKind] or - Ctl3DStyles[Ctl3D]); - - EdgeSize := 0; - if BevelInner <> bvNone then - Inc(EdgeSize, BevelWidth); - if BevelOuter <> bvNone then - Inc(EdgeSize, BevelWidth); - with 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. - IntersectClipRect(DC, RC.Left, RC.Top, RC.Right, RC.Bottom); - - // Determine inner rectangle to exclude (RC corresponds then to the client area). - InflateRect(RC, -BorderWidth, -BorderWidth); - - // Remove the inner rectangle. - ExcludeClipRect(DC, RC.Left, RC.Top, RC.Right, RC.Bottom); - - // Erase parts not drawn. - Brush.Color := FColors.BorderColor; - Windows.FillRect(DC, RW, Brush.Handle); - end; -end; -{$endif} -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.Paint; - -// Window paint routine. Used when the tree window needs to be updated. - -var - Window: TRect; - Target: TPoint; - Temp: Integer; - Options: TVTInternalPaintOptions; - RTLOffset: Integer; - -begin - Logger.EnterMethod(lcPaint,'Paint'); - Options := [poBackground, poColumnColor, poDrawFocusRect, poDrawDropMark, poDrawSelection, poGridLines]; - if UseRightToLeftAlignment and FHeader.UseColumns then - RTLOffset := ComputeRTLOffset(True) - else - RTLOffset := 0; - - // The update rect has already been filled in WMPaint, as it is the window's update rect, which gets - // reset when BeginPaint is called (in the ancestor). - // The difference to the DC's clipbox is that it is also valid with internal paint operations used - // e.g. by the Explorer while dragging, but show window content while dragging is disabled. - if not IsRectEmpty(FUpdateRect) then - begin - Temp := Header.Columns.GetVisibleFixedWidth; - if Temp = 0 then - begin - Window := FUpdateRect; - Target := Window.TopLeft; - - // The clipping rectangle is given in client coordinates of the window. We have to convert it into - // a sliding window of the tree image. - Logger.Send(lcPaintDetails,'FEffectiveOffsetX: %d, RTLOffset: %d, OffsetY: %d',[FEffectiveOffsetX,RTLOffset,FOffsetY]); - //Logger.Send(lcPaint,'Window Before Offset',Window); - Windows.OffsetRect(Window, FEffectiveOffsetX - RTLOffset, -FOffsetY); - //Logger.Send(lcPaint,'Window After Offset',Window); - PaintTree(Canvas, Window, Target, Options); - end - else - begin - Logger.Send(lcPaint,'FUpdateRect IS Empty'); - // First part, fixed columns - Window := ClientRect; - Window.Right := Temp; - Target := Window.TopLeft; - - OffsetRect(Window, -RTLOffset, -FOffsetY); - PaintTree(Canvas, Window, Target, Options); - - // Second part, other columns - Window := GetClientRect; - - if Temp > Window.Right then - begin - Logger.ExitMethod(lcPaint,'Paint'); - Exit; - end; - - Window.Left := Temp; - Target := Window.TopLeft; - - OffsetRect(Window, FEffectiveOffsetX - RTLOffset, -FOffsetY); - PaintTree(Canvas, Window, Target, Options); - end; - end; - Logger.ExitMethod(lcPaint,'Paint'); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.PaintCheckImage(const PaintInfo: TVTPaintInfo); - -var - ForegroundColor: COLORREF; - {$ifdef ThemeSupport} - R: TRect; - Details: TThemedElementDetails; - {$endif ThemeSupport} - -begin - Logger.EnterMethod(lcCheck,'PaintCheckImage'); - with PaintInfo, ImageInfo[iiCheck] do - begin - {$ifdef ThemeSupport} - if (tsUseThemes in FStates) and (FCheckImageKind <> ckCustom) then - begin - R := Rect(XPos - 1, YPos, XPos + 16, YPos + 16); - Details.Element := teButton; - case Index of - 0..8: // radio buttons - begin - Details.Part := BP_RADIOBUTTON; - Details.State := Index; - end; - 9..20: // check boxes - begin - Details.Part := BP_CHECKBOX; - Details.State := Index - 8; - end; - 21..24: // buttons - begin - Details.Part := BP_PUSHBUTTON; - Details.State := Index - 20; - end; - else - Details.Part := 0; - Details.State := 0; - end; - ThemeServices.DrawElement(Canvas.Handle, Details, R); - if Index in [21..24] then - UtilityImages.Draw(Canvas, XPos - 1, YPos, 4); - end - else - {$endif ThemeSupport} - with FCheckImages do - begin - if (vsSelected in Node.States) and not Ghosted then - begin - if Focused or (toPopupMode in FOptions.FPaintOptions) then - ForegroundColor := ColorToRGB(FColors.FocusedSelectionColor) - else - ForegroundColor := ColorToRGB(FColors.UnfocusedSelectionColor); - end - else - ForegroundColor := GetRGBColor(BlendColor); - - Draw(Canvas,XPos,YPos,Index); - //ImageList_DrawEx(Handle, Index, Canvas.Handle, XPos, YPos, 0, 0, GetRGBColor(BkColor), ForegroundColor, - // ILD_TRANSPARENT); - end; - end; - Logger.ExitMethod(lcCheck,'PaintCheckImage'); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -type - TCustomImageListCast = class(TCustomImageList); - -procedure TBaseVirtualTree.PaintImage(var PaintInfo: TVTPaintInfo; ImageInfoIndex: TVTImageInfoIndex; DoOverlay: Boolean); - -const - Style: array[TImageType] of Cardinal = (0, ILD_MASK); - -var - ExtraStyle: Cardinal; - CutNode: Boolean; - PaintFocused: Boolean; - DrawEnabled: Boolean; - -begin - with PaintInfo do - begin - CutNode := (vsCutOrCopy in Node.States) and (tsCutPending in FStates); - PaintFocused := Focused or (toGhostedIfUnfocused in FOptions.FPaintOptions); - - // Since the overlay image must be specified together with the image to draw - // it is meaningfull to retrieve it in advance. - if DoOverlay then - GetImageIndex(PaintInfo, ikOverlay, iiOverlay, Images) - else - PaintInfo.ImageInfo[iiOverlay].Index := -1; - - DrawEnabled := not (vsDisabled in Node.States) and Enabled; - with ImageInfo[ImageInfoIndex] do - begin - if (vsSelected in Node.States) and not (Ghosted or CutNode) then - begin - if PaintFocused or (toPopupMode in FOptions.FPaintOptions) then - Images.BlendColor := FColors.FocusedSelectionColor - else - Images.BlendColor := FColors.UnfocusedSelectionColor; - end - else - Images.BlendColor := Color; - - // If the user returned an index >= 15 then we cannot use the built-in overlay image drawing. - // Instead we do it manually. - if (ImageInfo[iiOverlay].Index > -1) and (ImageInfo[iiOverlay].Index < 15) then - ExtraStyle := ILD_TRANSPARENT or ILD_OVERLAYMASK and IndexToOverlayMask(ImageInfo[iiOverlay].Index + 1) - else - ExtraStyle := ILD_TRANSPARENT; - - // Blend image if enabled and the tree has the focus (or ghosted images must be drawn also if unfocused) ... - if (toUseBlendedImages in FOptions.FPaintOptions) and PaintFocused - // ... and the image is ghosted... - and (Ghosted or - // ... or it is not the check image and the node is selected (but selection is not for the entire row)... - ((vsSelected in Node.States) and - not (toFullRowSelect in FOptions.FSelectionOptions) and - not (toGridExtensions in FOptions.FMiscOptions)) or - // ... or the node must be shown in cut mode. - CutNode) then - ExtraStyle := ExtraStyle or ILD_BLEND50; - - if (vsSelected in Node.States) and not Ghosted then - Images.BlendColor := clDefault; - //todo_lcl - //TCustomImageListCast(Images).DoDraw(Index, Canvas, XPos, YPos, Style[Images.ImageType] or ExtraStyle, DrawEnabled); - Images.Draw(Canvas, XPos, YPos, Index); - - // Now, draw the overlay. This circumnavigates limitations in the overlay mask index (it has to be 4 bits in size, - // anything larger will be truncated by the ILD_OVERLAYMASK). - // However this will only be done if the overlay image index is > 15, to avoid breaking code that relies - // on overlay image indices (e.g. when using system image lists). - if PaintInfo.ImageInfo[iiOverlay].Index >= 15 then - // Note: XPos and YPos are those of the normal images. - //todo_lcl - //TCustomImageListCast(ImageInfo[iiOverlay].Images).DoDraw(ImageInfo[iiOverlay].Index, Canvas, XPos, YPos, - // Style[ImageInfo[iiOverlay].Images.ImageType] or ExtraStyle, DrawEnabled); - ImageInfo[iiOverlay].Images.Draw(Canvas, XPos, YPos,ImageInfo[iiOverlay].Index); - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.PaintNodeButton(Canvas: TCanvas; Node: PVirtualNode; const R: TRect; ButtonX, - ButtonY: Integer; BidiMode: TBiDiMode); - -var - Bitmap: TBitmap; - XPos: Integer; - -begin - Logger.EnterMethod(lcPaintDetails,'PaintNodeButton'); - if vsExpanded in Node.States then - Bitmap := FMinusBM - else - Bitmap := FPlusBM; - - // Draw the node's plus/minus button according to the directionality. - if BidiMode = bdLeftToRight then - XPos := R.Left + ButtonX - else - XPos := R.Right - ButtonX - Bitmap.Width; - Logger.SendBitmap(lcPaintBitmap,'NodeButton',Bitmap); - // Need to draw this masked. - Canvas.Draw(XPos, R.Top + ButtonY, Bitmap); - Logger.ExitMethod(lcPaintDetails,'PaintNodeButton'); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.PaintTreeLines(const PaintInfo: TVTPaintInfo; VAlignment, IndentSize: Integer; - LineImage: TLineImage); - -var - I: Integer; - XPos, - Offset: Integer; - NewStyles: TLineImage; - -begin - Logger.EnterMethod(lcPaintDetails,'PaintTreeLines'); - NewStyles := nil; - - with PaintInfo do - begin - if BidiMode = bdLeftToRight then - begin - XPos := CellRect.Left; - Offset := FIndent; - end - else - begin - Offset := -Integer(FIndent); - XPos := CellRect.Right + Offset; - end; - - case FLineMode of - lmBands: - if poGridLines in PaintInfo.PaintOptions then - begin - // Convert the line images in correct bands. - SetLength(NewStyles, Length(LineImage)); - for I := IndentSize - 1 downto 0 do - begin - Logger.Send(lcPaintDetails,'FLineMode = lmBands'); - if (vsExpanded in Node.States) and not (vsAllChildrenHidden in Node.States) then - NewStyles[I] := ltLeft - else - case LineImage[I] of - ltRight, - ltBottomRight, - ltTopDownRight, - ltTopRight: - NewStyles[I] := ltLeftBottom; - ltNone: - // Have to take over the image to the right of this one. A no line entry can never appear as - // last entry so I don't need an end check here. - if LineImage[I + 1] in [ltNone, ltTopRight] then - NewStyles[I] := NewStyles[I + 1] - else - NewStyles[I] := ltLeft; - ltTopDown: - // Have to check the image to the right of this one. A top down line can never appear as - // last entry so I don't need an end check here. - if LineImage[I + 1] in [ltNone, ltTopRight] then - NewStyles[I] := NewStyles[I + 1] - else - NewStyles[I] := ltLeft; - end; - end; - - PaintInfo.Canvas.Font.Color := FColors.GridLineColor; - for I := 0 to IndentSize - 1 do - begin - DrawLineImage(PaintInfo, XPos, CellRect.Top, NodeHeight[Node] - 1, VAlignment, NewStyles[I], - BidiMode <> bdLeftToRight); - Inc(XPos, Offset); - end; - end; - else // lmNormal - Logger.Send(lcPaintDetails,'FLineMode = lmNormal'); - Logger.Send(lcPaintDetails,'Brush.Color',PaintInfo.Canvas.Brush.Color); - PaintInfo.Canvas.Font.Color := FColors.TreeLineColor; - Logger.Send(lcPaintDetails,'Brush.Color',PaintInfo.Canvas.Font.Color); - for I := 0 to IndentSize - 1 do - begin - DrawLineImage(PaintInfo, XPos, CellRect.Top, NodeHeight[Node], VAlignment, LineImage[I], - BidiMode <> bdLeftToRight); - Inc(XPos, Offset); - end; - end; - end; - Logger.ExitMethod(lcPaintDetails,'PaintTreeLines'); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.PaintSelectionRectangle(Target: TCanvas; WindowOrgX: Integer; const SelectionRect: TRect; - TargetRect: TRect); - -// Helper routine to draw a selection rectangle in the mode determined by DrawSelectionMode. - -var - BlendRect: TRect; - TextColorBackup, - BackColorBackup: COLORREF; // used to restore forground and background colors when drawing a selection rectangle - -begin - if ((FDrawSelectionMode = smDottedRectangle) and not (tsUseThemes in FStates)) or - not MMXAvailable then - begin - // Classical selection rectangle using dotted borderlines. - TextColorBackup := GetTextColor(Target.Handle); - SetTextColor(Target.Handle, $FFFFFF); - BackColorBackup := GetBkColor(Target.Handle); - SetBkColor(Target.Handle, 0); - Target.DrawFocusRect(SelectionRect); - SetTextColor(Target.Handle, TextColorBackup); - SetBkColor(Target.Handle, BackColorBackup); - end - else - begin - // Modern alpha blended style. - OffsetRect(TargetRect, WindowOrgX, 0); - if IntersectRect(BlendRect, OrderRect(SelectionRect), TargetRect) then - begin - OffsetRect(BlendRect, -WindowOrgX, 0); - AlphaBlend(0, Target.Handle, BlendRect, Point(0, 0), bmConstantAlphaAndColor, FSelectionBlendFactor, - ColorToRGB(FColors.SelectionRectangleBlendColor)); - - Target.Brush.Color := FColors.SelectionRectangleBorderColor; - Target.FrameRect(SelectionRect); - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.PanningWindowProc(var Message: TLMessage); - -var - PS: TPaintStruct; - Canvas: TCanvas; - -begin - if Message.Msg = LM_PAINT then - begin - BeginPaint(FPanningWindow, PS); - Canvas := TCanvas.Create; - Canvas.Handle := PS.hdc; - try - Canvas.Draw(0, 0, FPanningImage); - finally - Canvas.Handle := 0; - Canvas.Free; - EndPaint(FPanningWindow, PS); - end; - Message.Result := 0; - end - else - with Message do - Result := DefWindowProc(FPanningWindow, Msg, wParam, lParam); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.ReadChunk(Stream: TStream; Version: Integer; Node: PVirtualNode; ChunkType, - ChunkSize: Integer): Boolean; - -// Called while loading a tree structure, Node is already valid (allocated) at this point. -// The function handles the base and user chunks, any other chunk is marked as being unknown (result becomes False) -// and skipped. descendants may handle them by overriding this method. -// Returns True if the chunk could be handled, otherwise False. - -var - ChunkBody: TBaseChunkBody; - Run: PVirtualNode; - LastPosition: Integer; - -begin - case ChunkType of - BaseChunk: - begin - // Load base chunk's body (chunk header has already been consumed). - if Version > 1 then - Stream.Read(ChunkBody, SizeOf(ChunkBody)) - else - begin - with ChunkBody do - begin - // In version prior to 2 there was a smaller chunk body. Hence we have to read it entry by entry now. - Stream.Read(ChildCount, SizeOf(ChildCount)); - Stream.Read(NodeHeight, SizeOf(NodeHeight)); - // TVirtualNodeStates was a byte sized type in version 1. - States := []; - Stream.Read(States, SizeOf(Byte)); - // vsVisible is now in the place where vsSelected was before, but every node was visible in the old version - // so we need to fix this too. - if vsVisible in States then - Include(States, vsSelected) - else - Include(States, vsVisible); - Stream.Read(Align, SizeOf(Align)); - Stream.Read(CheckState, SizeOf(CheckState)); - Stream.Read(CheckType, SizeOf(CheckType)); - end; - end; - - with Node^ do - begin - // Set states first, in case the node is invisble. - States := ChunkBody.States; - NodeHeight := ChunkBody.NodeHeight; - TotalHeight := NodeHeight; - Align := ChunkBody.Align; - CheckState := ChunkBody.CheckState; - CheckType := ChunkBody.CheckType; - ChildCount := ChunkBody.ChildCount; - - // Create and read child nodes. - while ChunkBody.ChildCount > 0 do - begin - Run := MakeNewNode; - - Run.PrevSibling := Node.LastChild; - if Assigned(Run.PrevSibling) then - Run.Index := Run.PrevSibling.Index + 1; - if Assigned(Node.LastChild) then - Node.LastChild.NextSibling := Run - else - Node.FirstChild := Run; - Node.LastChild := Run; - Run.Parent := Node; - - ReadNode(Stream, Version, Run); - Dec(ChunkBody.ChildCount); - end; - end; - Result := True; - end; - UserChunk: - if ChunkSize > 0 then - begin - // need to know whether the data was read - LastPosition := Stream.Position; - DoLoadUserData(Node, Stream); - // compare stream position to learn whether the data was read - Result := Stream.Position > LastPosition; - // Improve stability by advancing the stream to the chunk's real end if - // the application did not read what has been written. - if not Result or (Stream.Position <> (LastPosition + ChunkSize)) then - Stream.Position := LastPosition + ChunkSize; - end - else - Result := True; - else - // unknown chunk, skip it - Stream.Position := Stream.Position + ChunkSize; - Result := False; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.ReadNode(Stream: TStream; Version: Integer; Node: PVirtualNode); - -// Reads the anchor chunk of each node and initiates reading the sub chunks for this node - -var - Header: TChunkHeader; - EndPosition: Integer; - -begin - with Stream do - begin - // Read anchor chunk of the node. - Stream.Read(Header, SizeOf(Header)); - if Header.ChunkType = NodeChunk then - begin - EndPosition := Stream.Position + Header.ChunkSize; - // Read all subchunks until the indicated chunk end position is reached in the stream. - while Position < EndPosition do - begin - // Read new chunk header. - Stream.Read(Header, SizeOf(Header)); - ReadChunk(Stream, Version, Node, Header.ChunkType, Header.ChunkSize); - end; - // If the last chunk does not end at the given end position then there is something wrong. - if Position <> EndPosition then - ShowError(SCorruptStream2, hcTFCorruptStream2); - end - else - ShowError(SCorruptStream1, hcTFCorruptStream1); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.RedirectFontChangeEvent(Canvas: TCanvas); - -begin - if @Canvas.Font.OnChange <> @FOldFontChange then - begin - FOldFontChange := Canvas.Font.OnChange; - Canvas.Font.OnChange := FontChanged; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.RemoveFromSelection(Node: PVirtualNode); - -var - Index: Integer; - -begin - Assert(Assigned(Node), 'Node must not be nil!'); - if vsSelected in Node.States then - begin - Exclude(Node.States, vsSelected); - if FindNodeInSelection(Node, Index, -1, -1) and (Index < FSelectionCount - 1) then - Move(FSelection[Index + 1], FSelection[Index], (FSelectionCount - Index - 1) * 4); - if FSelectionCount > 0 then - Dec(FSelectionCount); - SetLength(FSelection, FSelectionCount); - - if FSelectionCount = 0 then - ResetRangeAnchor; - - Change(Node); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.RenderOLEData(const FormatEtcIn: TFormatEtc; out Medium: TStgMedium; - ForClipboard: Boolean): HResult; - -// Returns a memory expression of all currently selected nodes in the Medium structure. -// Note: The memory requirement of this method might be very high. This depends however on the requested storage format. -// For HGlobal (a global memory block) we need to render first all nodes to local memory and copy this then to -// the global memory in Medium. This is necessary because we have first to determine how much -// memory is needed before we can allocate it. Hence for a short moment we need twice the space as used by the -// nodes alone (plus the amount the nodes need in the tree anyway)! -// With IStream this does not happen. We directly stream out the nodes and pass the constructed stream along. - - //--------------- local function -------------------------------------------- - - procedure WriteNodes(Stream: TStream); - - var - Selection: TNodeArray; - I: Integer; - - begin - if ForClipboard then - Selection := GetSortedCutCopySet(True) - else - Selection := GetSortedSelection(True); - for I := 0 to High(Selection) do - WriteNode(Stream, Selection[I]); - end; - - //--------------- end local function ---------------------------------------- - -var - Data: PCardinal; - ResPointer: Pointer; - ResSize: Integer; - OLEStream: IStream; - VCLStream: TStream; - -begin - FillChar(Medium, SizeOf(Medium), 0); - {$ifdef NeedWindows} - // We can render the native clipboard format in two different storage media. - if (FormatEtcIn.cfFormat = CF_VIRTUALTREE) and (FormatEtcIn.tymed and (TYMED_HGLOBAL or TYMED_ISTREAM) <> 0) then - begin - VCLStream := nil; - try - Medium.PunkForRelease := nil; - // Return data in one of the supported storage formats, prefer IStream. - if FormatEtcIn.tymed and TYMED_ISTREAM <> 0 then - begin - // Create an IStream on a memory handle (here it is 0 which indicates to implicitely allocated a handle). - // Do not use TStreamAdapter as it is not compatible with OLE (when flushing the clipboard OLE wants the HGlobal - // back which is not supported by TStreamAdapater). - CreateStreamOnHGlobal(0, True, OLEStream); - - VCLStream := TOLEStream.Create(OLEStream); - WriteNodes(VCLStream); - // Rewind stream. - VCLStream.Position := 0; - Medium.tymed := TYMED_ISTREAM; - IUnknown(Medium.Pstm) := OLEStream; - Result := S_OK; - end - else - begin - VCLStream := TMemoryStream.Create; - WriteNodes(VCLStream); - ResPointer := TMemoryStream(VCLStream).Memory; - ResSize := VCLStream.Position; - - // Allocate memory to hold the string. - if ResSize > 0 then - begin - Medium.hGlobal := GlobalAlloc(GHND or GMEM_SHARE, ResSize + SizeOf(Cardinal)); - Data := GlobalLock(Medium.hGlobal); - // Store the size of the data too, for easy retrival. - Data^ := ResSize; - Inc(Data); - Move(ResPointer^, Data^, ResSize); - GlobalUnlock(Medium.hGlobal); - Medium.tymed := TYMED_HGLOBAL; - - Result := S_OK; - end - else - Result := E_FAIL; - end; - finally - // We can free the VCL stream here since it was either a pure memory stream or only a wrapper around - // the OLEStream which exists independently. - VCLStream.Free; - end; - end - else // Ask application descendants to render self defined formats. - Result := DoRenderOLEData(FormatEtcIn, Medium, ForClipboard); - {$endif} -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.ResetRangeAnchor; - -// Called when there is no selected node anymore and the selection range anchor needs a new value. - -begin - FRangeAnchor := FFocusedNode; - FLastSelectionLevel := -1; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.RestoreFontChangeEvent(Canvas: TCanvas); - -begin - Canvas.Font.OnChange := FOldFontChange; - FOldFontChange := nil; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SelectNodes(StartNode, EndNode: PVirtualNode; AddOnly: Boolean); - -// Selects a range of nodes and unselects all other eventually selected nodes which are not in this range if -// AddOnly is False. -// EndNode must be visible while StartNode does not necessarily as in the case where the last focused node is the start -// node but it is a child of a node which has been collapsed previously. In this case the first visible parent node -// is used as start node. StartNode can be nil in which case the very first node in the tree is used. - -var - NodeFrom, - NodeTo, - LastAnchor: PVirtualNode; - Index: Integer; - -begin - Assert(Assigned(EndNode), 'EndNode must not be nil!'); - ClearTempCache; - if StartNode = nil then - StartNode := FRoot.FirstChild - else - if not FullyVisible[StartNode] then - begin - StartNode := GetPreviousVisible(StartNode); - if StartNode = nil then - StartNode := FRoot.FirstChild - end; - - if CompareNodePositions(StartNode, EndNode) < 0 then - begin - NodeFrom := StartNode; - NodeTo := EndNode; - end - else - begin - NodeFrom := EndNode; - NodeTo := StartNode; - end; - - // The range anchor will be reset by the following call. - LastAnchor := FRangeAnchor; - if not AddOnly then - InternalClearSelection; - - while NodeFrom <> NodeTo do - begin - InternalCacheNode(NodeFrom); - NodeFrom := GetNextVisible(NodeFrom); - end; - // select last node too - InternalCacheNode(NodeFrom); - // now add them all in "one" step - AddToSelection(FTempNodeCache, FTempNodeCount); - ClearTempCache; - if Assigned(LastAnchor) and FindNodeInSelection(LastAnchor, Index, -1, -1) then - FRangeAnchor := LastAnchor; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SetFocusedNodeAndColumn(Node: PVirtualNode; Column: TColumnIndex); - -var - OldColumn: TColumnIndex; - WasDifferent: Boolean; - -begin - WasDifferent := (Node <> FFocusedNode) or (Column <> FFocusedColumn); - - OldColumn := FFocusedColumn; - FFocusedColumn := Column; - - DoFocusNode(Node, True); - - // Check if the change was accepted. - if FFocusedNode = Node then - begin - CancelEditNode; - if WasDifferent then - DoFocusChange(FFocusedNode, FFocusedColumn); - end - else - // If the user did not accept the new cell to focus then set also the focused column back - // to its original state. - FFocusedColumn := OldColumn; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SkipNode(Stream: TStream); - -// Skips the data for the next node in the given stream (including the child nodes). - -var - Header: TChunkHeader; - -begin - with Stream do - begin - // read achor chunk of the node - Stream.Read(Header, SizeOf(Header)); - if Header.ChunkType = NodeChunk then - Stream.Position := Stream.Position + Header.ChunkSize - else - ShowError(SCorruptStream1, hcTFCorruptStream1); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -var - PanningWindowClass: TWndClass = ( - style: 0; - lpfnWndProc: @DefWindowProc; - cbClsExtra: 0; - cbWndExtra: 0; - hInstance: 0; - hIcon: 0; - hCursor: 0; - hbrBackground: 0; - lpszMenuName: nil; - lpszClassName: 'VTPanningWindow' - ); - -procedure TBaseVirtualTree.StartWheelPanning(Position: TPoint); - -// Called when wheel panning should start. A little helper window is created to indicate the reference position, -// which determines in which direction and how far wheel panning/scrolling will happen. - - //--------------- local function -------------------------------------------- - - function CreateClipRegion: HRGN; - - // In order to avoid doing all the transparent drawing ourselves we use a - // window region for the wheel window. - // Since we only work on a very small image (32x32 pixels) this is acceptable. - - var - Start, X, Y: Integer; - Temp: HRGN; - - begin - Assert(not FPanningImage.Empty, 'Invalid wheel panning image.'); - - // Create an initial region on which we operate. - Result := CreateRectRgn(0, 0, 0, 0); - with FPanningImage, Canvas do - begin - for Y := 0 to Height - 1 do - begin - Start := -1; - for X := 0 to Width - 1 do - begin - // Start a new span if we found a non-transparent pixel and no span is currently started. - if (Start = -1) and (Pixels[X, Y] <> clFuchsia) then - Start := X - else - if (Start > -1) and (Pixels[X, Y] = clFuchsia) then - begin - // A non-transparent span is finished. Add it to the result region. - Temp := CreateRectRgn(Start, Y, X, Y + 1); - CombineRgn(Result, Result, Temp, RGN_OR); - DeleteObject(Temp); - Start := -1; - end; - end; - // If there is an open span then add this also to the result region. - if Start > -1 then - begin - Temp := CreateRectRgn(Start, Y, Width, Y + 1); - CombineRgn(Result, Result, Temp, RGN_OR); - DeleteObject(Temp); - end; - end; - end; - // The resulting region is used as window region so we must not delete it. - // Windows will own it after the assignment below. - end; - - //--------------- end local function ---------------------------------------- - -var - TempClass: TWndClass; - ClassRegistered: Boolean; - ImageName: string; - -begin - {$ifdef EnableWheelPanning} - - // Set both panning and scrolling flag. One will be removed shortly depending on whether the middle mouse button is - // released before the mouse is moved or vice versa. The first case is referred to as wheel scrolling while the - // latter is called wheel panning. - StopTimer(ScrollTimer); - DoStateChange([tsWheelPanning, tsWheelScrolling]); - - // Register the helper window class. - PanningWindowClass.hInstance := HInstance; - ClassRegistered := GetClassInfo(HInstance, PanningWindowClass.lpszClassName, TempClass); - if not ClassRegistered or (TempClass.lpfnWndProc <> @DefWindowProc) then - begin - if ClassRegistered then - Windows.UnregisterClass(PanningWindowClass.lpszClassName, HInstance); - Windows.RegisterClass(PanningWindowClass.lpszClassName); - end; - // Create the helper window and show it at the given position without activating it. - with ClientToScreen(Position) do - FPanningWindow := CreateWindowEx(WS_EX_TOOLWINDOW, PanningWindowClass.lpszClassName, nil, WS_POPUP, X - 16, Y - 16, - 32, 32, Handle, 0, HInstance, nil); - - FPanningImage := TBitmap.Create; - if Integer(FRangeX) > ClientWidth then - begin - if Integer(FRangeY) > ClientHeight then - ImageName := 'VT_MOVEALL' - else - ImageName := 'VT_MOVEEW' - end - else - ImageName := 'VT_MOVENS'; - FPanningImage.LoadFromLazarusResource(ImageName); - SetWindowRgn(FPanningWindow, CreateClipRegion, False); - - {$ifdef COMPILER_6_UP} - SetWindowLong(FPanningWindow, GWL_WNDPROC, Integer(Classes.MakeObjectInstance(PanningWindowProc))); - {$else} - SetWindowLong(FPanningWindow, GWL_WNDPROC, Integer(MakeObjectInstance(PanningWindowProc))); - {$endif} - ShowWindow(FPanningWindow, SW_SHOWNOACTIVATE); - - // Setup the panscroll timer and capture all mouse input. - SetFocus; - SetCapture(Handle); - SetTimer(Handle, ScrollTimer, 20, nil); - - {$endif} -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.StopWheelPanning; - -// Stops panning if currently active and destroys the helper window. - -var - Instance: Pointer; - -begin - {$ifdef EnableWheelPanning} - if [tsWheelPanning, tsWheelScrolling] * FStates <> [] then - begin - // Release the mouse capture and stop the panscroll timer. - StopTimer(ScrollTimer); - ReleaseCapture; - DoStateChange([], [tsWheelPanning, tsWheelScrolling]); - - // Destroy the helper window. - Instance := Pointer(GetWindowLong(FPanningWindow, GWL_WNDPROC)); - DestroyWindow(FPanningWindow); - if Instance <> @DefWindowProc then - {$ifdef COMPILER_6_UP} - Classes.FreeObjectInstance(Instance); - {$else} - FreeObjectInstance(Instance); - {$endif} - FPanningWindow := 0; - FPanningImage.Free; - FPanningImage := nil; - DeleteObject(FPanningCursor); - FPanningCursor := 0; - Windows.SetCursor(Screen.Cursors[Cursor]); - end; - {$endif} -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.StructureChange(Node: PVirtualNode; Reason: TChangeReason); - -begin - AdviseChangeEvent(True, Node, Reason); - - if FUpdateCount = 0 then - begin - if (FChangeDelay > 0) and not (tsSynchMode in FStates) then - SetTimer(Handle, StructureChangeTimer, FChangeDelay, nil) - else - DoStructureChange(Node, Reason); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.SuggestDropEffect(Source: TObject; Shift: TShiftState; Pt: TPoint; - AllowedEffects: Integer): Integer; - -// determines the drop action to take if the drag'n drop operation ends on this tree -// Note: Source can be any Delphi object not just a virtual tree - -begin - Result := AllowedEffects; - - // prefer MOVE if source and target are the same control, otherwise whatever is allowed as initial value - if Assigned(Source) and (Source = Self) then - if (AllowedEffects and DROPEFFECT_MOVE) <> 0 then - Result := DROPEFFECT_MOVE - else // no change - else - // drag between different applicatons - if (AllowedEffects and DROPEFFECT_COPY) <> 0 then - Result := DROPEFFECT_COPY; - - // consider modifier keys and what is allowed at the moment, if none of the following conditions apply then - // the initial value just set is used - if ssCtrl in Shift then - begin - // copy or link - if ssShift in Shift then - begin - // link - if (AllowedEffects and DROPEFFECT_LINK) <> 0 then - Result := DROPEFFECT_LINK; - end - else - begin - // copy - if (AllowedEffects and DROPEFFECT_COPY) <> 0 then - Result := DROPEFFECT_COPY; - end; - end - else - begin - // move, link or default - if ssShift in Shift then - begin - // move - if (AllowedEffects and DROPEFFECT_MOVE) <> 0 then - Result := DROPEFFECT_MOVE; - end - else - begin - // link or default - if ssAlt in Shift then - begin - // link - if (AllowedEffects and DROPEFFECT_LINK) <> 0 then - Result := DROPEFFECT_LINK; - end; - // else default - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.ToggleSelection(StartNode, EndNode: PVirtualNode); - -// Switchs the selection state of a range of nodes. -// Note: This method is specifically designed to help selecting ranges with the keyboard and considers therefore -// the range anchor. - -var - NodeFrom, - NodeTo: PVirtualNode; - NewSize: Integer; - Position: Integer; - -begin - Assert(Assigned(EndNode), 'EndNode must not be nil!'); - if StartNode = nil then - StartNode := FRoot.FirstChild - else - if not FullyVisible[StartNode] then - StartNode := GetPreviousVisible(StartNode); - - Position := CompareNodePositions(StartNode, EndNode); - // nothing to do if start and end node are the same - if Position <> 0 then - begin - if Position < 0 then - begin - NodeFrom := StartNode; - NodeTo := EndNode; - end - else - begin - NodeFrom := EndNode; - NodeTo := StartNode; - end; - - ClearTempCache; - - // 1) toggle the start node if it is before the range anchor - if CompareNodePositions(NodeFrom, FRangeAnchor) < 0 then - if not (vsSelected in NodeFrom.States) then - InternalCacheNode(NodeFrom) - else - InternalRemoveFromSelection(NodeFrom); - - // 2) toggle all nodes within the range - NodeFrom := GetNextVisible(NodeFrom); - while NodeFrom <> NodeTo do - begin - if not (vsSelected in NodeFrom.States) then - InternalCacheNode(NodeFrom) - else - InternalRemoveFromSelection(NodeFrom); - NodeFrom := GetNextVisible(NodeFrom); - end; - - // 3) toggle end node if it is after the range anchor - if CompareNodePositions(NodeFrom, FRangeAnchor) > 0 then - if not (vsSelected in NodeFrom.States) then - InternalCacheNode(NodeFrom) - else - InternalRemoveFromSelection(NodeFrom); - - // Do some housekeeping if there was a change. - NewSize := PackArray(FSelection, FSelectionCount); - if NewSize > -1 then - begin - FSelectionCount := NewSize; - SetLength(FSelection, FSelectionCount); - end; - // If the range went over the anchor then we need to reselect it. - if not (vsSelected in FRangeAnchor.States) then - InternalCacheNode(FRangeAnchor); - if FTempNodeCount > 0 then - AddToSelection(FTempNodeCache, FTempNodeCount); - ClearTempCache; - - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.UnselectNodes(StartNode, EndNode: PVirtualNode); - -// Deselects a range of nodes. -// EndNode must be visible while StartNode must not as in the case where the last focused node is the start node -// but it is a child of a node which has been collapsed previously. In this case the first visible parent node -// is used as start node. StartNode can be nil in which case the very first node in the tree is used. - -var - NodeFrom, - NodeTo: PVirtualNode; - NewSize: Integer; - -begin - Assert(Assigned(EndNode), 'EndNode must not be nil!'); - - if StartNode = nil then - StartNode := FRoot.FirstChild - else - if not FullyVisible[StartNode] then - begin - StartNode := GetPreviousVisible(StartNode); - if StartNode = nil then - StartNode := FRoot.FirstChild - end; - - if CompareNodePositions(StartNode, EndNode) < 0 then - begin - NodeFrom := StartNode; - NodeTo := EndNode; - end - else - begin - NodeFrom := EndNode; - NodeTo := StartNode; - end; - - while NodeFrom <> NodeTo do - begin - InternalRemoveFromSelection(NodeFrom); - NodeFrom := GetNextVisible(NodeFrom); - end; - // Deselect last node too. - InternalRemoveFromSelection(NodeFrom); - - // Do some housekeeping. - NewSize := PackArray(FSelection, FSelectionCount); - if NewSize > -1 then - begin - FSelectionCount := NewSize; - SetLength(FSelection, FSelectionCount); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.UpdateDesigner; - -var - ParentForm: TCustomForm; - -begin - if (csDesigning in ComponentState) and not (csUpdating in ComponentState) then - begin - ParentForm := GetParentForm(Self); - if Assigned(ParentForm) and Assigned(ParentForm.Designer) then - ParentForm.Designer.Modified; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.UpdateHeaderRect; - -// Calculates the rectangle the header occupies in non-client area. -// These coordinates are in window rectangle. - -var - OffsetX, - OffsetY: Integer; - EdgeSize: Integer; - Size: TSize; - -begin - FHeaderRect := Rect(0, 0, Width, Height); - - // Consider borders... - Size := GetBorderDimensions; - InflateRect(FHeaderRect, Size.cx, Size.cy); - - // ... and bevels. - OffsetX := BorderWidth; - OffsetY := BorderWidth; - //todo_lcl - { - if BevelKind <> bkNone then - begin - EdgeSize := 0; - if BevelInner <> bvNone then - Inc(EdgeSize, BevelWidth); - if BevelOuter <> bvNone then - Inc(EdgeSize, BevelWidth); - if beLeft in BevelEdges then - Inc(OffsetX, EdgeSize); - if beTop in BevelEdges then - Inc(OffsetY, EdgeSize); - end; - } - InflateRect(FHeaderRect, -OffsetX, -OffsetY); - - if hoVisible in FHeader.FOptions then - begin - if FHeaderRect.Left <= FHeaderRect.Right then - FHeaderRect.Bottom := FHeaderRect.Top + Integer(FHeader.FHeight) - else - FHeaderRect := Rect(0, 0, 0, 0); - end - else - FHeaderRect.Bottom := FHeaderRect.Top; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.UpdateEditBounds; - -// Used to update the bounds of the current node editor if editing is currently active. - -var - R: TRect; - Dummy: Integer; - CurrentAlignment: TAlignment; - CurrentBidiMode: TBidiMode; - -begin - if tsEditing in FStates then - begin - if vsMultiline in FFocusedNode.States then - R := GetDisplayRect(FFocusedNode, FEditColumn, True, False) - else - R := GetDisplayRect(FFocusedNode, FEditColumn, True, True); - if (toGridExtensions in FOptions.FMiscOptions) then - begin - // Adjust edit bounds depending on alignment and bidi mode. - if FEditColumn = NoColumn then - begin - CurrentAlignment := Alignment; - CurrentBidiMode := BiDiMode; - end - else - begin - CurrentAlignment := FHeader.Columns[FEditColumn].FAlignment; - CurrentBidiMode := FHeader.Columns[FEditColumn].FBidiMode; - end; - // Consider bidi mode here. In RTL context does left alignment actually mean right alignment and vice versa. - if CurrentBidiMode <> bdLeftToRight then - ChangeBiDiModeAlignment(CurrentAlignment); - if CurrentAlignment = taLeftJustify then - FHeader.Columns.GetColumnBounds(FEditColumn, Dummy, R.Right) - else - FHeader.Columns.GetColumnBounds(FEditColumn, R.Left, Dummy); - end; - if toShowHorzGridLines in TreeOptions.PaintOptions then - Dec(R.Bottom); - FEditLink.SetBounds(R); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -const - ScrollMasks: array[Boolean] of Cardinal = (0, SIF_DISABLENOSCROLL); - -const // Region identifiers for GetRandomRgn - CLIPRGN = 1; - METARGN = 2; - APIRGN = 3; - SYSRGN = 4; - -//todo_lcl -function GetRandomRgn(DC: HDC; Rgn: HRGN; iNum: Integer): Integer; //stdcall; external 'GDI32.DLL'; -begin -end; - -procedure TBaseVirtualTree.UpdateWindowAndDragImage(const Tree: TBaseVirtualTree; TreeRect: TRect; UpdateNCArea, - ReshowDragImage: Boolean); - -// Method to repaint part of the window area which is not covered by the drag image and to initiate a recapture -// of the drag image. -// Note: This method must only be called during a drag operation and the tree passed in is the one managing the current -// drag image (so it is the actual drag source). - -var - DragRegion, // the region representing the drag image - UpdateRegion, // the unclipped region within the tree to be updated - NCRegion: HRGN; // the region representing the non-client area of the tree - DragRect, - NCRect: TRect; - RedrawFlags: Cardinal; - - VisibleTreeRegion: HRGN; - - DC: HDC; - -begin - if IntersectRect(TreeRect, TreeRect, ClientRect) then - begin - // Retrieve the visible region of the window. This is important to avoid overpainting parts of other windows - // which overlap this one. - VisibleTreeRegion := CreateRectRgn(0, 0, 1, 1); - DC := GetDCEx(Handle, 0, DCX_CACHE or DCX_WINDOW or DCX_CLIPSIBLINGS or DCX_CLIPCHILDREN); - GetRandomRgn(DC, VisibleTreeRegion, SYSRGN); - ReleaseDC(Handle, DC); - - // In Win9x the returned visible region is given in client coordinates. We need it in screen coordinates, though. - if not IsWinNT then - with ClientToScreen(Point(0, 0)) do - OffsetRgn(VisibleTreeRegion, X, Y); - - // The drag image will figure out itself what part of the rectangle can be recaptured. - // Recapturing is not done by taking a snapshot of the screen, but by letting the tree draw itself - // into the back bitmap of the drag image. So the order here is unimportant. - Tree.FDragImage.RecaptureBackground(Self, TreeRect, VisibleTreeRegion, UpdateNCArea, ReshowDragImage); - - // Calculate the screen area not covered by the drag image and which needs an update. - DragRect := Tree.FDragImage.GetDragImageRect; - MapWindowPoints(0, Handle, @DragRect.TopLeft, 2); - DragRegion := CreateRectRgnIndirect(DragRect); - - // Start with non-client area if requested. - if UpdateNCArea then - begin - // Compute the part of the non-client area which must be updated. - - // Determine the outer rectangle of the entire tree window. - GetWindowRect(Handle, NCRect); - // Express the tree window rectangle in client coordinates (because RedrawWindow wants them so). - MapWindowPoints(0, Handle, @NCRect.TopLeft, 2); - NCRegion := CreateRectRgnIndirect(NCRect); - // Determine client rect in screen coordinates and create another region for it. - UpdateRegion := CreateRectRgnIndirect(ClientRect); - // Create a region which only contains the NC part by subtracting out the client area. - CombineRgn(NCRegion, NCRegion, UpdateRegion, RGN_DIFF); - // Subtract also out what is hidden by the drag image. - CombineRgn(NCRegion, NCRegion, DragRegion, RGN_DIFF); - RedrawWindow(Handle, nil, NCRegion, RDW_FRAME or RDW_NOERASE or RDW_NOCHILDREN or RDW_INVALIDATE or RDW_VALIDATE or - RDW_UPDATENOW); - DeleteObject(NCRegion); - DeleteObject(UpdateRegion); - end; - - UpdateRegion := CreateRectRgnIndirect(TreeRect); - RedrawFlags := RDW_INVALIDATE or RDW_VALIDATE or RDW_UPDATENOW or RDW_NOERASE or RDW_NOCHILDREN; - // Remove the part of the update region which is covered by the drag image. - CombineRgn(UpdateRegion, UpdateRegion, DragRegion, RGN_DIFF); - RedrawWindow(Handle, nil, UpdateRegion, RedrawFlags); - DeleteObject(UpdateRegion); - DeleteObject(DragRegion); - DeleteObject(VisibleTreeRegion); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.ValidateCache; - -// Starts cache validation if not already done by adding this instance to the worker thread's waiter list -// (if not already there) and signalling the thread it can start validating. - -begin - // Wait for thread to stop validation if it is currently validating this tree's cache. - InterruptValidation; - - FStartIndex := 0; - if tsValidationNeeded in FStates then - begin - // Tell the thread this tree needs actually something to do. - WorkerThread.AddTree(Self); - WorkEvent.SetEvent; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.ValidateNodeDataSize(var Size: Integer); - -begin - Size := 0; - if Assigned(FOnGetNodeDataSize) then - FOnGetNodeDataSize(Self, Size); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.WndProc(var Message: TLMessage); - -var - Handled: Boolean; - -begin - Handled := False; - - // Try the header whether it needs to take this message. - if Assigned(FHeader) and (FHeader.FStates <> []) then - Handled := FHeader.HandleMessage(Message); - if not Handled then - begin - // For auto drag mode, let tree handle itself, instead of TControl. - if not (csDesigning in ComponentState) and - ((Message.Msg = LM_LBUTTONDOWN) or (Message.Msg = LM_LBUTTONDBLCLK)) then - begin - if (DragMode = dmAutomatic) and (DragKind = dkDrag) then - begin - if IsControlMouseMsg(TLMMouse(Message)) then - Handled := True; - if not Handled then - begin - ControlState := ControlState + [csLButtonDown]; - Dispatch(Message); // overrides TControl's BeginDrag - Handled := True; - end; - end; - end; - - if not Handled and Assigned(FHeader) then - Handled := FHeader.HandleMessage(Message); - - if not Handled then - begin - if (Message.Msg in [WM_NCLBUTTONDOWN, WM_NCRBUTTONDOWN, WM_NCMBUTTONDOWN]) and not Focused and CanFocus then - SetFocus; - inherited; - end; - - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.WriteChunks(Stream: TStream; Node: PVirtualNode); - -// Writes the core chunks for Node into the stream. -// Note: descendants can optionally override this method to add other node specific chunks. -// Keep in mind that this method is also called for the root node. Using this fact in descendants you can -// create a kind of "global" chunks not directly bound to a specific node. - -var - Header: TChunkHeader; - LastPosition, - ChunkSize: Integer; - Chunk: TBaseChunk; - Run: PVirtualNode; - -begin - with Stream do - begin - // 1. The base chunk... - LastPosition := Position; - Chunk.Header.ChunkType := BaseChunk; - with Node^, Chunk do - begin - Body.ChildCount := ChildCount; - Body.NodeHeight := NodeHeight; - // Some states are only temporary so take them out as they make no sense at the new location. - Body.States := States - [vsChecking, vsCutOrCopy, vsDeleting, vsInitialUserData, vsHeightMeasured]; - Body.Align := Align; - Body.CheckState := CheckState; - Body.CheckType := CheckType; - Body.Reserved := 0; - end; - // write the base chunk - Write(Chunk, SizeOf(Chunk)); - - // 2. ... directly followed by the child node chunks (actually they are child chunks of - // the base chunk) - if vsInitialized in Node.States then - begin - Run := Node.FirstChild; - while Assigned(Run) do - begin - WriteNode(Stream, Run); - Run := Run.NextSibling; - end; - end; - - FinishChunkHeader(Stream, LastPosition, Position); - - // 3. write user data - LastPosition := Position; - Header.ChunkType := UserChunk; - Write(Header, SizeOf(Header)); - DoSaveUserData(Node, Stream); - // check if the application actually wrote data - ChunkSize := Position - LastPosition - SizeOf(TChunkHeader); - // seek back to start of chunk if nothing has been written - if ChunkSize = 0 then - begin - Position := LastPosition; - Size := Size - SizeOf(Header); - end - else - FinishChunkHeader(Stream, LastPosition, Position); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.WriteNode(Stream: TStream; Node: PVirtualNode); - -// Writes the "cover" chunk for Node to Stream and initiates writing child nodes and chunks. - -var - LastPosition: Integer; - Header: TChunkHeader; - -begin - // Initialize the node first if necessary and wanted. - if toInitOnSave in FOptions.FMiscOptions then - begin - if not (vsInitialized in Node.States) then - InitNode(Node); - if (vsHasChildren in Node.States) and (Node.ChildCount = 0) then - InitChildren(Node); - end; - - with Stream do - begin - LastPosition := Position; - // Emit the anchor chunk. - Header.ChunkType := NodeChunk; - Write(Header, SizeOf(Header)); - // Write other chunks to stream taking their size into this chunk's size. - WriteChunks(Stream, Node); - - // Update chunk size. - FinishChunkHeader(Stream, LastPosition, Position); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.AbsoluteIndex(Node: PVirtualNode): Cardinal; - -begin - Result := 0; - while Assigned(Node) and (Node <> FRoot) do - begin - if not (vsInitialized in Node.States) then - InitNode(Node); - if Assigned(Node.PrevSibling) then - begin - // if there's a previous sibling then add its total count to the result - Node := Node.PrevSibling; - Inc(Result, Node.TotalCount); - end - else - begin - Node := Node.Parent; - if Node <> FRoot then - Inc(Result); - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.AddChild(Parent: PVirtualNode; UserData: Pointer = nil): PVirtualNode; - -// Adds a new node to the given parent node. This is simply done by increasing the child count of the -// parent node. If Parent is nil then the new node is added as (last) top level node. -// UserData can be used to set the first 4 bytes of the user data area to an initial value which can be used -// in OnInitNode and will also cause to trigger the OnFreeNode event (if <> nil) even if the node is not yet -// "officially" initialized. -// AddChild is a compatibility method and will implicitly validate the parent node. This is however -// against the virtual paradigm and hence I dissuade from its usage. - -var - NodeData: ^Pointer; - -begin - if not (toReadOnly in FOptions.FMiscOptions) then - begin - CancelEditNode; - - if Parent = nil then - Parent := FRoot; - if not (vsInitialized in Parent.States) then - InitNode(Parent); - - // Locally stop updates of the tree in order to avoid usage of the new node before it is correctly set up. - // If the update count was 0 on enter then there will be a correct update at the end of this method. - Inc(FUpdateCount); - try - SetChildCount(Parent, Parent.ChildCount + 1); - // Update the hidden children flag of the parent. Nodes are added as being visible by default. - Exclude(Parent.States, vsAllChildrenHidden); - finally - Dec(FUpdateCount); - end; - Result := Parent.LastChild; - - // Check if there is initial user data and there is also enough user data space allocated. - if Assigned(UserData) then - if FNodeDataSize >= 4 then - begin - NodeData := Pointer(PChar(@Result.Data) + FTotalInternalDataSize); - NodeData^ := UserData; - Include(Result.States, vsInitialUserData); - end - else - ShowError(SCannotSetUserData, hcTFCannotSetUserData); - - InvalidateCache; - if FUpdateCount = 0 then - begin - ValidateCache; - if tsStructureChangePending in FStates then - begin - if Parent = FRoot then - StructureChange(nil, crChildAdded) - else - StructureChange(Parent, crChildAdded); - end; - - if (toAutoSort in FOptions.FAutoOptions) and (FHeader.FSortColumn > InvalidColumn) then - Sort(Parent, FHeader.FSortColumn, FHeader.FSortDirection, True); - - InvalidateToBottom(Parent); - UpdateScrollbars(True); - end; - end - else - Result := nil; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.AddFromStream(Stream: TStream; TargetNode: PVirtualNode); - -// loads nodes from the given stream and adds them to TargetNode -// the current content is not cleared before the load process starts (see also LoadFromStream) - -var - ThisID: TMagicID; - Version, - Count: Cardinal; - Node: PVirtualNode; - -begin - if not (toReadOnly in FOptions.FMiscOptions) then - begin - // check first whether this is a stream we can read - Stream.ReadBuffer(ThisID, SizeOf(TMagicID)); - if (ThisID[0] = MagicID[0]) and - (ThisID[1] = MagicID[1]) and - (ThisID[2] = MagicID[2]) and - (ThisID[5] = MagicID[5]) then - begin - Version := Word(ThisID[3]); - if Version <= VTTreeStreamVersion then - begin - BeginUpdate; - try - if Version < 2 then - Count := MaxInt - else - Stream.ReadBuffer(Count, SizeOf(Count)); - - while (Stream.Position < Stream.Size) and (Count > 0) do - begin - Dec(Count); - Node := MakeNewNode; - InternalConnectNode(Node, TargetNode, Self, amAddChildLast); - InternalAddFromStream(Stream, Version, Node); - end; - if TargetNode = FRoot then - DoNodeCopied(nil) - else - DoNodeCopied(TargetNode); - finally - EndUpdate; - end; - end - else - ShowError(SWrongStreamVersion, hcTFWrongStreamVersion); - end - else - ShowError(SWrongStreamVersion, hcTFWrongStreamVersion); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.AfterConstruction; - -begin - inherited; - - if FRoot = nil then - InitRootNode; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.Assign(Source: TPersistent); - -begin - if (Source is TBaseVirtualTree) and not (toReadOnly in FOptions.FMiscOptions) then - with Source as TBaseVirtualTree do - begin - Self.Align := Align; - Self.Anchors := Anchors; - Self.AutoScrollDelay := AutoScrollDelay; - Self.AutoScrollInterval := AutoScrollInterval; - Self.AutoSize := AutoSize; - Self.Background := Background; - //todo_lcl - { - Self.BevelEdges := BevelEdges; - Self.BevelInner := BevelInner; - Self.BevelKind := BevelKind; - Self.BevelOuter := BevelOuter; - Self.BevelWidth := BevelWidth; - } - Self.BiDiMode := BiDiMode; - Self.BorderStyle := BorderStyle; - Self.BorderWidth := BorderWidth; - Self.ChangeDelay := ChangeDelay; - Self.CheckImageKind := CheckImageKind; - Self.Color := Color; - Self.Colors.Assign(Colors); - Self.Constraints.Assign(Constraints); - Self.Ctl3D := Ctl3D; - Self.DefaultNodeHeight := DefaultNodeHeight; - Self.DefaultPasteMode := DefaultPasteMode; - Self.DragCursor := DragCursor; - Self.DragImageKind := DragImageKind; - Self.DragKind := DragKind; - Self.DragMode := DragMode; - Self.Enabled := Enabled; - Self.Font := Font; - Self.Header := Header; - Self.HintAnimation := HintAnimation; - Self.HintMode := HintMode; - Self.HotCursor := HotCursor; - Self.Images := Images; - //Self.ImeMode := ImeMode; - //Self.ImeName := ImeName; - Self.Indent := Indent; - Self.Margin := Margin; - Self.NodeAlignment := NodeAlignment; - Self.NodeDataSize := NodeDataSize; - Self.TreeOptions := TreeOptions; - //Self.ParentBiDiMode := ParentBiDiMode; - Self.ParentColor := ParentColor; - Self.ParentCtl3D := ParentCtl3D; - Self.ParentFont := ParentFont; - Self.ParentShowHint := ParentShowHint; - Self.PopupMenu := PopupMenu; - Self.RootNodeCount := RootNodeCount; - Self.ScrollBarOptions := ScrollBarOptions; - Self.ShowHint := ShowHint; - Self.StateImages := StateImages; - Self.TabOrder := TabOrder; - Self.TabStop := TabStop; - Self.Visible := Visible; - Self.SelectionCurveRadius := SelectionCurveRadius; - Self.SelectionBlendFactor := SelectionBlendFactor; - end - else - inherited; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.BeginDrag(Immediate: Boolean; Threshold: Integer); - -// Reintroduced method to allow to start OLE drag'n drop as well as VCL drag'n drop. - -begin - if FDragType = dtVCL then - begin - DoStateChange([tsVCLDragPending]); - inherited; - end - else - if (FStates * [tsOLEDragPending, tsOLEDragging]) = [] then - begin - // Drag start position has already been recorded in WMMouseDown. - if Threshold < 0 then - FDragThreshold := Mouse.DragThreshold - else - FDragThreshold := Threshold; - if Immediate then - DoDragging(FLastClickPos) - else - DoStateChange([tsOLEDragPending]); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.BeginSynch; - -// Starts the synchronous update mode (if not already active). - -begin - if not (csDestroying in ComponentState) then - begin - if FSynchUpdateCount = 0 then - begin - DoUpdating(usBeginSynch); - - // Stop all timers... - StopTimer(ChangeTimer); - StopTimer(StructureChangeTimer); - StopTimer(ExpandTimer); - StopTimer(EditTimer); - StopTimer(HeaderTimer); - StopTimer(ScrollTimer); - StopTimer(SearchTimer); - FSearchBuffer := ''; - FLastSearchNode := nil; - DoStateChange([], [tsEditPending, tsScrollPending, tsScrolling, tsIncrementalSearching]); - - // ...and trigger pending update states. - if tsStructureChangePending in FStates then - DoStructureChange(FLastStructureChangeNode, FLastStructureChangeReason); - if tsChangePending in FStates then - DoChange(FLastChangedNode); - end - else - DoUpdating(usSynch); - end; - Inc(FSynchUpdateCount); - DoStateChange([tsSynchMode]); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.BeginUpdate; - -begin - if not (csDestroying in ComponentState) then - begin - if FUpdateCount = 0 then - begin - DoUpdating(usBegin); - SetUpdateState(True); - end - else - DoUpdating(usUpdate); - end; - Inc(FUpdateCount); - DoStateChange([tsUpdating]); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.CancelCutOrCopy; - -// Resets nodes which are marked as being cut. - -var - Run: PVirtualNode; - -begin - if ([tsCutPending, tsCopyPending] * FStates) <> [] then - begin - Run := FRoot.FirstChild; - while Assigned(Run) do - begin - if vsCutOrCopy in Run.States then - Exclude(Run.States, vsCutOrCopy); - Run := GetNextNoInit(Run); - end; - end; - DoStateChange([], [tsCutPending, tsCopyPending]); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.CancelEditNode: Boolean; - -// Called by the application or the current edit link to cancel the edit action. - -begin - if HandleAllocated and ([tsEditing, tsEditPending] * FStates <> []) then - Result := DoCancelEdit - else - Result := True; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.CanFocus: Boolean; - -var - Form: TCustomForm; - -begin - {$ifdef COMPILER_5_UP} - Result := inherited CanFocus; - {$else} - Result := True; - {$endif} - - if Result and not (csDesigning in ComponentState) then - begin - Form := GetParentForm(Self); - Result := (Form = nil) or (Form.Enabled and Form.Visible); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.Clear; - -begin - if not (toReadOnly in FOptions.FMiscOptions) or (csDestroying in ComponentState) then - begin - BeginUpdate; - try - InterruptValidation; - if IsEditing then - CancelEditNode; - - if ClipboardStates * FStates <> [] then - begin - OleSetClipBoard(nil); - DoStateChange([], ClipboardStates); - end; - ClearSelection; - FFocusedNode := nil; - FLastSelected := nil; - FCurrentHotNode := nil; - FDropTargetNode := nil; - FLastChangedNode := nil; - FRangeAnchor := nil; - FCheckNode := nil; - FLastVCLDragTarget := nil; - FLastSearchNode := nil; - DeleteChildren(FRoot, True); - FVisibleCount := 0; - FOffsetX := 0; - FOffsetY := 0; - - {$ifdef UseLocalMemoryManager} - FNodeMemoryManager.Clear; - {$endif UseLocalMemoryManager} - finally - EndUpdate; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.ClearChecked; - -var - Node: PVirtualNode; - -begin - Node := RootNode.FirstChild; - while Assigned(Node) do - begin - if Node.CheckState <> csUncheckedNormal then - CheckState[Node] := csUncheckedNormal; - Node := GetNextNoInit(Node); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.ClearSelection; - -var - Node: PVirtualNode; - Dummy: Integer; - R: TRect; - Counter: Integer; - -begin - if (FSelectionCount > 0) and not (csDestroying in ComponentState) then - begin - if (FUpdateCount = 0) and HandleAllocated and (FVisibleCount > 0) then - begin - // Iterate through nodes currently visible in the client area and invalidate them. - Node := GetNodeAt(0, 0, True, Dummy); - if Assigned(Node) then - R := GetDisplayRect(Node, NoColumn, False); - Counter := FSelectionCount; - - while Assigned(Node) do - begin - R.Bottom := R.Top + Integer(NodeHeight[Node]); - if vsSelected in Node.States then - begin - InvalidateRect(Handle, @R, False); - Dec(Counter); - // Only try as many nodes as are selected. - if Counter = 0 then - Break; - end; - R.Top := R.Bottom; - if R.Top > ClientHeight then - Break; - Node := GetNextVisibleNoInit(Node); - end; - end; - - InternalClearSelection; - Change(nil); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.CopyTo(Source: PVirtualNode; Tree: TBaseVirtualTree; Mode: TVTNodeAttachMode; - ChildrenOnly: Boolean): PVirtualNode; - -// A simplified CopyTo method to allow to copy nodes to the root of another tree. - -begin - Result := CopyTo(Source, Tree.FRoot, Mode, ChildrenOnly); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.CopyTo(Source, Target: PVirtualNode; Mode: TVTNodeAttachMode; - ChildrenOnly: Boolean): PVirtualNode; - -// Copies Source and all its child nodes to Target. -// Mode is used to specify further where to add the new node actually (as sibling of Target or as child of Target). -// Result is the newly created node to which source has been copied if ChildrenOnly is False or just contains Target -// in the other case. -// ChildrenOnly determines whether to copy also the source node or only its child nodes. - -var - TargetTree: TBaseVirtualTree; - Stream: TMemoryStream; - -begin - Assert(TreeFromNode(Source) = Self, 'The source tree must contain the source node.'); - - Result := nil; - if (Mode <> amNoWhere) and Assigned(Source) and (Source <> FRoot) then - begin - // Assume that an empty destination means the root in this (the source) tree. - if Target = nil then - begin - TargetTree := Self; - Target := FRoot; - Mode := amAddChildFirst; - end - else - TargetTree := TreeFromNode(Target); - - if not (toReadOnly in TargetTree.FOptions.FMiscOptions) then - begin - if Target = TargetTree.FRoot then - begin - case Mode of - amInsertBefore: - Mode := amAddChildFirst; - amInsertAfter: - Mode := amAddChildLast; - end; - end; - - Stream := TMemoryStream.Create; - try - // Write all nodes into a temprary stream depending on the ChildrenOnly flag. - if not ChildrenOnly then - WriteNode(Stream, Source) - else - begin - Source := Source.FirstChild; - while Assigned(Source) do - begin - WriteNode(Stream, Source); - Source := Source.NextSibling; - end; - end; - // Now load the serialized nodes into the target node (tree). - TargetTree.BeginUpdate; - try - Stream.Position := 0; - while Stream.Position < Stream.Size do - begin - Result := TargetTree.MakeNewNode; - InternalConnectNode(Result, Target, TargetTree, Mode); - TargetTree.InternalAddFromStream(Stream, VTTreeStreamVersion, Result); - if not DoNodeCopying(Result, Target) then - begin - TargetTree.DeleteNode(Result); - Result := nil; - end - else - DoNodeCopied(Result); - end; - if ChildrenOnly then - Result := Target; - finally - TargetTree.EndUpdate; - end; - finally - Stream.Free; - end; - - with TargetTree do - begin - InvalidateCache; - if FUpdateCount = 0 then - begin - ValidateCache; - UpdateScrollBars(True); - Invalidate; - end; - StructureChange(Source, crNodeCopied); - end; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.CopyToClipBoard; - -var - DataObject: IDataObject; - -begin - if FSelectionCount > 0 then - begin - DataObject := TVTDataObject.Create(Self, True) as IDataObject; - if OleSetClipBoard(DataObject) = S_OK then - begin - MarkCutCopyNodes; - DoStateChange([tsCopyPending]); - Invalidate; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.CutToClipBoard; - -var - DataObject: IDataObject; - -begin - if (FSelectionCount > 0) and not (toReadOnly in FOptions.FMiscOptions) then - begin - DataObject := TVTDataObject.Create(Self, True) as IDataObject; - if OleSetClipBoard(DataObject) = S_OK then - begin - MarkCutCopyNodes; - DoStateChange([tsCutPending], [tsCopyPending]); - Invalidate; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DeleteChildren(Node: PVirtualNode; ResetHasChildren: Boolean = False); - -// Removes all children and their children from memory without changing the vsHasChildren style by default. - -var - Run, - Mark: PVirtualNode; - LastTop, - LastLeft, - NewSize: Integer; - ParentVisible: Boolean; - -begin - if (Node.ChildCount > 0) and not (toReadOnly in FOptions.FMiscOptions) then - begin - Assert(not (tsIterating in FStates), 'Deleting nodes during tree iteration leads to invalid pointers.'); - - // The code below uses some flags for speed improvements which may cause invalid pointers if updates of - // the tree happen. Hence switch updates off until we have finished the operation. - Inc(FUpdateCount); - try - InterruptValidation; - LastLeft := -FEffectiveOffsetX; - LastTop := FOffsetY; - - // Make a local copy of the visibility state of this node to speed up - // adjusting the visible nodes count. - ParentVisible := Node = FRoot; - if not ParentVisible then - ParentVisible := FullyVisible[Node] and (vsExpanded in Node.States); - - // Show that we are clearing the child list, to avoid registering structure change events. - Include(Node.States, vsClearing); - Run := Node.LastChild; - while Assigned(Run) do - begin - if ParentVisible and (vsVisible in Run.States) then - Dec(FVisibleCount); - - Include(Run.States, vsDeleting); - Mark := Run; - Run := Run.PrevSibling; - // Important, to avoid exchange of invalid pointers while disconnecting the node. - if Assigned(Run) then - Run.NextSibling := nil; - DeleteNode(Mark); - end; - Exclude(Node.States, vsClearing); - if ResetHasChildren then - Exclude(Node.States, vsHasChildren); - if Node <> FRoot then - Exclude(Node.States, vsExpanded); - Node.ChildCount := 0; - if (Node = FRoot) or (vsDeleting in Node.States) then - begin - Node.TotalHeight := FDefaultNodeHeight + NodeHeight[Node]; - Node.TotalCount := 1; - end - else - begin - AdjustTotalHeight(Node, NodeHeight[Node]); - AdjustTotalCount(Node, 1); - end; - Node.FirstChild := nil; - Node.LastChild := nil; - finally - Dec(FUpdateCount); - end; - - InvalidateCache; - if FUpdateCount = 0 then - begin - NewSize := PackArray(FSelection, FSelectionCount); - if NewSize > -1 then - begin - FSelectionCount := NewSize; - SetLength(FSelection, FSelectionCount); - end; - - ValidateCache; - UpdateScrollbars(True); - // Invalidate entire tree if it scrolled e.g. to make the last node also the - // bottom node in the treeview. - if (LastLeft <> FOffsetX) or (LastTop <> FOffsetY) then - Invalidate - else - InvalidateToBottom(Node); - end; - StructureChange(Node, crChildDeleted); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DeleteNode(Node: PVirtualNode; Reindex: Boolean = True); - -var - LastTop, - LastLeft: Integer; - LastParent: PVirtualNode; - WasInSynchMode: Boolean; - ParentClearing: Boolean; - -begin - if Assigned(Node) and (Node <> FRoot) and not (toReadOnly in FOptions.FMiscOptions) then - begin - Assert(not (tsIterating in FStates), 'Deleting nodes during tree iteration leads to invalid pointers.'); - - // Determine parent node for structure change notification. - ParentClearing := vsClearing in Node.Parent.States; - LastParent := Node.Parent; - - if not ParentClearing then - begin - if LastParent = FRoot then - StructureChange(nil, crChildDeleted) - else - StructureChange(LastParent, crChildDeleted); - end; - - LastLeft := -FEffectiveOffsetX; - LastTop := FOffsetY; - - if vsSelected in Node.States then - begin - if FUpdateCount = 0 then - begin - // Go temporarily into sync mode to avoid a delayed change event for the node - // when unselecting. - WasInSynchMode := tsSynchMode in FStates; - Include(FStates, tsSynchMode); - RemoveFromSelection(Node); - if not WasInSynchMode then - Exclude(FStates, tsSynchMode); - InvalidateToBottom(LastParent); - end - else - InternalRemoveFromSelection(Node); - end - else - InvalidateToBottom(LastParent); - - if tsHint in FStates then - begin - Application.CancelHint; - DoStateChange([], [tsHint]); - end; - - DeleteChildren(Node); - InternalDisconnectNode(Node, False, Reindex); - DoFreeNode(Node); - - if not ParentClearing then - begin - DetermineHiddenChildrenFlag(LastParent); - InvalidateCache; - if FUpdateCount = 0 then - begin - ValidateCache; - UpdateScrollbars(True); - // Invalidate entire tree if it scrolled e.g. to make the last node also the - // bottom node in the treeview. - if (LastLeft <> FOffsetX) or (LastTop <> FOffsetY) then - Invalidate; - end; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.DeleteSelectedNodes; - -// Deletes all currently selected nodes (including their child nodes). - -var - Nodes: TNodeArray; - I: Integer; - LevelChange: Boolean; - -begin - Nodes := nil; - if (FSelectionCount > 0) and not (toReadOnly in FOptions.FMiscOptions) then - begin - BeginUpdate; - try - Nodes := GetSortedSelection(True); - for I := High(Nodes) downto 1 do - begin - LevelChange := Nodes[I].Parent <> Nodes[I - 1].Parent; - DeleteNode(Nodes[I], LevelChange); - end; - DeleteNode(Nodes[0]); - finally - EndUpdate; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.Dragging: Boolean; - -begin - // Check for both OLE drag'n drop as well as VCL drag'n drop. - Result := ([tsOLEDragPending, tsOLEDragging] * FStates <> []) or inherited Dragging; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.EditNode(Node: PVirtualNode; Column: TColumnIndex): Boolean; - -// Application triggered edit event for the given node. -// Returns True if the tree started editing otherwise False. - -begin - Assert(Assigned(Node), 'Node must not be nil.'); - Assert((Column > InvalidColumn) and (Column < FHeader.Columns.Count), - 'Column must be a valid column index (-1 if no header is shown).'); - - Result := tsEditing in FStates; - // If the tree is already editing then we don't disrupt this. - if not Result and not (toReadOnly in FOptions.FMiscOptions) then - begin - FocusedNode := Node; - if Assigned(FFocusedNode) and (Node = FFocusedNode) and CanEdit(FFocusedNode, Column) then - begin - FEditColumn := Column; - if not (vsInitialized in Node.States) then - InitNode(Node); - DoEdit; - Result := tsEditing in FStates; - end - else - Result := False; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.EndEditNode: Boolean; - -// Called to finish a current edit action or stop the edit timer if an edit operation is pending. - -begin - if [tsEditing, tsEditPending] * FStates <> [] then - Result := DoEndEdit - else - Result := True; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.EndSynch; - -begin - if FSynchUpdateCount > 0 then - Dec(FSynchUpdateCount); - - if not (csDestroying in ComponentState) then - begin - if FSynchUpdateCount = 0 then - begin - DoStateChange([], [tsSynchMode]); - DoUpdating(usEndSynch); - end - else - DoUpdating(usSynch); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.EndUpdate; - -var - NewSize: Integer; - -begin - if FUpdateCount > 0 then - Dec(FUpdateCount); - - if not (csDestroying in ComponentState) then - begin - if (FUpdateCount = 0) and (tsUpdating in FStates) then - begin - if tsUpdateHiddenChildrenNeeded in FStates then - begin - DetermineHiddenChildrenFlagAllNodes; - Exclude(FStates, tsUpdateHiddenChildrenNeeded); - end; - - DoStateChange([], [tsUpdating]); - - NewSize := PackArray(FSelection, FSelectionCount); - if NewSize > -1 then - begin - FSelectionCount := NewSize; - SetLength(FSelection, FSelectionCount); - end; - - InvalidateCache; - ValidateCache; - if HandleAllocated then - UpdateScrollBars(False); - - if tsStructureChangePending in FStates then - DoStructureChange(FLastStructureChangeNode, FLastStructureChangeReason); - if tsChangePending in FStates then - DoChange(FLastChangedNode); - - if toAutoSort in FOptions.FAutoOptions then - SortTree(FHeader.FSortColumn, FHeader.FSortDirection, True); - - SetUpdateState(False); - if HandleAllocated then - Invalidate; - UpdateDesigner; - end; - - if FUpdateCount = 0 then - DoUpdating(usEnd) - else - DoUpdating(usUpdate); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.ExecuteAction(Action: TBasicAction): Boolean; - -// Some support for standard actions. - -begin - Result := inherited ExecuteAction(Action); - - if not Result then - begin - {$ifdef COMPILER_5_UP} - Result := Action is TEditSelectAll; - if Result then - SelectAll(False) - else - begin - {$endif COMPILER_5_UP} - Result := Action is TEditCopy; - if Result then - CopyToClipboard - else - if not (toReadOnly in FOptions.FMiscOptions) then - begin - Result := Action is TEditCut; - if Result then - CutToClipBoard - else - begin - Result := Action is TEditPaste; - if Result then - PasteFromClipboard - {$ifdef COMPILER_5_UP} - else - begin - Result := Action is TEditDelete; - if Result then - DeleteSelectedNodes - end; - {$endif COMPILER_5_UP} - end; - end; - {$ifdef COMPILER_5_UP} - end; - {$endif COMPILER_5_UP} - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.FinishCutOrCopy; - -// Deletes nodes which are marked as being cutted. - -var - Run: PVirtualNode; - -begin - if tsCutPending in FStates then - begin - Run := FRoot.FirstChild; - while Assigned(Run) do - begin - if vsCutOrCopy in Run.States then - DeleteNode(Run); - Run := GetNextNoInit(Run); - end; - DoStateChange([], [tsCutPending]); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.FlushClipboard; - -// Used to render the data which is currently on the clipboard (finishes delayed rendering). - -begin - if ClipboardStates * FStates <> [] then - begin - DoStateChange([tsClipboardFlushing]); - OleFlushClipboard; - CancelCutOrCopy; - DoStateChange([], [tsClipboardFlushing]); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.FullCollapse(Node: PVirtualNode = nil); - -// This routine collapses all expanded nodes in the subtree given by Node or the whole tree if Node is FRoot or nil. -// Only nodes which are expanded will be collapsed. This excludes uninitialized nodes but nodes marked as visible -// will still be collapsed if they are expanded. - -var - Stop: PVirtualNode; - -begin - if FRoot.TotalCount > 1 then - begin - if Node = FRoot then - Node := nil; - - DoStateChange([tsCollapsing]); - BeginUpdate; - try - Stop := Node; - Node := GetLastVisibleNoInit(Node); - - if Assigned(Node) then - begin - repeat - if [vsHasChildren, vsExpanded] * Node.States = [vsHasChildren, vsExpanded] then - ToggleNode(Node); - Node := GetPreviousNoInit(Node); - until Node = Stop; - - // Collapse the start node too. - if Assigned(Node) and ([vsHasChildren, vsExpanded] * Node.States = [vsHasChildren, vsExpanded]) then - ToggleNode(Node); - end; - finally - EndUpdate; - DoStateChange([], [tsCollapsing]); - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.FullExpand(Node: PVirtualNode = nil); - -// This routine expands all collapsed nodes in the subtree given by Node or the whole tree if Node is FRoot or nil. -// All nodes on the way down are initialized so this procedure might take a long time. -// Since all nodes are validated, the tree cannot make use of optimatizations. Hence it is counter productive and you -// should consider avoiding its use. - -var - Stop: PVirtualNode; - -begin - if FRoot.TotalCount > 1 then - begin - DoStateChange([tsExpanding]); - BeginUpdate; - try - if Node = nil then - begin - Node := FRoot.FirstChild; - Stop := nil; - end - else - begin - Stop := Node.NextSibling; - if Stop = nil then - begin - Stop := Node; - repeat - Stop := Stop.Parent; - until (Stop = FRoot) or Assigned(Stop.NextSibling); - if Stop = FRoot then - Stop := nil - else - Stop := Stop.NextSibling; - end; - end; - - // Initialize the start node. Others will be initialized in GetNext. - if not (vsInitialized in Node.States) then - InitNode(Node); - - repeat - if not (vsExpanded in Node.States) then - ToggleNode(Node); - Node := GetNext(Node); - until Node = Stop; - finally - EndUpdate; - DoStateChange([], [tsExpanding]); - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -{$ifndef fpc} - -function TBaseVirtualTree.GetControlsAlignment: TAlignment; - -begin - Result := FAlignment; -end; - -{$endif} -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetDisplayRect(Node: PVirtualNode; Column: TColumnIndex; TextOnly: Boolean; - Unclipped: Boolean = False): TRect; - -// Determines the client coordinates the given node covers, depending on scrolling, expand state etc. -// If the given node cannot be found (because one of its parents is collapsed or it is invisible) then an empty -// rectangle is returned. -// If TextOnly is True then only the text bounds are returned, that is, the resulting rectangle's left and right border -// are updated according to bidi mode, alignment and text width of the node. -// If Unclipped is True (which only makes sense if also TextOnly is True) then the calculated text rectangle is -// not clipped if the text does not entirely fit into the text space. This is special handling needed for hints. -// If Column is -1 then the entire client width is used before determining the node's width otherwise the bounds of the -// particular column are used. -// Note: Column must be a valid column and is used independent of whether the header is visible or not. - -var - Temp: PVirtualNode; - Offset: Cardinal; - Indent, - TextWidth: Integer; - MainColumnHit: Boolean; - CurrentBidiMode: TBidiMode; - CurrentAlignment: TAlignment; - -begin - Assert(Assigned(Node), 'Node must not be nil.'); - Assert(Node <> FRoot, 'Node must not be the hidden root node.'); - - MainColumnHit := (Column + 1) in [0, FHeader.MainColumn + 1]; - if not (vsInitialized in Node.States) then - InitNode(Node); - - Result := Rect(0, 0, 0, 0); - - // Check whether the node is visible (determine indentation level btw.). - Temp := Node; - Indent := 0; - while Temp <> FRoot do - begin - if not (vsVisible in Temp.States) or not (vsExpanded in Temp.Parent.States) then - Exit; - Temp := Temp.Parent; - if MainColumnHit and (Temp <> FRoot) then - Inc(Indent, FIndent); - end; - - // Here we know the node is visible. - Offset := 0; - if tsUseCache in FStates then - begin - // If we can use the position cache then do a binary search to find a cached node which is as close as possible - // to the current node. Iterate then through all following and visible nodes and sum up their heights. - Temp := FindInPositionCache(Node, Offset); - while Assigned(Temp) and (Temp <> Node) do - begin - Inc(Offset, NodeHeight[Temp]); - Temp := GetNextVisibleNoInit(Temp); - end; - end - else - begin - // If the cache is not available then go straight through all nodes up to the root and sum up their heights. - Temp := Node; - repeat - Temp := GetPreviousVisibleNoInit(Temp); - if Temp = nil then - Break; - Inc(Offset, NodeHeight[Temp]); - until False; - end; - - Result := Rect(0, Offset, Max(FRangeX, ClientWidth), Offset + NodeHeight[Node]); - - // Limit left and right bounds to the given column (if any) and move bounds according to current scroll state. - if Column > NoColumn then - begin - FHeader.FColumns.GetColumnBounds(Column, Result.Left, Result.Right); - // The right column border is not part of this cell. - Dec(Result.Right); - OffsetRect(Result, 0, FOffsetY); - end - else - OffsetRect(Result, -FEffectiveOffsetX, FOffsetY); - - // Limit left and right bounds further if only the text area is required. - if TextOnly then - begin - // Start with the offset of the text in the column and consider the indentation level too. - Offset := FMargin + Indent; - // If the text of a node is involved then we have to consider directionality and alignment too. - if Column = NoColumn then - begin - CurrentBidiMode := BidiMode; - CurrentAlignment := Alignment; - end - else - begin - CurrentBidiMode := FHeader.FColumns[Column].BidiMode; - CurrentAlignment := FHeader.FColumns[Column].Alignment; - end; - - TextWidth := DoGetNodeWidth(Node, Column); - - if MainColumnHit then - begin - if toShowRoot in FOptions.FPaintOptions then - Inc(Offset, FIndent); - if (toCheckSupport in FOptions.FMiscOptions) and Assigned(FCheckImages) and (Node.CheckType <> ctNone) then - Inc(Offset, FCheckImages.Width + 2); - end; - // Consider associated images. - if Assigned(FStateImages) and HasImage(Node, ikState, Column) then - Inc(Offset, FStateImages.Width + 2); - if Assigned(FImages) and HasImage(Node, ikNormal, Column) then - Inc(Offset, FImages.Width + 2); - - // Offset contains now the distance from the left or right border of the rectangle (depending on bidi mode). - // Now consider the alignment too and calculate the final result. - if CurrentBidiMode = bdLeftToRight then - begin - Inc(Result.Left, Offset); - // Left-to-right reading does not need any special adjustment of the alignment. - end - else - begin - Dec(Result.Right, Offset); - - // Consider bidi mode here. In RTL context does left alignment actually mean right alignment and vice versa. - ChangeBiDiModeAlignment(CurrentAlignment); - end; - - if Unclipped then - begin - // The caller requested the text coordinates unclipped. This means they must be calculated so as would - // there be enough space, regardless of column bounds etc. - // The layout still depends on the available space too, because this determines the position - // of the unclipped text rectangle. - if Result.Right - Result.Left < TextWidth then - if CurrentBidiMode = bdLeftToRight then - CurrentAlignment := taLeftJustify - else - CurrentAlignment := taRightJustify; - - case CurrentAlignment of - taCenter: - begin - Result.Left := (Result.Left + Result.Right - TextWidth) div 2; - Result.Right := Result.Left + TextWidth; - end; - taRightJustify: - Result.Left := Result.Right - TextWidth; - else // taLeftJustify - Result.Right := Result.Left + TextWidth; - end; - end - else - // Modify rectangle only if the text fits entirely into the given room. - if Result.Right - Result.Left > TextWidth then - case CurrentAlignment of - taCenter: - begin - Result.Left := (Result.Left + Result.Right - TextWidth) div 2; - Result.Right := Result.Left + TextWidth; - end; - taRightJustify: - Result.Left := Result.Right - TextWidth; - else // taLeftJustify - Result.Right := Result.Left + TextWidth; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetFirst: PVirtualNode; - -// Returns the first node in the tree. - -begin - Result := FRoot.FirstChild; - if Assigned(Result) and not (vsInitialized in Result.States) then - InitNode(Result); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetFirstChecked(State: TCheckState): PVirtualNode; - -// Returns the first node in the tree with the given check state. - -begin - Result := GetNextChecked(nil, State); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetFirstChild(Node: PVirtualNode): PVirtualNode; - -// Returns the first child of the given node. The result node is initialized before exit. - -begin - if (Node = nil) or (Node = FRoot) then - Result := FRoot.FirstChild - else - begin - if not (vsInitialized in Node.States) then - InitNode(Node); - if vsHasChildren in Node.States then - begin - if Node.ChildCount = 0 then - InitChildren(Node); - Result := Node.FirstChild; - end - else - Result := nil; - end; - - if Assigned(Result) and not (vsInitialized in Result.States) then - InitNode(Result); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetFirstCutCopy: PVirtualNode; - -// Returns the first node in the tree which is currently marked for a clipboard operation. -// See also GetNextCutCopy for comments on initialization. - -begin - Result := GetNextCutCopy(nil); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetFirstInitialized: PVirtualNode; - -// Returns the first node which is already initialized. - -begin - Result := FRoot.FirstChild; - if Assigned(Result) and not (vsInitialized in Result.States) then - Result := GetNextInitialized(Result); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetFirstNoInit: PVirtualNode; - -begin - Result := FRoot.FirstChild; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetFirstSelected: PVirtualNode; - -// Returns the first node in the current selection. - -begin - Result := GetNextSelected(nil); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetFirstVisible: PVirtualNode; - -// Returns the first visible node in the tree. If necessary nodes are initialized on demand. - -begin - if vsHasChildren in FRoot.States then - begin - Result := FRoot; - - if Result.ChildCount = 0 then - InitChildren(Result); - - // Child nodes are the first choice if possible. - if Assigned(Result.FirstChild) then - begin - Result := GetFirstChild(Result); - - // If there are no children or the first child is not visible then search the sibling nodes or traverse parents. - if not (vsVisible in Result.States) then - begin - repeat - // Is there a next sibling? - if Assigned(Result.NextSibling) then - begin - Result := Result.NextSibling; - // The visible state can be removed during initialization so init the node first. - if not (vsInitialized in Result.States) then - InitNode(Result); - if vsVisible in Result.States then - Break; - end - else - begin - // No sibling anymore, so use the parent's next sibling. - if Result.Parent <> FRoot then - Result := Result.Parent - else - begin - // There are no further nodes to examine, hence there is no further visible node. - Result := nil; - Break; - end; - end; - until False; - end; - end - else - Result := nil; - end - else - Result := nil; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetFirstVisibleChild(Node: PVirtualNode): PVirtualNode; - -// Returns the first visible child node of Node. If necessary nodes are initialized on demand. - -begin - Result := GetFirstChild(Node); - if Assigned(Result) and not (vsVisible in Result.States) then - Result := GetNextVisibleSibling(Result); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetFirstVisibleChildNoInit(Node: PVirtualNode): PVirtualNode; - -// Returns the first visible child node of Node. - -begin - if Node = nil then - Node := FRoot; - Result := Node.FirstChild; - if Assigned(Result) and not (vsVisible in Result.States) then - Result := GetNextVisibleSiblingNoInit(Result); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetFirstVisibleNoInit: PVirtualNode; - -// Returns the first visible node in the tree. No initialization is performed. - -begin - if vsHasChildren in FRoot.States then - begin - Result := FRoot; - - // Child nodes are the first choice if possible. - if Assigned(Result.FirstChild) then - begin - Result := Result.FirstChild; - - // If there are no children or the first child is not visible then search the sibling nodes or traverse parents. - if not (vsVisible in Result.States) then - begin - repeat - // Is there a next sibling? - if Assigned(Result.NextSibling) then - begin - Result := Result.NextSibling; - if vsVisible in Result.States then - Break; - end - else - begin - // No sibling anymore, so use the parent's next sibling. - if Result.Parent <> FRoot then - Result := Result.Parent - else - begin - // There are no further nodes to examine, hence there is no further visible node. - Result := nil; - Break; - end; - end; - until False; - end; - end - else - Result := nil; - end - else - Result := nil; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.GetHitTestInfoAt(X, Y: Integer; Relative: Boolean; var HitInfo: THitInfo); - -// Determines the node that occupies the specified point or nil if there's none. The parameter Relative determines -// whether to consider X and Y as being client coordinates (if True) or as being absolute tree coordinates. -// HitInfo is filled with flags describing the hit further. - -var - ColLeft, - ColRight: Integer; - NodeTop: Integer; - InitialColumn, - NextColumn: TColumnIndex; - CurrentBidiMode: TBidiMode; - CurrentAlignment: TAlignment; - -begin - HitInfo.HitNode := nil; - HitInfo.HitPositions := []; - HitInfo.HitColumn := NoColumn; - - // Determine if point lies in the tree's client area. - if X < 0 then - Include(HitInfo.HitPositions, hiToLeft) - else - if X > Max(FRangeX, ClientWidth) then - Include(HitInfo.HitPositions, hiToRight); - - if Y < 0 then - Include(HitInfo.HitPositions, hiAbove) - else - if Y > Max(FRangeY, ClientHeight) then - Include(HitInfo.HitPositions, hiBelow); - - // Convert position into absolute coordinate if necessary. - if Relative then - begin - if X > Header.Columns.GetVisibleFixedWidth then - Inc(X, FEffectiveOffsetX); - Inc(Y, -FOffsetY); - end; - - // If the point is in the tree area then check the nodes. - if HitInfo.HitPositions = [] then - begin - HitInfo.HitNode := GetNodeAt(X, Y, False, NodeTop); - if HitInfo.HitNode = nil then - Include(HitInfo.HitPositions, hiNowhere) - else - begin - // At this point we need some info about the node, so it must be initialized. - if not (vsInitialized in HitInfo.HitNode.States) then - InitNode(HitInfo.HitNode); - - if FHeader.UseColumns then - begin - 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.FAutoOptions then - begin - InitialColumn := HitInfo.HitColumn; - // Search to the left of the hit column for empty columns. - while (HitInfo.HitColumn > NoColumn) and ColumnIsEmpty(HitInfo.HitNode, HitInfo.HitColumn) do - begin - NextColumn := FHeader.FColumns.GetPreviousVisibleColumn(HitInfo.HitColumn); - if NextColumn = InvalidColumn then - Break; - HitInfo.HitColumn := NextColumn; - Dec(ColLeft, FHeader.FColumns[NextColumn].Width); - end; - // Search to the right of the hit column for empty columns. - repeat - InitialColumn := FHeader.FColumns.GetNextVisibleColumn(InitialColumn); - if (InitialColumn = InvalidColumn) or not ColumnIsEmpty(HitInfo.HitNode, InitialColumn) then - Break; - Inc(ColRight, FHeader.FColumns[InitialColumn].Width); - until False; - end; - // Make the X position and the right border relative to the start of the column. - Dec(X, ColLeft); - Dec(ColRight, ColLeft); - end - else - begin - HitInfo.HitColumn := NoColumn; - ColRight := Max(FRangeX, ClientWidth); - end; - ColLeft := 0; - - if HitInfo.HitColumn = InvalidColumn then - Include(HitInfo.HitPositions, hiNowhere) - else - begin - // From now on X is in "column" coordinates (relative to the left column border). - HitInfo.HitPositions := [hiOnItem]; - if HitInfo.HitColumn = NoColumn then - begin - CurrentBidiMode := BidiMode; - CurrentAlignment := Alignment; - end - else - begin - CurrentBidiMode := FHeader.FColumns[HitInfo.HitColumn].BidiMode; - CurrentAlignment := FHeader.FColumns[HitInfo.HitColumn].Alignment; - end; - - if CurrentBidiMode = bdLeftToRight then - DetermineHitPositionLTR(HitInfo, X, ColRight, CurrentAlignment) - else - DetermineHitPositionRTL(HitInfo, X, ColRight, CurrentAlignment); - end; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetLast(Node: PVirtualNode = nil): PVirtualNode; - -// Returns the very last node in the tree branch given by Node and initializes the nodes all the way down including the -// result. By using Node = nil the very last node in the tree is returned. - -var - Next: PVirtualNode; - -begin - Result := GetLastChild(Node); - while Assigned(Result) do - begin - // Test if there is a next last child. If not keep the node from the last run. - // Otherwise use the next last child. - Next := GetLastChild(Result); - if Next = nil then - Break; - Result := Next; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetLastInitialized(Node: PVirtualNode): PVirtualNode; - -// Returns the very last initialized child node in the tree branch given by Node. - -begin - Result := GetLastNoInit(Node); - if Assigned(Result) and not (vsInitialized in Result.States) then - Result := GetPreviousInitialized(Result); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetLastNoInit(Node: PVirtualNode = nil): PVirtualNode; - -// Returns the very last node in the tree branch given by Node without initialization. - -var - Next: PVirtualNode; - -begin - Result := GetLastChildNoInit(Node); - while Assigned(Result) do - begin - // Test if there is a next last child. If not keep the node from the last run. - // Otherwise use the next last child. - Next := GetLastChildNoInit(Result); - if Next = nil then - Break; - Result := Next; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetLastChild(Node: PVirtualNode): PVirtualNode; - -// Determines the last child of the given node and initializes it if there is one. - -begin - if (Node = nil) or (Node = FRoot) then - Result := FRoot.LastChild - else - begin - if not (vsInitialized in Node.States) then - InitNode(Node); - if vsHasChildren in Node.States then - begin - if Node.ChildCount = 0 then - InitChildren(Node); - Result := Node.LastChild; - end - else - Result := nil; - end; - - if Assigned(Result) and not (vsInitialized in Result.States) then - InitNode(Result); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetLastChildNoInit(Node: PVirtualNode): PVirtualNode; - -// Determines the last child of the given node but does not initialize it. - -begin - if (Node = nil) or (Node = FRoot) then - Result := FRoot.LastChild - else - begin - if vsHasChildren in Node.States then - Result := Node.LastChild - else - Result := nil; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetLastVisible(Node: PVirtualNode = nil): PVirtualNode; - -// Returns the very last visible node in the tree and initializes nodes all the way down including the result node. - -var - Next: PVirtualNode; - -begin - Result := GetLastVisibleChild(Node); - while Assigned(Result) do - begin - // Test if there is a next last visible child. If not keep the node from the last run. - // Otherwise use the next last visible child. - Next := GetLastVisibleChild(Result); - if Next = nil then - Break; - Result := Next; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetLastVisibleChild(Node: PVirtualNode): PVirtualNode; - -// Determines the last visible child of the given node and initializes it if necessary. - -begin - if (Node = nil) or (Node = FRoot) then - Result := GetLastChild(FRoot) - else - if FullyVisible[Node] and (vsExpanded in Node.States) then - Result := GetLastChild(Node) - else - Result := nil; - - if Assigned(Result) and not (vsVisible in Result.States) then - Result := GetPreviousVisibleSibling(Result); - - if Assigned(Result) and not (vsInitialized in Result.States) then - InitNode(Result); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetLastVisibleChildNoInit(Node: PVirtualNode): PVirtualNode; - -// Determines the last visible child of the given node without initialization. - -begin - if (Node = nil) or (Node = FRoot) then - Result := GetLastChildNoInit(FRoot) - else - if FullyVisible[Node] and (vsExpanded in Node.States) then - Result := GetLastChildNoInit(Node) - else - Result := nil; - - if Assigned(Result) and not (vsVisible in Result.States) then - Result := GetPreviousVisibleSiblingNoInit(Result); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetLastVisibleNoInit(Node: PVirtualNode = nil): PVirtualNode; - -// Returns the very last visible node in the tree without initialization. - -var - Next: PVirtualNode; - -begin - Result := GetLastVisibleChildNoInit(Node); - while Assigned(Result) do - begin - // Test if there is a next last visible child. If not keep the node from the last run. - // Otherwise use the next last visible child. - Next := GetLastVisibleChildNoInit(Result); - if Next = nil then - Break; - Result := Next; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetMaxColumnWidth(Column: TColumnIndex): Integer; - -// This method determines the width of the largest node in the given column. -// Note: Every visible node in the tree will be initialized contradicting so the virtual paradigm. - -var - Run, - NextNode: PVirtualNode; - NodeLeft, - TextLeft, - CurrentWidth: Integer; - WithCheck, - WithImages, - WithStateImages: Boolean; - CheckOffset, - ImageOffset, - StateImageOffset: Integer; - -begin - Result := 0; - - // Don't check the event here as descendant trees might have overriden the DoGetImageIndex method. - WithImages := Assigned(FImages); - if WithImages then - ImageOffset := FImages.Width + 2 - else - ImageOffset := 0; - WithStateImages := Assigned(FStateImages); - if WithStateImages then - StateImageOffset := FStateImages.Width + 2 - else - StateImageOffset := 0; - if Assigned(FCheckImages) then - CheckOffset := FCheckImages.Width + 2 - else - CheckOffset := 0; - - Run := GetFirstVisible; - if Column = FHeader.MainColumn then - begin - if toShowRoot in FOptions.FPaintOptions then - NodeLeft := Integer((GetNodeLevel(Run) + 1) * FIndent) - else - NodeLeft := Integer(GetNodeLevel(Run) * FIndent); - - WithCheck := (toCheckSupport in FOptions.FMiscOptions) and Assigned(FCheckImages); - end - else - begin - NodeLeft := 0; - WithCheck := False; - end; - - // Consider node margin at the left of the nodes. - Inc(NodeLeft, FMargin); - - while Assigned(Run) do - begin - TextLeft := NodeLeft; - if WithCheck and (Run.CheckType <> ctNone) then - Inc(TextLeft, CheckOffset); - if WithImages and HasImage(Run, ikNormal, Column) then - Inc(TextLeft, ImageOffset); - if WithStateImages and HasImage(Run, ikState, Column) then - Inc(TextLeft, StateImageOffset); - - CurrentWidth := DoGetNodeWidth(Run, Column); - - if Result < (TextLeft + CurrentWidth) then - Result := TextLeft + CurrentWidth; - - // Get next visible node and update left node position if needed. - NextNode := GetNextVisible(Run); - if NextNode = nil then - Break; - if Column = Header.MainColumn then - Inc(NodeLeft, CountLevelDifference(Run, NextNode) * Integer(FIndent)); - Run := NextNode; - end; - if toShowVertGridLines in FOptions.FPaintOptions then - Inc(Result) -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetNext(Node: PVirtualNode): PVirtualNode; - -// Returns next node in tree (advances to next sibling of the node's parent or its parent, if necessary). - -begin - Result := Node; - if Assigned(Result) then - begin - Assert(Result <> FRoot, 'Node must not be the hidden root node.'); - - // Has this node got children? - if vsHasChildren in Result.States then - begin - // Yes, there are child nodes. Initialize them if necessary. - if Result.ChildCount = 0 then - InitChildren(Result); - end; - - // if there is no child node try siblings - if Assigned(Result.FirstChild) then - Result := Result.FirstChild - else - begin - repeat - // Is there a next sibling? - if Assigned(Result.NextSibling) then - begin - Result := Result.NextSibling; - Break; - end - else - begin - // No sibling anymore, so use the parent's next sibling. - if Result.Parent <> FRoot then - Result := Result.Parent - else - begin - // There are no further nodes to examine, hence there is no further visible node. - Result := nil; - Break; - end; - end; - until False; - end; - - if Assigned(Result) and not (vsInitialized in Result.States) then - InitNode(Result); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetNextChecked(Node: PVirtualNode; State: TCheckState = csCheckedNormal): PVirtualNode; - -begin - if (Node = nil) or (Node = FRoot) then - Result := FRoot.FirstChild - else - Result := GetNextNoInit(Node); - - while Assigned(Result) and (Result.CheckState <> State) do - Result := GetNextNoInit(Result); - - if Assigned(Result) and not (vsInitialized in Result.States) then - InitNode(Result); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetNextCutCopy(Node: PVirtualNode): PVirtualNode; - -// Returns the next node in the tree which is currently marked for a clipboard operation. Since only visible nodes can -// be marked (or they are hidden after they have been marked) it is not necessary to initialize nodes to check for -// child nodes. The result, however, is initialized if necessary. - -begin - if ClipboardStates * FStates <> [] then - begin - if (Node = nil) or (Node = FRoot) then - Result := FRoot.FirstChild - else - Result := GetNextNoInit(Node); - while Assigned(Result) and not (vsCutOrCopy in Result.States) do - Result := GetNextNoInit(Result); - if Assigned(Result) and not (vsInitialized in Result.States) then - InitNode(Result); - end - else - Result := nil; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetNextInitialized(Node: PVirtualNode): PVirtualNode; - -// Returns the next node in tree which is initialized. - -begin - Result := Node; - repeat - Result := GetNextNoInit(Result); - until (Result = nil) or (vsInitialized in Result.States); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetNextNoInit(Node: PVirtualNode): PVirtualNode; - -// Optimized variant of GetNext, no initialization of nodes is performed (if a node is not initialized -// then it is considered as not being there). - -begin - Result := Node; - if Assigned(Result) then - begin - Assert(Result <> FRoot, 'Node must not be the hidden root node.'); - - // If there is no child node try siblings. - if Assigned(Result.FirstChild) then - Result := Result.FirstChild - else - begin - repeat - // Is there a next sibling? - if Assigned(Result.NextSibling) then - begin - Result := Result.NextSibling; - Break; - end - else - begin - // No sibling anymore, so use the parent's next sibling. - if Result.Parent <> FRoot then - Result := Result.Parent - else - begin - // There are no further nodes to examine, hence there is no further visible node. - Result := nil; - Break; - end; - end; - until False; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetNextSelected(Node: PVirtualNode): PVirtualNode; - -// Returns the next node in the tree which is currently selected. Since children of unitialized nodes cannot be -// in the current selection (because they simply do not exist yet) it is not necessary to initialize nodes here. -// The result however is initialized if necessary. - -begin - if FSelectionCount > 0 then - begin - if (Node = nil) or (Node = FRoot) then - Result := FRoot.FirstChild - else - Result := GetNextNoInit(Node); - while Assigned(Result) and not (vsSelected in Result.States) do - Result := GetNextNoInit(Result); - if Assigned(Result) and not (vsInitialized in Result.States) then - InitNode(Result); - end - else - Result := nil; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetNextSibling(Node: PVirtualNode): PVirtualNode; - -// Returns the next sibling of Node and initializes it if necessary. - -begin - Result := Node; - if Assigned(Result) then - begin - Assert(Result <> FRoot, 'Node must not be the hidden root node.'); - - Result := Result.NextSibling; - if Assigned(Result) and not (vsInitialized in Result.States) then - InitNode(Result); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetNextVisible(Node: PVirtualNode): PVirtualNode; - -// Returns next node in tree, with regard to Node, which is visible. -// Nodes which need an initialization (including the result) are initialized. - -var - ForceSearch: Boolean; - -begin - Result := Node; - if Assigned(Result) then - begin - Assert(Result <> FRoot, 'Node must not be the hidden root node.'); - - // If the given node is not visible then look for a parent node which is visible, otherwise we will - // likely go unnecessarily through a whole bunch of invisible nodes. - if not FullyVisible[Result] then - Result := GetVisibleParent(Result); - - // Has this node got children? - if [vsHasChildren, vsExpanded] * Result.States = [vsHasChildren, vsExpanded] then - begin - // Yes, there are child nodes. Initialize them if necessary. - if Result.ChildCount = 0 then - InitChildren(Result); - end; - - // Child nodes are the first choice if possible. - if (vsExpanded in Result.States) and Assigned(Result.FirstChild) then - begin - Result := GetFirstChild(Result); - ForceSearch := False; - end - else - ForceSearch := True; - - // If there are no children or the first child is not visible then search the sibling nodes or traverse parents. - if Assigned(Result) and (ForceSearch or not (vsVisible in Result.States)) then - begin - repeat - // Is there a next sibling? - if Assigned(Result.NextSibling) then - begin - Result := Result.NextSibling; - if not (vsInitialized in Result.States) then - InitNode(Result); - if vsVisible in Result.States then - Break; - end - else - begin - // No sibling anymore, so use the parent's next sibling. - if Result.Parent <> FRoot then - Result := Result.Parent - else - begin - // There are no further nodes to examine, hence there is no further visible node. - Result := nil; - Break; - end; - end; - until False; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetNextVisibleNoInit(Node: PVirtualNode): PVirtualNode; - -// Returns the next node in tree, with regard to Node, which is visible. -// No initialization is done. - -var - ForceSearch: Boolean; - -begin - Result := Node; - if Assigned(Result) then - begin - Assert(Result <> FRoot, 'Node must not be the hidden root node.'); - - // If the given node is not visible then look for a parent node which is visible, otherwise we will - // likely go unnecessarily through a whole bunch of invisible nodes. - if not FullyVisible[Result] then - Result := GetVisibleParent(Result); - - // Child nodes are the first choice if possible. - if (vsExpanded in Result.States) and Assigned(Result.FirstChild) then - begin - Result := Result.FirstChild; - ForceSearch := False; - end - else - ForceSearch := True; - - // If there are no children or the first child is not visible then search the sibling nodes or traverse parents. - if ForceSearch or not (vsVisible in Result.States) then - begin - repeat - // Is there a next sibling? - if Assigned(Result.NextSibling) then - begin - Result := Result.NextSibling; - if vsVisible in Result.States then - Break; - end - else - begin - // No sibling anymore, so use the parent's next sibling. - if Result.Parent <> FRoot then - Result := Result.Parent - else - begin - // There are no further nodes to examine, hence there is no further visible node. - Result := nil; - Break; - end; - end; - until False; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetNextVisibleSibling(Node: PVirtualNode): PVirtualNode; - -// Returns the next visible sibling after Node. Initialization is done implicitly. - -begin - Assert(Assigned(Node) and (Node <> FRoot), 'Invalid parameter.'); - - Result := Node; - repeat - Result := GetNextSibling(Result); - until (Result = nil) or (vsVisible in Result.States); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetNextVisibleSiblingNoInit(Node: PVirtualNode): PVirtualNode; - -// Returns the next visible sibling after Node. - -begin - Assert(Assigned(Node) and (Node <> FRoot), 'Invalid parameter.'); - - Result := Node; - repeat - Result := Result.NextSibling; - until (Result = nil) or (vsVisible in Result.States); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetNodeAt(X, Y: Integer): PVirtualNode; - -// Overloaded variant of GetNodeAt to easy life of application developers which do not need to have the exact -// top position returned and always use client coordinates. - -var - Dummy: Integer; - -begin - Result := GetNodeAt(X, Y, True, Dummy); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetNodeAt(X, Y: Integer; Relative: Boolean; var NodeTop: Integer): PVirtualNode; - -// This method returns the node that occupies the specified point, or nil if there's none. -// If Releative is True then X and Y are given in client coordinates otherwise they are considered as being -// absolute values into the virtual tree image (regardless of the current offsets in the tree window). -// NodeTop gets the absolute or relative top position of the node returned or is untouched if no node -// could be found. - -var - AbsolutePos, - CurrentPos: Cardinal; - -begin - if Y < 0 then - Y := 0; - - AbsolutePos := Y; - if Relative then - Inc(AbsolutePos, -FOffsetY); - - // CurrentPos tracks a running term of the current position to test for. - // It corresponds always to the top position of the currently considered node. - CurrentPos := 0; - - // If the cache is available then use it. - if tsUseCache in FStates then - Result := FindInPositionCache(AbsolutePos, CurrentPos) - else - Result := GetFirstVisibleNoInit; - - // Determine node, of which position and height corresponds to the scroll position most closely. - while Assigned(Result) and (Result <> FRoot) do - begin - if (vsVisible in Result.States) and (AbsolutePos < (CurrentPos + Result.TotalHeight)) then - begin - // Found a node which covers the given position. Now go down one level - // and search its children (if any, otherwise stop looking). - if (AbsolutePos >= CurrentPos + NodeHeight[Result]) and Assigned(Result.FirstChild) and - (vsExpanded in Result.States) then - begin - Inc(CurrentPos, NodeHeight[Result]); - Result := Result.FirstChild; - Continue; - end - else - Break; - end - else - begin - // Advance current position to after the current node, if the node is visible. - if vsVisible in Result.States then - Inc(CurrentPos, Result.TotalHeight); - // Find following node not being a child of the currently considered node (e.g. a sibling or parent). - repeat - // Is there a next sibling? - if Assigned(Result.NextSibling) then - begin - Result := Result.NextSibling; - if vsVisible in Result.States then - Break; - end - else - begin - // No sibling anymore, so use the parent's next sibling. - if Result.Parent <> FRoot then - Result := Result.Parent - else - begin - // There are no further nodes to examine, hence there is no further visible node. - Result := nil; - Break; - end; - end; - until False; - end; - end; - - if Result = FRoot then - Result := nil; - - // Since the given vertical position is likely not the same as the top position - // of the found node this top position is returned. - if Assigned(Result) then - begin - NodeTop := CurrentPos; - if Relative then - Inc(NodeTop, FOffsetY); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetNodeData(Node: PVirtualNode): Pointer; - -// Returns the address of the user defined data area in the node. - -begin - Assert(FNodeDataSize > 0, 'NodeDataSize not initialized.'); - - if (FNodeDataSize <= 0) or (Node = nil) or (Node = FRoot) then - Result := nil - else - Result := PChar(@Node.Data) + FTotalInternalDataSize; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetNodeLevel(Node: PVirtualNode): Cardinal; - -// returns the level of the given node - -var - Run: PVirtualNode; - -begin - Result := 0; - if Assigned(Node) and (Node <> FRoot) then - begin - Run := Node.Parent; - while Run <> FRoot do - begin - Run := Run.Parent; - Inc(Result); - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetPrevious(Node: PVirtualNode): PVirtualNode; - -// Resturns previous node in tree with regard to Node. The result node is initialized if necessary. - -begin - Result := Node; - if Assigned(Result) then - begin - Assert(Result <> FRoot, 'Node must not be the hidden root node.'); - - // Is there a previous sibling? - if Assigned(Node.PrevSibling) then - begin - // Go down and find the last child node. - Result := GetLast(Node.PrevSibling); - if Result = nil then - Result := Node.PrevSibling; - end - else - // no previous sibling so the parent of the node is the previous visible node - if Node.Parent <> FRoot then - Result := Node.Parent - else - Result := nil; - - if Assigned(Result) and not (vsInitialized in Result.States) then - InitNode(Result); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetPreviousInitialized(Node: PVirtualNode): PVirtualNode; - -// Returns the previous node in tree which is initialized. - -begin - Result := Node; - repeat - Result := GetPreviousNoInit(Result); - until (Result = nil) or (vsInitialized in Result.States); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetPreviousNoInit(Node: PVirtualNode): PVirtualNode; - -// Returns the previous node in the tree with regard to Node. No initialization in done, hence this -// method might be faster than GetPrevious. Not yet initialized nodes are ignored during search. - -begin - Result := Node; - if Assigned(Result) then - begin - Assert(Result <> FRoot, 'Node must not be the hidden root node.'); - - // Is there a previous sibling? - if Assigned(Node.PrevSibling) then - begin - // Go down and find the last child node. - Result := GetLastNoInit(Node.PrevSibling); - if Result = nil then - Result := Node.PrevSibling; - end - else - // No previous sibling so the parent of the node is the previous node. - if Node.Parent <> FRoot then - Result := Node.Parent - else - Result := nil - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetPreviousSibling(Node: PVirtualNode): PVirtualNode; - -// Get next sibling of Node, initialize it if necessary. - -begin - Result := Node; - if Assigned(Result) then - begin - Assert(Result <> FRoot, 'Node must not be the hidden root node.'); - - Result := Result.PrevSibling; - if Assigned(Result) and not (vsInitialized in Result.States) then - InitNode(Result); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetPreviousVisible(Node: PVirtualNode): PVirtualNode; - -// Returns the previous node in tree, with regard to Node, which is visible. -// Nodes which need an initialization (including the result) are initialized. - -var - Marker: PVirtualNode; - -begin - Result := Node; - if Assigned(Result) then - begin - Assert(Result <> FRoot, 'Node must not be the hidden root node.'); - - // If the given node is not visible then look for a parent node which is visible and use its last visible - // child or the parent node (if there is no visible child) as result. - if not FullyVisible[Result] then - begin - Result := GetVisibleParent(Result); - if Result = FRoot then - Result := nil; - Marker := GetLastVisible(Result); - if Assigned(Marker) then - Result := Marker; - end - else - begin - repeat - // Is there a previous sibling node? - if Assigned(Result.PrevSibling) then - begin - Result := Result.PrevSibling; - // Initialize the new node and check its visibility. - if not (vsInitialized in Result.States) then - InitNode(Result); - if vsVisible in Result.States then - begin - // If there are visible child nodes then use the last one. - Marker := GetLastVisible(Result); - if Assigned(Marker) then - Result := Marker; - Break; - end; - end - else - begin - // No previous sibling there so the parent node is the nearest previous node. - Result := Result.Parent; - if Result = FRoot then - Result := nil; - Break; - end; - until False; - - if Assigned(Result) and not (vsInitialized in Result.States) then - InitNode(Result); - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetPreviousVisibleNoInit(Node: PVirtualNode): PVirtualNode; - -// Returns the previous node in tree, with regard to Node, which is visible. - -var - Marker: PVirtualNode; - -begin - Result := Node; - if Assigned(Result) then - begin - Assert(Result <> FRoot, 'Node must not be the hidden root node.'); - - // If the given node is not visible then look for a parent node which is visible and use its last visible - // child or the parent node (if there is no visible child) as result. - if not FullyVisible[Result] then - begin - Result := GetVisibleParent(Result); - if Result = FRoot then - Result := nil; - Marker := GetLastVisibleNoInit(Result); - if Assigned(Marker) then - Result := Marker; - end - else - begin - repeat - // Is there a previous sibling node? - if Assigned(Result.PrevSibling) then - begin - Result := Result.PrevSibling; - if vsVisible in Result.States then - begin - // If there are visible child nodes then use the last one. - Marker := GetLastVisibleNoInit(Result); - if Assigned(Marker) then - Result := Marker; - Break; - end; - end - else - begin - // No previous sibling there so the parent node is the nearest previous node. - Result := Result.Parent; - if Result = FRoot then - Result := nil; - Break; - end; - until False; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetPreviousVisibleSibling(Node: PVirtualNode): PVirtualNode; - -// Returns the previous visible sibling before Node. Initialization is done implicitly. - -begin - Assert(Assigned(Node) and (Node <> FRoot), 'Invalid parameter.'); - - Result := Node; - repeat - Result := GetPreviousSibling(Result); - until (Result = nil) or (vsVisible in Result.States); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetPreviousVisibleSiblingNoInit(Node: PVirtualNode): PVirtualNode; - -// Returns the previous visible sibling before Node. - -begin - Assert(Assigned(Node) and (Node <> FRoot), 'Invalid parameter.'); - - Result := Node; - repeat - Result := Result.PrevSibling; - until (Result = nil) or (vsVisible in Result.States); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetSortedCutCopySet(Resolve: Boolean): TNodeArray; - -// Same as GetSortedSelection but with nodes marked as being part in the current cut/copy set (e.g. for clipboard). - -var - Run: PVirtualNode; - Counter: Cardinal; - - //--------------- local function -------------------------------------------- - - procedure IncludeThisNode(Node: PVirtualNode); - - // adds the given node to the result - - var - Len: Cardinal; - - begin - Len := Length(Result); - if Counter = Len then - begin - if Len < 100 then - Len := 100 - else - Len := Len + Len div 10; - SetLength(Result, Len); - end; - Result[Counter] := Node; - Inc(Counter); - end; - - //--------------- end local function ---------------------------------------- - -begin - Run := FRoot.FirstChild; - Counter := 0; - if Resolve then - begin - // Resolving is actually easy: just find the first cutted node in logical order - // and then never go deeper in level than this node as long as there's a sibling node. - // Restart the search for a cutted node (at any level) if there are no further siblings. - while Assigned(Run) do - begin - if vsCutOrCopy in Run.States then - begin - IncludeThisNode(Run); - if Assigned(Run.NextSibling) then - Run := Run.NextSibling - else - begin - // If there are no further siblings then go up one or more levels until a node is - // found or all nodes have been processed. Although we consider here only initialized - // nodes we don't need to make any special checks as only initialized nodes can also be selected. - repeat - Run := Run.Parent; - until (Run = FRoot) or Assigned(Run.NextSibling); - if Run = FRoot then - Break - else - Run := Run.NextSibling; - end; - end - else - Run := GetNextNoInit(Run); - end; - end - else - while Assigned(Run) do - begin - if vsCutOrCopy in Run.States then - IncludeThisNode(Run); - Run := GetNextNoInit(Run); - end; - - // set the resulting array to its real length - SetLength(Result, Counter); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetSortedSelection(Resolve: Boolean): TNodeArray; - -// Returns a list of selected nodes sorted in logical order, that is, as they appear in the tree. -// If Resolve is True then nodes which are children of other selected nodes are not put into the new array. -// This feature is in particuar important when doing drag'n drop as in this case all selected node plus their children -// need to be considered. A selected node which is child (grand child etc.) of another selected node is then -// automatically included and doesn't need to be explicitely mentioned in the returned selection array. -// -// Note: The caller is responsible for freeing the array. Allocation is done here. Usually, though, freeing the array -// doesn't need additional attention as it is automatically freed by Delphi when it gets out of scope. - -var - Run: PVirtualNode; - Counter: Cardinal; - -begin - SetLength(Result, FSelectionCount); - if FSelectionCount > 0 then - begin - Run := FRoot.FirstChild; - Counter := 0; - if Resolve then - begin - // Resolving is actually easy: just find the first selected node in logical order - // and then never go deeper in level than this node as long as there's a sibling node. - // Restart the search for a selected node (at any level) if there are no further siblings. - while Assigned(Run) do - begin - if vsSelected in Run.States then - begin - Result[Counter] := Run; - Inc(Counter); - if Assigned(Run.NextSibling) then - Run := Run.NextSibling - else - begin - // If there are no further siblings then go up one or more levels until a node is - // found or all nodes have been processed. Although we consider here only initialized - // nodes we don't need to make any special checks as only initialized nodes can also be selected. - repeat - Run := Run.Parent; - until (Run = FRoot) or Assigned(Run.NextSibling); - if Run = FRoot then - Break - else - Run := Run.NextSibling; - end; - end - else - Run := GetNextNoInit(Run); - end; - end - else - while Assigned(Run) do - begin - if vsSelected in Run.States then - begin - Result[Counter] := Run; - Inc(Counter); - end; - Run := GetNextNoInit(Run); - end; - - // Since we may have skipped some nodes the result array is likely to be smaller than the - // selection array, hence shorten the result to true length. - if Integer(Counter) < Length(Result) then - SetLength(Result, Counter); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.GetTextInfo(Node: PVirtualNode; Column: TColumnIndex; const AFont: TFont; var R: TRect; - var Text: WideString); - -// Generic base method for editors, hint windows etc. to get some info about a node. - -begin - R := Rect(0, 0, 0, 0); - Text := ''; - AFont.Assign(Font); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetTreeRect: TRect; - -// Returns the true size of the tree in pixels. This size is at least ClientHeight x ClientWidth and depends on -// the expand state, header size etc. -// Note: if no columns are used then the width of the tree is determined by the largest node which is currently in the -// client area. This might however not be the largest node in the entire tree. - -begin - Result := Rect(0, 0, Max(FRangeX, ClientWidth), Max(FRangeY, ClientHeight)); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.GetVisibleParent(Node: PVirtualNode): PVirtualNode; - -// Returns the first (nearest) parent node of Node which is visible. -// This method is one of the seldom cases where the hidden root node could be returned. - -begin - Assert(Assigned(Node), 'Node must not be nil.'); - - Result := Node; - while Result <> FRoot do - begin - // FRoot is always expanded hence the loop will safely stop there if no other node is expanded - repeat - Result := Result.Parent; - until vsExpanded in Result.States; - - if (Result = FRoot) or FullyVisible[Result] then - Break; - - // if there is still a collapsed parent node then advance to it and repeat the entire loop - while (Result <> FRoot) and (vsExpanded in Result.Parent.States) do - Result := Result.Parent; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.HasAsParent(Node, PotentialParent: PVirtualNode): Boolean; - -// Determines whether Node has got PotentialParent as one of its parents. - -var - Run: PVirtualNode; - -begin - Result := Assigned(Node) and Assigned(PotentialParent) and (Node <> PotentialParent); - if Result then - begin - Run := Node; - while (Run <> FRoot) and (Run <> PotentialParent) do - Run := Run.Parent; - Result := Run = PotentialParent; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.InsertNode(Node: PVirtualNode; Mode: TVTNodeAttachMode; UserData: Pointer = nil): PVirtualNode; - -// Adds a new node relative to Node. The final position is determined by Mode. -// UserData can be used to set the first 4 bytes of the user data area to an initial value which can be used -// in OnInitNode and will also cause to trigger the OnFreeNode event (if <> nil) even if the node is not yet -// "officially" initialized. -// InsertNode is a compatibility method and will implicitly validate the given node if the new node -// is to be added as child node. This is however against the virtual paradigm and hence I dissuade from its usage. - -var - NodeData: ^Pointer; - -begin - if Mode <> amNoWhere then - begin - CancelEditNode; - - if Node = nil then - Node := FRoot; - // we need a new node... - Result := MakeNewNode; - // avoid erronous attach modes - if Node = FRoot then - begin - case Mode of - amInsertBefore: - Mode := amAddChildFirst; - amInsertAfter: - Mode := amAddChildLast; - end; - end; - - // Validate given node in case the new node becomes its child. - if (Mode in [amAddChildFirst, amAddChildLast]) and not (vsInitialized in Node.States) then - InitNode(Node); - InternalConnectNode(Result, Node, Self, Mode); - - // Check if there is initial user data and there is also enough user data space allocated. - if Assigned(UserData) then - if FNodeDataSize >= 4 then - begin - NodeData := Pointer(PChar(@Result.Data) + FTotalInternalDataSize); - NodeData^ := UserData; - Include(Result.States, vsInitialUserData); - end - else - ShowError(SCannotSetUserData, hcTFCannotSetUserData); - - if FUpdateCount = 0 then - begin - // If auto sort is enabled then sort the node or its parent (depending on the insert mode). - if (toAutoSort in FOptions.FAutoOptions) and (FHeader.FSortColumn > InvalidColumn) then - case Mode of - amInsertBefore, - amInsertAfter: - // Here no initialization is necessary because *if* a node has already got children then it - // must also be initialized. - // Note: Node can never be FRoot at this point. - Sort(Node.Parent, FHeader.FSortColumn, FHeader.FSortDirection, True); - amAddChildFirst, - amAddChildLast: - Sort(Node, FHeader.FSortColumn, FHeader.FSortDirection, True); - end; - - UpdateScrollbars(True); - if Mode = amInsertBefore then - InvalidateToBottom(Result) - else - InvalidateToBottom(Node); - end; - StructureChange(Result, crNodeAdded); - end - else - Result := nil; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.InvalidateChildren(Node: PVirtualNode; Recursive: Boolean); - -// Invalidates Node and its immediate children. -// If Recursive is True then all grandchildren are invalidated as well. -// The node itself is initialized if necessary and its child nodes are created (and initialized too if -// Recursive is True). - -var - Run: PVirtualNode; - -begin - if Assigned(Node) then - begin - if not (vsInitialized in Node.States) then - InitNode(Node); - InvalidateNode(Node); - if (vsHasChildren in Node.States) and (Node.ChildCount = 0) then - InitChildren(Node); - Run := Node.FirstChild; - end - else - Run := FRoot.FirstChild; - - while Assigned(Run) do - begin - InvalidateNode(Run); - if Recursive then - InvalidateChildren(Run, True); - Run := Run.NextSibling; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.InvalidateColumn(Column: TColumnIndex); - -// Invalidates the client area part of a column. - -var - R: TRect; - -begin - if (FUpdateCount = 0) and FHeader.Columns.IsValidColumn(Column) then - begin - R := ClientRect; - FHeader.Columns.GetColumnBounds(Column, R.Left, R.Right); - InvalidateRect(Handle, @R, False); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.InvalidateNode(Node: PVirtualNode): TRect; - -// Initiates repaint of the given node and returns the just invalidated rectangle. - -begin - if (FUpdateCount = 0) and HandleAllocated then - begin - Result := GetDisplayRect(Node, NoColumn, False); - InvalidateRect(Handle, @Result, False); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.InvalidateToBottom(Node: PVirtualNode); - -// Initiates repaint of client area starting at given node. If this node is not visible or not yet initialized -// then nothing happens. - -var - R: TRect; - -begin - if FUpdateCount = 0 then - begin - if (Node = nil) or (Node = FRoot) then - Invalidate - else - if [vsInitialized, vsVisible] * Node.States = [vsInitialized, vsVisible] then - begin - R := GetDisplayRect(Node, -1, False); - if R.Top < ClientHeight then - begin - R.Bottom := ClientHeight; - InvalidateRect(Handle, @R, False); - end; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.InvertSelection(VisibleOnly: Boolean); - -// Inverts the current selection (so nodes which are selected become unselected and vice versa). -// If VisibleOnly is True then only visible nodes are considered. - -var - Run: PVirtualNode; - NewSize: Integer; - NextFunction: function(Node: PVirtualNode): PVirtualNode of object; - TriggerChange: Boolean; - -begin - if toMultiSelect in FOptions.FSelectionOptions then - begin - Run := FRoot.FirstChild; - ClearTempCache; - if VisibleOnly then - NextFunction := GetNextVisibleNoInit - else - NextFunction := GetNextNoInit; - while Assigned(Run) do - begin - if vsSelected in Run.States then - InternalRemoveFromSelection(Run) - else - InternalCacheNode(Run); - Run := NextFunction(Run); - end; - - // do some housekeeping - // Need to trigger the OnChange event from here if nodes were only deleted but not added. - TriggerChange := False; - NewSize := PackArray(FSelection, FSelectionCount); - if NewSize > -1 then - begin - FSelectionCount := NewSize; - SetLength(FSelection, FSelectionCount); - TriggerChange := True; - end; - if FTempNodeCount > 0 then - begin - AddToSelection(FTempNodeCache, FTempNodeCount); - ClearTempCache; - TriggerChange := False; - end; - Invalidate; - if TriggerChange then - Change(nil); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.IsEditing: Boolean; - -begin - Result := tsEditing in FStates; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.IsMouseSelecting: Boolean; - -begin - Result := (tsDrawSelPending in FStates) or (tsDrawSelecting in FStates); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.IterateSubtree(Node: PVirtualNode; Callback: TVTGetNodeProc; Data: Pointer; - Filter: TVirtualNodeStates = []; DoInit: Boolean = False; ChildNodesOnly: Boolean = False): PVirtualNode; - -// Iterates through the all children and grandchildren etc. of Node (or the entire tree if Node = nil) -// and calls for each node the provided callback method (which must not be empty). -// Filter determines which nodes to consider (an empty set denotes all nodes). -// If DoInit is True then nodes which aren't initialized yet will be initialized. -// Note: During execution of the callback the application can set Abort to True. In this case the iteration is stopped -// and the last accessed node (the one on which the callback set Abort to True) is returned to the caller. -// Otherwise (no abort) nil is returned. - -var - Stop: PVirtualNode; - Abort: Boolean; - GetNextNode: TGetNextNodeProc; - WasIterating: Boolean; - -begin - Assert(Node <> FRoot, 'Node must not be the hidden root node.'); - - WasIterating := tsIterating in FStates; - DoStateChange([tsIterating]); - try - // prepare function to be used when advancing - if DoInit then - GetNextNode := GetNext - else - GetNextNode := GetNextNoInit; - - Abort := False; - if Node = nil then - Stop := nil - else - begin - if not (vsInitialized in Node.States) and DoInit then - InitNode(Node); - - // The stopper does not need to be initialized since it is not taken into the enumeration. - Stop := Node.NextSibling; - if Stop = nil then - begin - Stop := Node; - repeat - Stop := Stop.Parent; - until (Stop = FRoot) or Assigned(Stop.NextSibling); - if Stop = FRoot then - Stop := nil - else - Stop := Stop.NextSibling; - end; - end; - - // Use first node if we start with the root. - if Node = nil then - Node := GetFirstNoInit; - - if Assigned(Node) then - begin - if not (vsInitialized in Node.States) and DoInit then - InitNode(Node); - - // Skip given node if only the child nodes are requested. - if ChildNodesOnly then - begin - if Node.ChildCount = 0 then - Node := nil - else - Node := GetNextNode(Node); - end; - - if Filter = [] then - begin - // unfiltered loop - while Assigned(Node) and (Node <> Stop) do - begin - Callback(Self, Node, Data, Abort); - if Abort then - Break; - Node := GetNextNode(Node); - end; - end - else - begin - // filtered loop - while Assigned(Node) and (Node <> Stop) do - begin - if Node.States * Filter = Filter then - Callback(Self, Node, Data, Abort); - if Abort then - Break; - Node := GetNextNode(Node) - end; - end; - end; - - if Abort then - Result := Node - else - Result := nil; - finally - if not WasIterating then - DoStateChange([], [tsIterating]); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.LoadFromFile(const FileName: TFileName); - -var - FileStream: TFileStream; - -begin - FileStream := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite); - try - LoadFromStream(FileStream); - finally - FileStream.Free; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.LoadFromStream(Stream: TStream); - -// Clears the current content of the tree and loads a new structure from the given stream. - -var - ThisID: TMagicID; - Version, - Count: Cardinal; - Node: PVirtualNode; - -begin - if not (toReadOnly in FOptions.FMiscOptions) then - begin - Clear; - // Check first whether this is a stream we can read. - if Stream.Read(ThisID, SizeOf(TMagicID)) < SizeOf(TMagicID) then - ShowError(SStreamTooSmall, hcTFStreamTooSmall); - - if (ThisID[0] = MagicID[0]) and - (ThisID[1] = MagicID[1]) and - (ThisID[2] = MagicID[2]) and - (ThisID[5] = MagicID[5]) then - begin - Version := Word(ThisID[3]); - if Version <= VTTreeStreamVersion then - begin - BeginUpdate; - try - if Version < 2 then - Count := MaxInt - else - Stream.ReadBuffer(Count, SizeOf(Count)); - - while (Stream.Position < Stream.Size) and (Count > 0) do - begin - Dec(Count); - Node := MakeNewNode; - InternalConnectNode(Node, FRoot, Self, amAddChildLast); - InternalAddFromStream(Stream, Version, Node); - end; - DoNodeCopied(nil); - finally - EndUpdate; - end; - end - else - ShowError(SWrongStreamVersion, hcTFWrongStreamVersion); - end - else - ShowError(SWrongStreamFormat, hcTFWrongStreamFormat); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.MeasureItemHeight(const Canvas: TCanvas; Node: PVirtualNode); - -// If the height of the given node has not yet been measured then do it now. - -var - NewNodeHeight: Integer; - -begin - if not (vsHeightMeasured in Node.States) then - begin - Include(Node.States, vsHeightMeasured); - NewNodeHeight := Node.NodeHeight; - DoMeasureItem(Canvas, Node, NewNodeHeight); - if NewNodeHeight <> Node.NodeHeight then - SetNodeHeight(Node, NewNodeHeight); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.MoveTo(Node: PVirtualNode; Tree: TBaseVirtualTree; Mode: TVTNodeAttachMode; - ChildrenOnly: Boolean); - -// A simplified method to allow to move nodes to the root of another tree. - -begin - MoveTo(Node, Tree.FRoot, Mode, ChildrenOnly); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.MoveTo(Source, Target: PVirtualNode; Mode: TVTNodeAttachMode; ChildrenOnly: Boolean); - -// Moves the given node (and all its children) to Target. Source must belong to the tree instance which calls this -// MoveTo method. Mode determines how to connect Source to Target. -// This method might involve a change of the tree if Target belongs to a different tree than Source. - -var - TargetTree: TBaseVirtualTree; - Allowed: Boolean; - NewNode: PVirtualNode; - Stream: TMemoryStream; - -begin - Assert(TreeFromNode(Source) = Self, 'The source tree must contain the source node.'); - - // When moving nodes then source and target must not be the same node unless only the source's children are - // moved and they are inserted before or after the node itself. - Allowed := (Source <> Target) or ((Mode in [amInsertBefore, amInsertAfter]) and ChildrenOnly); - - if Allowed and (Mode <> amNoWhere) and Assigned(Source) and (Source <> FRoot) and - not (toReadOnly in FOptions.FMiscOptions) then - begin - // Assume that an empty destination means the root in this (the source) tree. - if Target = nil then - begin - TargetTree := Self; - Target := FRoot; - Mode := amAddChildFirst; - end - else - TargetTree := TreeFromNode(Target); - - if Target = TargetTree.FRoot then - begin - case Mode of - amInsertBefore: - Mode := amAddChildFirst; - amInsertAfter: - Mode := amAddChildLast; - end; - end; - - // Make sure the target node is initialized. - if not (vsInitialized in Target.States) then - InitNode(Target) - else - if (vsHasChildren in Target.States) and (Target.ChildCount = 0) then - InitChildren(Target); - - if TargetTree = Self then - begin - // Simple case: move node(s) within the same tree. - if Target = FRoot then - Allowed := DoNodeMoving(Source, nil) - else - Allowed := DoNodeMoving(Source, Target); - if Allowed then - begin - // Check first that Source is not added as new child to a target node which - // is already a child of Source. - // Consider the case Source and Target are the same node, but only child nodes are moved. - if (Source <> Target) and HasAsParent(Target, Source) then - ShowError(SWrongMoveError, hcTFWrongMoveError); - - if not ChildrenOnly then - begin - // Disconnect from old location. - InternalDisconnectNode(Source, True); - // Connect to new location. - InternalConnectNode(Source, Target, Self, Mode); - DoNodeMoved(Source); - end - else - begin - // Only child nodes should be moved. Insertion order depends on move mode. - if Mode = amAddChildFirst then - begin - Source := Source.LastChild; - while Assigned(Source) do - begin - NewNode := Source.PrevSibling; - // Disconnect from old location. - InternalDisconnectNode(Source, True, False); - // Connect to new location. - InternalConnectNode(Source, Target, Self, Mode); - DoNodeMoved(Source); - Source := NewNode; - end; - end - else - begin - Source := Source.FirstChild; - while Assigned(Source) do - begin - NewNode := Source.NextSibling; - // Disconnect from old location. - InternalDisconnectNode(Source, True, False); - // Connect to new location. - InternalConnectNode(Source, Target, Self, Mode); - DoNodeMoved(Source); - Source := NewNode; - end; - end; - end; - end; - end - else - begin - // Difficult case: move node(s) to another tree. - // In opposition to node copying we ask only once if moving is allowed because - // we cannot take back a move once done. - if Target = TargetTree.FRoot then - Allowed := DoNodeMoving(Source, nil) - else - Allowed := DoNodeMoving(Source, Target); - - if Allowed then - begin - Stream := TMemoryStream.Create; - try - // Write all nodes into a temporary stream depending on the ChildrenOnly flag. - if not ChildrenOnly then - WriteNode(Stream, Source) - else - begin - Source := Source.FirstChild; - while Assigned(Source) do - begin - WriteNode(Stream, Source); - Source := Source.NextSibling; - end; - end; - // Now load the serialized nodes into the target node (tree). - TargetTree.BeginUpdate; - try - Stream.Position := 0; - while Stream.Position < Stream.Size do - begin - NewNode := TargetTree.MakeNewNode; - InternalConnectNode(NewNode, Target, TargetTree, Mode); - TargetTree.InternalAddFromStream(Stream, VTTreeStreamVersion, NewNode); - DoNodeMoved(NewNode); - end; - finally - TargetTree.EndUpdate; - end; - finally - Stream.Free; - end; - // finally delete original nodes - BeginUpdate; - try - if ChildrenOnly then - DeleteChildren(Source) - else - DeleteNode(Source); - finally - EndUpdate; - end; - end; - end; - - InvalidateCache; - if (FUpdateCount = 0) and Allowed then - begin - ValidateCache; - UpdateScrollBars(True); - Invalidate; - if TargetTree <> Self then - TargetTree.Invalidate; - end; - StructureChange(Source, crNodeMoved); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.PaintTree(TargetCanvas: TCanvas; Window: TRect; Target: TPoint; - PaintOptions: TVTInternalPaintOptions; PixelFormat: TPixelFormat); - -// This is the core paint routine of the tree. It is responsible for maintaining the paint cycles per node as well -// as coordinating drawing of the various parts of the tree image. -// TargetCanvas is the canvas to which to draw the tree image. This is usually the tree window itself but could well -// be a bitmap or printer canvas. -// Window determines which part of the entire tree image to draw. The full size of the virtual image is determined -// by GetTreeRect. -// Target is the position in TargetCanvas where to draw the tree part specified by Window. -// PaintOptions determines what of the tree to draw. For different tasks usually different parts need to be drawn, with -// a full image in the window, selected only nodes for a drag image etc. - -const - ImageKind: array[Boolean] of TVTImageKind = (ikNormal, ikSelected); - -var - DrawSelectionRect, - UseBackground, - ShowImages, - ShowStateImages, - ShowCheckImages, - UseColumns, - IsMainColumn: Boolean; - - VAlign, - IndentSize, - ButtonX, - ButtonY: Integer; - Temp: PVirtualNode; - LineImage: TLineImage; - PaintInfo: TVTPaintInfo; // all necessary information about a node to pass to the paint routines - - R, // the area of an entire node in its local coordinate - TargetRect, // the area of a node (part) in the target canvas - SelectionRect: TRect; // ordered rectangle used for drawing the selection focus rect - NextColumn: TColumnIndex; - BaseOffset: Integer; // top position of the top node to draw given in absolute tree coordinates - NodeBitmap: TBitmap; // small buffer to draw flicker free - MaximumRight, // maximum horizontal target position - MaximumBottom: Integer; // maximum vertical target position - SelectLevel: Integer; // > 0 if current node is selected or child/grandchild etc. of a selected node - FirstColumn: TColumnIndex; // index of first column which is at least partially visible in the given window - -begin - Logger.EnterMethod(lcPaint,'PaintTree'); - Logger.Send(lcPaint,'Window',Window); - Logger.Send(lcPaint,'Target',Target); - if not (tsPainting in FStates) then - begin - DoStateChange([tsPainting]); - try - DoBeforePaint(TargetCanvas); - - // Create small bitmaps and initialize default values. - // The bitmaps are used to paint one node at a time and to draw the result to the target (e.g. screen) in one step, - // to prevent flickering. - NodeBitmap := TBitmap.Create; - // For alpha blending we need the 32 bit pixel format. For other targets there might be a need for a certain - // pixel format (e.g. printing). - if MMXAvailable and ((FDrawSelectionMode = smBlendedRectangle) or (tsUseThemes in FStates) or - (toUseBlendedSelection in FOptions.PaintOptions)) then - NodeBitmap.PixelFormat := pf32Bit - else - NodeBitmap.PixelFormat := PixelFormat; - - // Prepare paint info structure and lock the back bitmap canvas to avoid that it gets freed on the way. - FillChar(PaintInfo, SizeOf(PaintInfo), 0); - PaintInfo.Canvas := NodeBitmap.Canvas; - NodeBitmap.Canvas.Lock; - try - Logger.Send(lcPaintDetails,'FNewSelRect',FNewSelRect); - // Prepare the current selection rectangle once. The corner points are absolute tree coordinates. - SelectionRect := OrderRect(FNewSelRect); - Logger.Send(lcPaintDetails,'SelectionRect',SelectionRect); - DrawSelectionRect := IsMouseSelecting and not IsRectEmpty(SelectionRect); - Logger.Watch(lcPaintDetails,'DrawSelectionRect',DrawSelectionRect); - // R represents an entire node (all columns), but is a bit unprecise when it comes to - // trees without any column defined, because FRangeX only represents the maximum width of all - // nodes in the client area (not all defined nodes). There might be, however, wider nodes somewhere. Without full - // validation I cannot better determine the width, though. By using at least the control's width it is ensured - // that the tree is fully displayed on screen. - R := Rect(0, 0, Max(FRangeX, ClientWidth), 0); - NodeBitmap.Width := Window.Right - Window.Left; - Logger.Send(lcPaintDetails,'NodeBitmap.Width',NodeBitmap.Width); - // Make sure the buffer bitmap and target bitmap use the same transformation mode. - SetMapMode(NodeBitmap.Canvas.Handle, GetMapMode(TargetCanvas.Handle)); - - // For quick checks some intermediate variables are used. - UseBackground := (toShowBackground in FOptions.FPaintOptions) and (FBackground.Graphic is TBitmap) and - (poBackground in PaintOptions); - ShowImages := Assigned(FImages); - ShowStateImages := Assigned(FStateImages); - ShowCheckImages := Assigned(FCheckImages) and (toCheckSupport in FOptions.FMiscOptions); - Logger.Send(lcCheck,'ShowCheckImages',ShowCheckImages); - UseColumns := FHeader.UseColumns; - - // Adjust paint options to tree settings. Hide selection if told so or the tree is unfocused. - if (toAlwaysHideSelection in FOptions.FPaintOptions) or - (not Focused and (toHideSelection in FOptions.FPaintOptions)) then - Exclude(PaintOptions, poDrawSelection); - if toHideFocusRect in FOptions.FPaintOptions then - Exclude(PaintOptions, poDrawFocusRect); - - // Determine node to start drawing with. - BaseOffset := 0; - PaintInfo.Node := GetNodeAt(0, Window.Top, False, BaseOffset); - if PaintInfo.Node = nil then - BaseOffset := Window.Top; - Logger.Watch(lcPaint,'BaseOffset',BaseOffset); - // Transform selection rectangle into node bitmap coordinates. - if DrawSelectionRect then - OffsetRect(SelectionRect, 0, -BaseOffset); - - // The target rectangle holds the coordinates of the exact area to blit in target canvas coordinates. - // It is usually smaller than an entire node and wanders while the paint loop advances. - MaximumRight := Target.X + (Window.Right - Window.Left); - MaximumBottom := Target.Y + (Window.Bottom - Window.Top); - - TargetRect := Rect(Target.X, Target.Y - (Window.Top - BaseOffset), MaximumRight, 0); - TargetRect.Bottom := TargetRect.Top; - Logger.Send(lcPaint,'TargetRect',TargetRect); - // This marker gets the index of the first column which is visible in the given window. - // This is needed for column based background colors. - FirstColumn := InvalidColumn; - - if Assigned(PaintInfo.Node) then - begin - SelectLevel := InitializeLineImageAndSelectLevel(PaintInfo.Node, LineImage); - IndentSize := Length(LineImage); - - // Precalculate horizontal position of buttons relative to the column start. - ButtonX := (Length(LineImage) * Integer(FIndent)) + Round((Integer(FIndent) - FPlusBM.Width) / 2) - FIndent; - - // ----- main node paint loop - while Assigned(PaintInfo.Node) do - begin - Logger.EnterMethod(lcPaintDetails,'PaintNode'); - Logger.Watch(lcPaintDetails,'BaseOffset',BaseOffset); - Logger.Watch(lcPaintDetails,'Brush.Color',PaintInfo.Canvas.Brush.Color); - // Initialize node if not already done. - if not (vsInitialized in PaintInfo.Node.States) then - InitNode(PaintInfo.Node); - if vsSelected in PaintInfo.Node.States then - Inc(SelectLevel); - - // Ensure the node's height is determined. - MeasureItemHeight(PaintInfo.Canvas, PaintInfo.Node); - - // Adjust the brush origin for dotted lines depending on the current source position. - // It is applied some lines later, as the canvas might get reallocated, when changing the node bitmap. - PaintInfo.BrushOrigin := Point(Window.Left and 1, BaseOffset and 1); - Inc(BaseOffset, PaintInfo.Node.NodeHeight); - - TargetRect.Bottom := TargetRect.Top + PaintInfo.Node.NodeHeight; - - // If poSelectedOnly is active then do the following stuff only for selected nodes or nodes - // which are children of selected nodes. - if (SelectLevel > 0) or not (poSelectedOnly in PaintOptions) then - begin - // Adjust height of temporary node bitmap. - with NodeBitmap do - begin - if Height <> PaintInfo.Node.NodeHeight then - begin - // Avoid that the VCL copies the bitmap while changing its height. - Height := 0; - Height := PaintInfo.Node.NodeHeight; - SetWindowOrgEx(Canvas.Handle, Window.Left, 0, nil); - R.Bottom := PaintInfo.Node.NodeHeight; - end; - // Set the origin of the canvas' brush. This depends on the node heights. - with PaintInfo do - SetBrushOrgEx(Canvas.Handle, BrushOrigin.X, BrushOrigin.Y, nil); - end; - CalculateVerticalAlignments(ShowImages, ShowStateImages, PaintInfo.Node, VAlign, ButtonY); - - // Let application decide whether the node should normally be drawn or by the application itself. - if not DoBeforeItemPaint(PaintInfo.Canvas, PaintInfo.Node, R) then - begin - // Init paint options for the background painting. - PaintInfo.PaintOptions := PaintOptions; - Logger.Watch(lcPaintDetails,'Brush.Color',PaintInfo.Canvas.Brush.Color); - // The node background can contain a single color, a bitmap or can be drawn by the application. - ClearNodeBackground(PaintInfo, UseBackground, True, Rect(Window.Left, TargetRect.Top, Window.Right, - TargetRect.Bottom)); - Logger.Watch(lcPaintDetails,'Brush.Color',PaintInfo.Canvas.Brush.Color); - // Prepare column, position and node clipping rectangle. - PaintInfo.CellRect := R; - if UseColumns then - InitializeFirstColumnValues(PaintInfo); - - // Now go through all visible columns (there's still one run if columns aren't used). - with FHeader.FColumns do - begin - while ((PaintInfo.Column > InvalidColumn) or not UseColumns) - and (PaintInfo.CellRect.Left < Window.Right) do - begin - Logger.Send(lcPaintDetails,'Handling a column'); - if UseColumns then - begin - PaintInfo.Column := FPositionToIndex[PaintInfo.Position]; - if FirstColumn = InvalidColumn then - FirstColumn := PaintInfo.Column; - PaintInfo.BidiMode := Items[PaintInfo.Column].FBiDiMode; - PaintInfo.Alignment := Items[PaintInfo.Column].FAlignment; - end - else - begin - PaintInfo.Column := NoColumn; - PaintInfo.BidiMode := BidiMode; - PaintInfo.Alignment := FAlignment; - end; - - PaintInfo.PaintOptions := PaintOptions; - with PaintInfo do - begin - if (tsEditing in FStates) and (Node = FFocusedNode) and - ((Column = FEditColumn) or not UseColumns) then - Exclude(PaintOptions, poDrawSelection); - if not UseColumns or - ((vsSelected in Node.States) and (toFullRowSelect in FOptions.FSelectionOptions) and - (poDrawSelection in PaintOptions)) or - (coParentColor in Items[PaintInfo.Column].Options) then - Exclude(PaintOptions, poColumnColor); - end; - IsMainColumn := PaintInfo.Column = FHeader.MainColumn; - - // Consider bidi mode here. In RTL context means left alignment actually right alignment and vice versa. - if PaintInfo.BidiMode <> bdLeftToRight then - ChangeBiDiModeAlignment(PaintInfo.Alignment); - - // Paint the current cell if it is marked as being visible or columns aren't used and - // if this cell belongs to the main column if only the main column should be drawn. - if (not UseColumns or (coVisible in Items[PaintInfo.Column].FOptions)) and - (not (poMainOnly in PaintOptions) or IsMainColumn) then - begin - AdjustPaintCellRect(PaintInfo, NextColumn); - - // Paint the cell only if it is in the current window. - if PaintInfo.CellRect.Right > Window.Left then - begin - with PaintInfo do - begin - // Fill in remaining values in the paint info structure. - NodeWidth := DoGetNodeWidth(Node, Column, Canvas); - // Not the entire cell is covered by text. Hence we need a running rectangle to follow up. - ContentRect := CellRect; - // Set up the distance from column border (margin). - if BidiMode <> bdLeftToRight then - Dec(ContentRect.Right, FMargin) - else - Inc(ContentRect.Left, FMargin); - - if ShowCheckImages and IsMainColumn then - begin - ImageInfo[iiCheck].Index := GetCheckImage(Node); - if ImageInfo[iiCheck].Index > -1 then - begin - AdjustImageBorder(FCheckImages, BidiMode, VAlign, ContentRect, ImageInfo[iiCheck]); - ImageInfo[iiCheck].Ghosted := False; - end; - end - else - ImageInfo[iiCheck].Index := -1; - if ShowStateImages then - begin - GetImageIndex(PaintInfo, ikState, iiState, FStateImages); - if ImageInfo[iiState].Index > -1 then - AdjustImageBorder(FStateImages, BidiMode, VAlign, ContentRect, ImageInfo[iiState]); - end - else - ImageInfo[iiState].Index := -1; - if ShowImages then - begin - GetImageIndex(PaintInfo, ImageKind[vsSelected in Node.States], iiNormal, FImages); - if ImageInfo[iiNormal].Index > -1 then - AdjustImageBorder(FImages, BidiMode, VAlign, ContentRect, ImageInfo[iiNormal]); - end - else - ImageInfo[iiNormal].Index := -1; - - // Take the space for the tree lines into account. - if IsMainColumn then - AdjustCoordinatesByIndent(PaintInfo, IndentSize); - - if UseColumns then - LimitPaintingToArea(Canvas, CellRect); - - // Paint the horizontal grid line. - if (poGridLines in PaintOptions) and (toShowHorzGridLines in FOptions.FPaintOptions) then - begin - Canvas.Font.Color := FColors.GridLineColor; - if IsMainColumn and (FLineMode = lmBands) then - begin - if BidiMode = bdLeftToRight then - begin - DrawDottedHLine(PaintInfo, CellRect.Left + IndentSize * Integer(FIndent), CellRect.Right - 1, - CellRect.Bottom - 1); - end - else - begin - DrawDottedHLine(PaintInfo, CellRect.Left, CellRect.Right - IndentSize * Integer(FIndent) - 1, - CellRect.Bottom - 1); - end; - end - else - DrawDottedHLine(PaintInfo, CellRect.Left, CellRect.Right, CellRect.Bottom - 1); - Dec(CellRect.Bottom); - Dec(ContentRect.Bottom); - end; - - if UseColumns then - begin - // Paint vertical grid line. - // Don't draw if this is the last column and the header is in autosize mode. - if (poGridLines in PaintOptions) and (toShowVertGridLines in FOptions.FPaintOptions) and - (not (hoAutoResize in FHeader.FOptions) or (Position < TColumnPosition(Count - 1))) then - begin - if (BidiMode = bdLeftToRight) or not ColumnIsEmpty(Node, Column) then - begin - Canvas.Font.Color := FColors.GridLineColor; - DrawDottedVLine(PaintInfo, CellRect.Top, CellRect.Bottom, CellRect.Right - 1); - end; - Dec(CellRect.Right); - Dec(ContentRect.Right); - end; - end; - - // Prepare background and focus rect for the current cell. - PrepareCell(PaintInfo, Window.Left, NodeBitmap.Width); - Logger.Watch(lcPaintDetails,'Brush.Color',PaintInfo.Canvas.Brush.Color); - // Some parts are only drawn for the main column. - if IsMainColumn then - begin - if toShowTreeLines in FOptions.FPaintOptions then - PaintTreeLines(PaintInfo, VAlign, IndentSize, LineImage); - // Show node button if allowed, if there child nodes and at least one of the child - // nodes is visible or auto button hiding is disabled. - if (toShowButtons in FOptions.FPaintOptions) and (vsHasChildren in Node.States) and - not ((vsAllChildrenHidden in Node.States) and - (toAutoHideButtons in TreeOptions.FAutoOptions)) then - PaintNodeButton(Canvas, Node, CellRect, ButtonX, ButtonY, BidiMode); - - if ImageInfo[iiCheck].Index > -1 then - PaintCheckImage(PaintInfo); - end; - Logger.Watch(lcPaintDetails,'Brush.Color',PaintInfo.Canvas.Brush.Color); - if ImageInfo[iiState].Index > -1 then - PaintImage(PaintInfo, iiState, False); - if ImageInfo[iiNormal].Index > -1 then - PaintImage(PaintInfo, iiNormal, True); - Logger.Watch(lcPaintDetails,'Brush.Color',PaintInfo.Canvas.Brush.Color); - // Now let descendants or applications draw whatever they want, - // but don't draw the node if it is currently being edited. - if not ((tsEditing in FStates) and (Node = FFocusedNode) and - ((Column = FEditColumn) or not UseColumns)) then - DoPaintNode(PaintInfo); - Logger.Watch(lcPaintDetails,'Brush.Color',PaintInfo.Canvas.Brush.Color); - DoAfterCellPaint(Canvas, Node, Column, CellRect); - end; - end; - - // leave after first run if columns aren't used - if not UseColumns then - Break; - end - else - NextColumn := GetNextVisibleColumn(PaintInfo.Column); - - SelectClipRgn(PaintInfo.Canvas.Handle, 0); - // Stop column loop if there are no further columns in the given window. - if (PaintInfo.CellRect.Left >= Window.Right) or (NextColumn = InvalidColumn) then - Break; - - // Move on to next column which might not be the one immediately following the current one - // because of auto span feature. - PaintInfo.Position := Items[NextColumn].Position; - - // Move clip rectangle and continue. - if coVisible in Items[NextColumn].FOptions then - with PaintInfo do - begin - Items[NextColumn].GetAbsoluteBounds(CellRect.Left, CellRect.Right); - CellRect.Bottom := Node.NodeHeight; - ContentRect.Bottom := Node.NodeHeight; - end; - end; - end; - - // This node is finished, notify descendants/application. - with PaintInfo do - begin - DoAfterItemPaint(Canvas, Node, R); - - // Final touch for this node: mark it if it is the current drop target node. - if (Node = FDropTargetNode) and (toShowDropmark in FOptions.FPaintOptions) and - (poDrawDropMark in PaintOptions) then - DoPaintDropMark(Canvas, Node, R); - end; - end; - - with PaintInfo.Canvas do - begin - if DrawSelectionRect then - begin - PaintSelectionRectangle(PaintInfo.Canvas, Window.Left, SelectionRect, Rect(0, 0, NodeBitmap.Width, - NodeBitmap.Height)); - end; - Logger.SendBitmap(lcPaintBitmap,'NodeBitmap',NodeBitmap); - // Put the constructed node image onto the target canvas. - with TargetRect, NodeBitmap do - BitBlt(TargetCanvas.Handle, Left, Top, Width, Height, Canvas.Handle, Window.Left, 0, SRCCOPY); - end; - end; - - Inc(TargetRect.Top, PaintInfo.Node.NodeHeight); - if TargetRect.Top >= MaximumBottom then - Break; - - // Keep selection rectangle coordinates in sync. - if DrawSelectionRect then - OffsetRect(SelectionRect, 0, -PaintInfo.Node.NodeHeight); - - // Advance to next visible node. - Temp := GetNextVisible(PaintInfo.Node); - if Assigned(Temp) then - begin - // Adjust line bitmap (and so also indentation level). - if Temp.Parent = PaintInfo.Node then - begin - // New node is a child node. Need to adjust previous bitmap level. - if IndentSize > 0 then - if HasVisibleNextSibling(PaintInfo.Node) then - LineImage[IndentSize - 1] := ltTopDown - else - LineImage[IndentSize - 1] := ltNone; - // Enhance line type array if necessary. - Inc(IndentSize); - if Length(LineImage) <= IndentSize then - SetLength(LineImage, IndentSize + 8); - Inc(ButtonX, FIndent); - end - else - begin - // New node is at the same or higher tree level. - // Take back select level increase if the node was selected - if vsSelected in PaintInfo.Node.States then - Dec(SelectLevel); - if PaintInfo.Node.Parent <> Temp.Parent then - begin - // We went up one or more levels. Determine how many levels it was actually. - while PaintInfo.Node.Parent <> Temp.Parent do - begin - Dec(IndentSize); - Dec(ButtonX, FIndent); - PaintInfo.Node := PaintInfo.Node.Parent; - // Take back one selection level increase for every step up. - if vsSelected in PaintInfo.Node.States then - Dec(SelectLevel); - end; - end; - end; - - // Set new image in front of the new node. - if IndentSize > 0 then - if HasVisibleNextSibling(Temp) then - LineImage[IndentSize - 1] := ltTopDownRight - else - LineImage[IndentSize - 1] := ltTopRight; - end; - - PaintInfo.Node := Temp; - Logger.ExitMethod(lcPaintDetails,'PaintNode'); - end; - end; - - // Erase rest of window not covered by a node. - if TargetRect.Top < MaximumBottom then - begin - Logger.Watch(lcPaintDetails,'UseBackground',UseBackground); - Logger.Watch(lcPaintDetails,'UseColumns',UseColumns); - // Keep the horizontal target position to determine the selection rectangle offset later (if necessary). - BaseOffset := Target.X; - Target := TargetRect.TopLeft; - R := Rect(TargetRect.Left, 0, TargetRect.Left, MaximumBottom - Target.Y); - TargetRect := Rect(0, 0, MaximumRight - Target.X, MaximumBottom - Target.Y); - Logger.Send(lcPaintDetails,'NodeBitmap.Handle',NodeBitmap.Handle); - // Avoid unnecessary copying of bitmap content. This will destroy the DC handle too. - NodeBitmap.Height := 0; - NodeBitmap.PixelFormat := pf32Bit; - NodeBitmap.Width := TargetRect.Right - TargetRect.Left + 1; - NodeBitmap.Height := TargetRect.Bottom - TargetRect.Top + 1; - Logger.Send(lcPaintDetails,'NodeBitmap.Handle',NodeBitmap.Handle); - Logger.Send(lcPaintDetails,'TargetRect',TargetRect); - Logger.Send(lcPaintDetails,'NodeBitmap Width: %d Height: %d',[NodeBitmap.Width,NodeBitmap.Height]); - // Call back application/descendants whether they want to erase this area. - SetWindowOrgEx(NodeBitmap.Canvas.Handle, Target.X, 0, nil); - if not DoPaintBackground(NodeBitmap.Canvas, TargetRect) then - begin - if UseBackground then - begin - SetWindowOrgEx(NodeBitmap.Canvas.Handle, 0, 0, nil); - if toStaticBackground in TreeOptions.PaintOptions then - StaticBackground(FBackground.Bitmap, NodeBitmap.Canvas, Target, TargetRect) - else - TileBackground(FBackground.Bitmap, NodeBitmap.Canvas, Target, TargetRect); - end - else - begin - // Consider here also colors of the columns. - if UseColumns then - begin - with FHeader.FColumns do - begin - // If there is no content in the tree then the first column has not yet been determined. - if FirstColumn = InvalidColumn then - begin - FirstColumn := GetFirstVisibleColumn; - repeat - if FirstColumn <> InvalidColumn then - begin - R.Left := Items[FirstColumn].Left; - R.Right := R.Left + Items[FirstColumn].FWidth; - if R.Right > TargetRect.Left then - Break; - FirstColumn := GetNextVisibleColumn(FirstColumn); - end; - until FirstColumn = InvalidColumn; - end - else - begin - R.Left := Items[FirstColumn].Left; - R.Right := R.Left + Items[FirstColumn].FWidth; - end; - - NodeBitmap.Canvas.Font.Color := FColors.GridLineColor; - while (FirstColumn <> InvalidColumn) and (R.Left < TargetRect.Right + Target.X) do - begin - if (poGridLines in PaintOptions) and - (toFullVertGridLines in FOptions.FPaintOptions) and - (toShowVertGridLines in FOptions.FPaintOptions) and - (not (hoAutoResize in FHeader.FOptions) or (Cardinal(FirstColumn) < TColumnPosition(Count - 1))) then - begin - DrawDottedVLine(PaintInfo, R.Top, R.Bottom, R.Right - 1); - Dec(R.Right); - end; - - if not (coParentColor in Items[FirstColumn].FOptions) then - NodeBitmap.Canvas.Brush.Color := Items[FirstColumn].FColor - else - NodeBitmap.Canvas.Brush.Color := Color; - - NodeBitmap.Canvas.FillRect(R); - FirstColumn := GetNextVisibleColumn(FirstColumn); - if FirstColumn <> InvalidColumn then - begin - R.Left := Items[FirstColumn].Left; - R.Right := R.Left + Items[FirstColumn].FWidth; - end; - end; - - // Erase also the part of the tree not covert by a column. - if R.Right < TargetRect.Right + Target.X then - begin - R.Left := R.Right; - R.Right := TargetRect.Right + Target.X; - // Prevent erasing the last vertical grid line. - if (poGridLines in PaintOptions) and - (toFullVertGridLines in FOptions.FPaintOptions) and (toShowVertGridLines in FOptions.FPaintOptions) and - (not (hoAutoResize in FHeader.FOptions)) then - Inc(R.Left); - NodeBitmap.Canvas.Brush.Color := Color; - NodeBitmap.Canvas.FillRect(R); - end; - end; - SetWindowOrgEx(NodeBitmap.Canvas.Handle, 0, 0, nil); - end - else - begin - Logger.Send(lcPaintDetails,'ErasingBackGround'); - Logger.Send(lcPaintDetails,'TargetRect',TargetRect); - // No columns nor bitmap background. Simply erase it with the tree color. - SetWindowOrgEx(NodeBitmap.Canvas.Handle, 0, 0, nil); - NodeBitmap.Canvas.Brush.Color := Color; - NodeBitmap.Canvas.FillRect(TargetRect); - end; - end; - end; - SetWindowOrgEx(NodeBitmap.Canvas.Handle, 0, 0, nil); - Logger.Watch(lcPaintDetails,'DrawSelectionRect',DrawSelectionRect); - if DrawSelectionRect then - begin - R := OrderRect(FNewSelRect); - // Remap the selection rectangle to the current window of the tree. - // Since Target has been used for other tasks BaseOffset got the left extent of the target position here. - OffsetRect(R, -Target.X + BaseOffset - Window.Left, -Target.Y + FOffsetY); - SetBrushOrgEx(NodeBitmap.Canvas.Handle, 0, Target.X and 1, nil); - PaintSelectionRectangle(NodeBitmap.Canvas, 0, R, TargetRect); - end; - Logger.Send(lcPaintDetails,'NodeBitmap.Canvas.Height',NodeBitmap.Canvas.Height); - Logger.Send(lcPaintDetails,'NodeBitmap.Canvas.ClipRect',NodeBitmap.Canvas.ClipRect); - Logger.Send(lcPaintDetails,'Target',Target); - Logger.SendBitmap(lcPaintBitmap,'BackGroundBitmap',NodeBitmap); - with Target, NodeBitmap do - BitBlt(TargetCanvas.Handle, X, Y, Width, Height, Canvas.Handle, 0, 0, SRCCOPY); - end; - finally - NodeBitmap.Canvas.Unlock; - NodeBitmap.Free; - end; - DoAfterPaint(TargetCanvas); - finally - DoStateChange([], [tsPainting]); - end; - end; - Logger.ExitMethod(lcPaint,'PaintTree'); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.PasteFromClipboard: Boolean; - -// Reads what is currently on the clipboard into the tree (if the format is supported). -// Note: If the application wants to have text or special formats to be inserted then it must implement -// its own code (OLE). Here only the native tree format is accepted. - -var - Data: IDataObject; - Source: TBaseVirtualTree; - -begin - Result := False; - if not (toReadOnly in FOptions.FMiscOptions) then - begin - if OleGetClipboard(Data) <> S_OK then - ShowError(SClipboardFailed, hcTFClipboardFailed) - else - try - // Try to get the source tree of the operation to optimize the operation. - Source := GetTreeFromDataObject(Data); - Result := ProcessOLEData(Source, Data, FFocusedNode, FDefaultPasteMode, Assigned(Source) and - (tsCutPending in Source.FStates)); - if Assigned(Source) then - if Source <> Self then - Source.FinishCutOrCopy - else - DoStateChange([], [tsCutPending]); - finally - Data := nil; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.PrepareDragImage(Hotspot: TPoint; const DataObject: IDataObject); - -// Initiates an image drag operation. Hotspot is the position of the mouse in client coordinates. - -var - PaintOptions: TVTInternalPaintOptions; - TreeRect, - PaintRect: TRect; - LocalSpot, - ImagePos, - PaintTarget: TPoint; - Image: TBitmap; - -begin - if CanShowDragImage then - begin - // Determine the drag rectangle which is a square around the hot spot. Operate in virtual tree space. - LocalSpot := HotSpot; - Dec(LocalSpot.X, -FEffectiveOffsetX); - Dec(LocalSpot.Y, FOffsetY); - TreeRect := Rect(LocalSpot.X - FDragWidth div 2, LocalSpot.Y - FDragHeight div 2, LocalSpot.X + FDragWidth div 2, - LocalSpot.Y + FDragHeight div 2); - - // Check that we have a valid rectangle. - with TreeRect do - begin - PaintRect := TreeRect; - 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 - try - PixelFormat := pf32Bit; - Width := TreeRect.Right - TreeRect.Left; - Height := TreeRect.Bottom - TreeRect.Top; - // Erase the entire image with the color key value, for the case not everything - // in the image is covered by the tree image. - Canvas.Brush.Color := Color; - Canvas.FillRect(Rect(0, 0, Width, Height)); - - PaintOptions := [poDrawSelection, poSelectedOnly]; - if FDragImageKind = diMainColumnOnly then - Include(PaintOptions, poMainOnly); - PaintTree(Image.Canvas, PaintRect, PaintTarget, PaintOptions); - - // Once we have got the drag image we can convert all necessary coordinates into screen space. - OffsetRect(TreeRect, -FEffectiveOffsetX, FOffsetY); - ImagePos := ClientToScreen(TreeRect.TopLeft); - HotSpot := ClientToScreen(HotSpot); - - FDragImage.ColorKey := Color; - FDragImage.PrepareDrag(Image, ImagePos, HotSpot, DataObject); - finally - Image.Free; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- -{$ifdef EnablePrint} -procedure TBaseVirtualTree.Print(Printer: TPrinter; PrintHeader: Boolean); - -var - SaveTreeFont: TFont; // Remembers the tree's current font. - SaveHeaderFont: TFont; // Remembers the header's current font. - ImgRect, // Describes the dimensions of Image. - TreeRect, // The total VTree dimensions. - DestRect, // Dimensions of PrinterImage. - SrcRect: TRect; // Clip dimensions from Image -> PrinterImage - P: TPoint; // Used by PaintTree. - Options: TVTInternalPaintOptions; // Used by PaintTree. - Image, // Complete Tree is drawn to this image. - PrinterImage: TBitmap; // This is the image that gets printed. - SaveColor: TColor; // Remembers the VTree Color. - pTxtHeight, // Height of font in the TPrinter.Canvas - vTxtHeight, // Height of font in the VTree Canvas - vPageWidth, - vPageHeight, // Printer height in VTree resolution - xPageNum, yPageNum, // # of pages (except the occasional last one) - xPage, yPage: Integer; // Loop counter - Scale: Extended; // Scale factor between Printer Canvas and VTree Canvas - LogFont: TLogFont; - -begin - if Assigned(Printer) then - begin - BeginUpdate; - - // Grid lines are the only parts which are desirable when printing. - Options := [poGridLines]; - - // Remember the tree font. - SaveTreeFont := TFont.Create; - SaveTreeFont.Assign(Font); - // Create a new font for printing which does not use clear type output (but is antialiased, if possible) - // and which has the highest possible quality. - GetObject(Font.Handle, SizeOf(TLogFont), @LogFont); - LogFont.lfQuality := ANTIALIASED_QUALITY; - Font.Handle := CreateFontIndirect(LogFont); - - // Create an image that will hold the complete VTree - Image := TBitmap.Create; - Image.PixelFormat := pf32Bit; - PrinterImage := nil; - try - TreeRect := GetTreeRect; - - Image.Width := TreeRect.Right - TreeRect.Left; - P := Point(0, 0); - if (hoVisible in FHeader.Options) and PrintHeader then - begin - Inc(TreeRect.Bottom, FHeader.Height); - Inc(P.Y, FHeader.Height); - end; - Image.Height := TreeRect.Bottom - TreeRect.Top; - - ImgRect.Left := 0; - ImgRect.Top := 0; - ImgRect.Right := Image.Width; - - // Force the background to white color during the rendering. - SaveColor := Color; - Color := clWhite; - // Print header if it is visible. - if (hoVisible in FHeader.Options) and PrintHeader then - begin - SaveHeaderFont := TFont.Create; - try - SaveHeaderFont.Assign(FHeader.Font); - // Create a new font for printing which does not use clear type output (but is antialiased, if possible) - // and which has the highest possible quality. - GetObject(FHeader.Font.Handle, SizeOf(TLogFont), @LogFont); - LogFont.lfQuality := ANTIALIASED_QUALITY; - FHeader.Font.Handle := CreateFontIndirect(LogFont); - ImgRect.Bottom := FHeader.Height; - FHeader.FColumns.PaintHeader(Image.Canvas.Handle, ImgRect, 0); - FHeader.Font := SaveHeaderFont; - finally - SaveHeaderFont.Free; - end; - end; - // The image's height is already adjusted for the header if it is visible. - ImgRect.Bottom := Image.Height; - - PaintTree(Image.Canvas, ImgRect, P, Options, pf32Bit); - Color := SaveColor; - - // Activate the printer - Printer.BeginDoc; - Printer.Canvas.Font := Font; - - // Now we can calculate the scaling : - pTxtHeight := Printer.Canvas.TextHeight('Tj'); - vTxtHeight := Canvas.TextHeight('Tj'); - - Scale := pTxtHeight / vTxtHeight; - - // Create an Image that has the same dimensions as the printer canvas but - // scaled to the VTree resolution: - PrinterImage := TBitmap.Create; - - vPageHeight := Round(Printer.PageHeight / Scale); - vPageWidth := Round(Printer.PageWidth / Scale); - - // We do a minumum of one page. - xPageNum := Trunc(Image.Width / vPageWidth); - yPageNum := Trunc(Image.Height / vPageHeight); - - PrinterImage.Width := vPageWidth; - PrinterImage.Height := vPageHeight; - - // Split vertically: - for yPage := 0 to yPageNum do - begin - DestRect.Left := 0; - DestRect.Top := 0; - DestRect.Right := PrinterImage.Width; - DestRect.Bottom := PrinterImage.Height; - - // Split horizontally: - for xPage := 0 to xPageNum do - begin - SrcRect.Left := vPageWidth * xPage; - SrcRect.Top := vPageHeight * yPage; - SrcRect.Right := vPageWidth * xPage + PrinterImage.Width; - SrcRect.Bottom := SrcRect.Top + vPageHeight; - - // Clear the image - PrinterImage.Canvas.Brush.Color := clWhite; - PrinterImage.Canvas.FillRect(Rect(0, 0, PrinterImage.Width, PrinterImage.Height)); - PrinterImage.Canvas.CopyRect(DestRect, Image.Canvas, SrcRect); - PrtStretchDrawDIB(Printer.Canvas, Rect(0, 0, Printer.PageWidth, Printer.PageHeight - 1), PrinterImage); - if xPage <> xPageNum then - Printer.NewPage; - end; - if yPage <> yPageNum then - Printer.NewPage; - end; - - // Restore tree font. - Font := SaveTreeFont; - SaveTreeFont.Free; - Printer.EndDoc; - finally - PrinterImage.Free; - Image.Free; - EndUpdate; - end; - end; -end; -{$endif} -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.ProcessDrop(DataObject: IDataObject; TargetNode: PVirtualNode; var Effect: Integer; - Mode: TVTNodeAttachMode): Boolean; - -// Recreates the (sub) tree structure serialized into memory and provided by DataObject. The new nodes are attached to -// the passed node or FRoot if TargetNode is nil. -// Returns True on success, i.e. the CF_VIRTUALTREE format is supported by the data object and the structure could be -// recreated, otherwise False. - -var - Source: TBaseVirtualTree; - -begin - Result := False; - if Mode = amNoWhere then - Effect := DROPEFFECT_NONE - else - begin - BeginUpdate; - // try to get the source tree of the operation - Source := GetTreeFromDataObject(DataObject); - if Assigned(Source) then - Source.BeginUpdate; - try - try - // Before adding the new nodes try to optimize the operation if source and target tree reside in - // the same application and operation is a move. - if ((Effect and DROPEFFECT_MOVE) <> 0) and Assigned(Source) then - begin - // If both copy and move are specified then prefer a copy because this is not destructing. - Result := ProcessOLEData(Source, DataObject, TargetNode, Mode, (Effect and DROPEFFECT_COPY) = 0); - // Since we made an optimized move or a copy there's no reason to act further after DoDragging returns. - Effect := DROPEFFECT_NONE; - end - else - // Act only if move or copy operation is requested. - if (Effect and (DROPEFFECT_MOVE or DROPEFFECT_COPY)) <> 0 then - Result := ProcessOLEData(Source, DataObject, TargetNode, Mode, False) - else - Result := False; - except - Effect := DROPEFFECT_NONE; - end; - finally - if Assigned(Source) then - Source.EndUpdate; - EndUpdate; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -type - // needed to handle OLE global memory objects - TOLEMemoryStream = class(TCustomMemoryStream) - public - function Write(const Buffer; Count: Integer): Longint; override; - end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TOLEMemoryStream.Write(const Buffer; Count: Integer): Integer; - -begin - {$ifdef COMPILER_5_UP} - raise EStreamError.CreateRes(PResStringRec(@SCantWriteResourceStreamError)); - {$else} - raise EStreamError.Create(SCantWriteResourceStreamError); - {$endif COMPILER_5_UP} -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.ProcessOLEData(Source: TBaseVirtualTree; DataObject: IDataObject; TargetNode: PVirtualNode; - Mode: TVTNodeAttachMode; Optimized: Boolean): Boolean; - -// Recreates the (sub) tree structure serialized into memory and provided by DataObject. The new nodes are attached to -// the passed node or FRoot if TargetNode is nil according to Mode. Optimized can be set to True if the entire operation -// happens within the same process (i.e. sender and receiver of the OLE operation are located in the same process). -// Optimize = True makes only sense if the operation to carry out is a move hence it is also the indication of the -// operation to be done here. Source is the source of the OLE data and only of use (and usually assigned) when -// an OLE operation takes place in the same application. -// Returns True on success, i.e. the CF_VIRTUALTREE format is supported by the data object and the structure could be -// recreated, otherwise False. - -var - Medium: TStgMedium; - Stream: TStream; - Data: Pointer; - Node: PVirtualNode; - Nodes: TNodeArray; - I: Integer; - Res: HRESULT; - ChangeReason: TChangeReason; - -begin - {$ifdef NeedWindows} - Nodes := nil; - // Check the data format available by the data object. - with StandardOLEFormat do - begin - // Read best format. - cfFormat := CF_VIRTUALTREE; - end; - Result := DataObject.QueryGetData(StandardOLEFormat) = S_OK; - if Result and not (toReadOnly in FOptions.FMiscOptions) then - begin - BeginUpdate; - Result := False; - try - if TargetNode = nil then - TargetNode := FRoot; - if TargetNode = FRoot then - begin - case Mode of - amInsertBefore: - Mode := amAddChildFirst; - amInsertAfter: - Mode := amAddChildLast; - end; - end; - - // Optimized means source is known and in the same process so we can access its pointers, which avoids duplicating - // the data while doing a serialization. Can only be used with cut'n paste and drag'n drop with move effect. - if Optimized then - begin - if tsOLEDragging in Source.FStates then - Nodes := Source.FDragSelection - else - Nodes := Source.GetSortedCutCopySet(True); - - if Mode in [amInsertBefore,amAddChildLast] then - begin - for I := 0 to High(Nodes) do - if not HasAsParent(TargetNode, Nodes[I]) then - Source.MoveTo(Nodes[I], TargetNode, Mode, False); - end - else - begin - for I := High(Nodes) downto 0 do - if not HasAsParent(TargetNode, Nodes[I]) then - Source.MoveTo(Nodes[I], TargetNode, Mode, False); - end; - Result := True; - end - else - begin - if Source = Self then - ChangeReason := crNodeCopied - else - ChangeReason := crNodeAdded; - Res := DataObject.GetData(StandardOLEFormat, Medium); - if Res = S_OK then - begin - case Medium.tymed of - TYMED_ISTREAM, // IStream interface - TYMED_HGLOBAL: // global memory block - begin - Stream := nil; - if Medium.tymed = TYMED_ISTREAM then - Stream := TOLEStream.Create(IUnknown(Medium.Pstm) as IStream) - else - begin - Data := GlobalLock(Medium.hGlobal); - if Assigned(Data) then - begin - // Get the total size of data to retrieve. - I := PCardinal(Data)^; - Inc(PCardinal(Data)); - Stream := TOLEMemoryStream.Create; - TOLEMemoryStream(Stream).SetPointer(Data, I); - end; - end; - - if Assigned(Stream) then - try - while Stream.Position < Stream.Size do - begin - Node := MakeNewNode; - InternalConnectNode(Node, TargetNode, Self, Mode); - InternalAddFromStream(Stream, VTTreeStreamVersion, Node); - // This seems a bit strange because of the callback for granting to add the node - // which actually comes after the node has been added. The reason is that the node must - // contain valid data otherwise I don't see how the application can make a funded decision. - if not DoNodeCopying(Node, TargetNode) then - DeleteNode(Node) - else - DoNodeCopied(Node); - StructureChange(Node, ChangeReason); - - // In order to maintain the same node order when restoring nodes in the case of amInsertAfter - // we have to move the reference node continously. Othwise we would end up with reversed node order. - if Mode = amInsertAfter then - TargetNode := Node; - end; - Result := True; - finally - Stream.Free; - if Medium.tymed = TYMED_HGLOBAL then - GlobalUnlock(Medium.hGlobal); - end; - end; - end; - ReleaseStgMedium(@Medium); - end; - end; - finally - EndUpdate; - end; - end; - {$endif} -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.ReinitChildren(Node: PVirtualNode; Recursive: Boolean); - -// Forces all child nodes of Node to be reinitialized. -// If Recursive is True then also the grandchildren are reinitialized. - -var - Run: PVirtualNode; - -begin - if Assigned(Node) then - begin - InitChildren(Node); - Run := Node.FirstChild; - end - else - begin - InitChildren(FRoot); - Run := FRoot.FirstChild; - end; - - while Assigned(Run) do - begin - ReinitNode(Run, Recursive); - Run := Run.NextSibling; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.ReinitNode(Node: PVirtualNode; Recursive: Boolean); - -// Forces the given node and all its children (if recursive is True) to be initialized again without -// modifying any data in the nodes nor deleting children (unless the application requests a different amount). - -begin - if Assigned(Node) and (Node <> FRoot) then - begin - // Remove dynamic styles. - Node.States := Node.States - [vsChecking, vsCutOrCopy, vsDeleting, vsHeightMeasured]; - InitNode(Node); - end; - - if Recursive then - ReinitChildren(Node, True); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.RepaintNode(Node: PVirtualNode); - -// Causes an immediate repaint of the given node. - -var - R: Trect; - -begin - if Assigned(Node) and (Node <> FRoot) then - begin - R := GetDisplayRect(Node, -1, False); - RedrawWindow(Handle, @R, 0, RDW_INVALIDATE or RDW_UPDATENOW or RDW_NOERASE or RDW_VALIDATE or RDW_NOCHILDREN); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.ResetNode(Node: PVirtualNode); - -// Deletes all children of the given node and marks it as being uninitialized. - -begin - DoCancelEdit; - if (Node = nil) or (Node = FRoot) then - Clear - else - begin - DoReset(Node); - DeleteChildren(Node); - // Remove initialized and other dynamic styles, keep persistent styles. - Node.States := Node.States - [vsInitialized, vsChecking, vsCutOrCopy, vsDeleting, vsHasChildren, vsExpanded, - vsHeightMeasured]; - InvalidateNode(Node); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SaveToFile(const FileName: TFileName); - -// Saves the entire content of the tree into a file (see further notes in SaveToStream). - -var - FileStream: TFileStream; - -begin - FileStream := TFileStream.Create(FileName, fmCreate); - try - SaveToStream(FileStream); - finally - FileStream.Free; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SaveToStream(Stream: TStream; Node: PVirtualNode = nil); - -// Saves Node and all its children to Stream. If Node is nil then all top level nodes will be stored. -// Note: You should be careful about assuming what is actually saved. The problem here is that we are dealing with -// virtual data. The tree can so not know what it has to save. The only fact we reliably know is the tree's -// structure. To be flexible for future enhancements as well as unknown content (unknown to the tree class which -// is saving/loading the stream) a chunk based approach is used here. Every tree class handles only those -// chunks which are not handled by an anchestor class and are known by the class. -// -// The base tree class saves only the structure of the tree along with application provided data. descendants may -// optionally add their own chunks to store additional information. See: WriteChunks. - -var - Count: Cardinal; - -begin - Stream.Write(MagicID, SizeOf(MagicID)); - if Node = nil then - begin - // Keep number of top level nodes for easy restauration. - Count := FRoot.ChildCount; - Stream.WriteBuffer(Count, SizeOf(Count)); - - // Save entire tree here. - Node := FRoot.FirstChild; - while Assigned(Node) do - begin - WriteNode(Stream, Node); - Node := Node.NextSibling; - end; - end - else - begin - Count := 1; - Stream.WriteBuffer(Count, SizeOf(Count)); - WriteNode(Stream, Node); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.ScrollIntoView(Node: PVirtualNode; Center: Boolean; Horizontally: Boolean = False): Boolean; - -// Scrolls the tree so that the given node is in the client area and returns True if the tree really has been -// scrolled (e.g. to avoid further updates) else returns False. If extened focus is enabled then the tree will also -// be horizontally scrolled if needed. -// Note: All collapsed parents of the node are expanded. - -var - R: TRect; - Run: PVirtualNode; - UseColumns, - HScrollBarVisible: Boolean; - NewOffset: Integer; - -begin - Result := False; - if Assigned(Node) and (Node <> FRoot) then - begin - // Make sure all parents of the node are expanded. - Run := Node.Parent; - while Run <> FRoot do - begin - if not (vsExpanded in Run.States) then - ToggleNode(Run); - Run := Run.Parent; - end; - UseColumns := FHeader.UseColumns; - if UseColumns then - R := GetDisplayRect(Node, FFocusedColumn, not (toGridExtensions in FOptions.FMiscOptions)) - else - R := GetDisplayRect(Node, NoColumn, not (toGridExtensions in FOptions.FMiscOptions)); - - // The returned rectangle can never be empty after the expand code above. - // 1) scroll vertically - if R.Top < 0 then - begin - if Center then - SetOffsetY(FOffsetY - R.Top + ClientHeight div 2) - else - SetOffsetY(FOffsetY - R.Top); - Result := True; - end - else - if (R.Bottom > ClientHeight) or Center then - begin - HScrollBarVisible := (ScrollBarOptions.ScrollBars in [ssBoth, ssHorizontal]) and - (ScrollBarOptions.AlwaysVisible or (Integer(FRangeX) > ClientWidth)); - if Center then - SetOffsetY(FOffsetY - R.Bottom + ClientHeight div 2) - else - SetOffsetY(FOffsetY - R.Bottom + ClientHeight); - // When scrolling up and the horizontal scroll appears because of the operation - // then we have to move up the node the horizontal scrollbar's height too - // 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)); - Result := True; - end; - - if Horizontally then - begin - // 2) scroll horizontally - if Header.Columns.GetVisibleFixedWidth > 0 then - begin - if (Abs(R.Left - Header.Columns.GetVisibleFixedWidth) > 1) then - begin - NewOffset := FEffectiveOffsetX - (R.Left - Header.Columns.GetVisibleFixedWidth); - if UseRightToLeftAlignment then - SetOffsetX(-Integer(FRangeX) + ClientWidth + NewOffset) - else - SetOffsetX(-NewOffset); - Result := True; - end; - end - else - if (R.Right > ClientWidth) or (R.Left < 0) then - begin - NewOffset := FEffectiveOffsetX + ((R.Left + R.Right) div 2) - (ClientWidth div 2); - if UseRightToLeftAlignment then - SetOffsetX(-Integer(FRangeX) + ClientWidth + NewOffset) - else - SetOffsetX(-NewOffset); - Result := True; - end; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SelectAll(VisibleOnly: Boolean); - -// Select all nodes in the tree. -// If VisibleOnly is True then only visible nodes are selected. - -var - Run: PVirtualNode; - NextFunction: function(Node: PVirtualNode): PVirtualNode of object; - -begin - if toMultiSelect in FOptions.FSelectionOptions then - begin - ClearTempCache; - if VisibleOnly then - begin - Run := GetFirstVisible; - NextFunction := GetNextVisible; - end - else - begin - Run := GetFirst; - NextFunction := GetNext; - end; - - while Assigned(Run) do - begin - if not(vsSelected in Run.States) then - InternalCacheNode(Run); - Run := NextFunction(Run); - end; - if FTempNodeCount > 0 then - AddToSelection(FTempNodeCache, FTempNodeCount); - ClearTempCache; - Invalidate; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.Sort(Node: PVirtualNode; Column: TColumnIndex; Direction: TSortDirection; DoInit: Boolean = True); - -// Sorts the given node. The application is queried about how to sort via the OnCompareNodes event. -// Column is simply passed to the the compare function so the application can also sort in a particular column. -// In order to free the application from taking care about the sort direction the parameter Direction is used. -// This way the application can always sort in increasing order, while this method reorders nodes according to this flag. - - //--------------- local functions ------------------------------------------- - - function MergeAscending(A, B: PVirtualNode): PVirtualNode; - - // Merges A and B (which both must be sorted via Compare) into one list. - - var - Dummy: TVirtualNode; - - begin - // This avoids checking for Result = nil in the loops. - Result := @Dummy; - while Assigned(A) and Assigned(B) do - begin - if DoCompare(A, B, Column) <= 0 then - begin - Result.NextSibling := A; - Result := A; - A := A.NextSibling; - end - else - begin - Result.NextSibling := B; - Result := B; - B := B.NextSibling; - end; - end; - - // Just append the list which is not nil (or set end of result list to nil if both lists are nil). - if Assigned(A) then - Result.NextSibling := A - else - Result.NextSibling := B; - // return start of the new merged list - Result := Dummy.NextSibling; - end; - - //--------------------------------------------------------------------------- - - function MergeDescending(A, B: PVirtualNode): PVirtualNode; - - // Merges A and B (which both must be sorted via Compare) into one list. - - var - Dummy: TVirtualNode; - - begin - // this avoids checking for Result = nil in the loops - Result := @Dummy; - while Assigned(A) and Assigned(B) do - begin - if DoCompare(A, B, Column) >= 0 then - begin - Result.NextSibling := A; - Result := A; - A := A.NextSibling; - end - else - begin - Result.NextSibling := B; - Result := B; - B := B.NextSibling; - end; - end; - - // Just append the list which is not nil (or set end of result list to nil if both lists are nil). - if Assigned(A) then - Result.NextSibling := A - else - Result.NextSibling := B; - // Return start of the newly merged list. - Result := Dummy.NextSibling; - end; - - //--------------------------------------------------------------------------- - - function MergeSortAscending(var Node: PVirtualNode; N: Cardinal): PVirtualNode; - - // Sorts the list of nodes given by Node (which must not be nil). - - var - A, B: PVirtualNode; - - begin - if N > 1 then - begin - A := MergeSortAscending(Node, N div 2); - B := MergeSortAscending(Node, (N + 1) div 2); - Result := MergeAscending(A, B); - end - else - begin - Result := Node; - Node := Node.NextSibling; - Result.NextSibling := nil; - end; - end; - - //--------------------------------------------------------------------------- - - function MergeSortDescending(var Node: PVirtualNode; N: Cardinal): PVirtualNode; - - // Sorts the list of nodes given by Node (which must not be nil). - - var - A, B: PVirtualNode; - - begin - if N > 1 then - begin - A := MergeSortDescending(Node, N div 2); - B := MergeSortDescending(Node, (N + 1) div 2); - Result := MergeDescending(A, B); - end - else - begin - Result := Node; - Node := Node.NextSibling; - Result.NextSibling := nil; - end; - end; - - //--------------- end local functions --------------------------------------- - -var - Run: PVirtualNode; - Index: Cardinal; - -begin - InterruptValidation; - if tsEditPending in FStates then - begin - StopTimer(EditTimer); - DoStateChange([], [tsEditPending]); - end; - - if not (tsEditing in FStates) or DoEndEdit then - begin - if Node = nil then - Node := FRoot; - if vsHasChildren in Node.States then - begin - if (Node.ChildCount = 0) and DoInit then - InitChildren(Node); - // Make sure the children are valid, so they can be sorted at all. - if DoInit and (Node.ChildCount > 0) then - ValidateChildren(Node, False); - // Child count might have changed. - if Node.ChildCount > 1 then - begin - // Sort the linked list, check direction flag only once. - if Direction = sdAscending then - Node.FirstChild := MergeSortAscending(Node.FirstChild, Node.ChildCount) - else - Node.FirstChild := MergeSortDescending(Node.FirstChild, Node.ChildCount); - // Consolidate the child list finally. - Run := Node.FirstChild; - Run.PrevSibling := nil; - Index := 0; - repeat - Run.Index := Index; - Inc(Index); - if Run.NextSibling = nil then - Break; - Run.NextSibling.PrevSibling := Run; - Run := Run.NextSibling; - until False; - Node.LastChild := Run; - - InvalidateCache; - end; - if FUpdateCount = 0 then - begin - ValidateCache; - Invalidate; - end; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.SortTree(Column: TColumnIndex; Direction: TSortDirection; DoInit: Boolean = True); - - //--------------- local function -------------------------------------------- - - procedure DoSort(Node: PVirtualNode); - - // Recursively sorts Node and its child nodes. - - var - Run: PVirtualNode; - - begin - Sort(Node, Column, Direction, DoInit); - - Run := Node.FirstChild; - while Assigned(Run) do - begin - if DoInit and not (vsInitialized in Run.States) then - InitNode(Run); - if vsInitialized in Run.States then - DoSort(Run); - Run := Run.NextSibling; - end; - end; - - //--------------- end local function ---------------------------------------- - -begin - // Instead of wrapping the sort using BeginUpdate/EndUpdate simply the update counter - // is modified. Otherwise the EndUpdate call will recurse here. - Inc(FUpdateCount); - try - if Column > InvalidColumn then - DoSort(FRoot); - InvalidateCache; - finally - if FUpdateCount > 0 then - Dec(FUpdateCount); - if FUpdateCount = 0 then - begin - ValidateCache; - Invalidate; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.ToggleNode(Node: PVirtualNode); - -// Changes a node's expand state to the opposite state. - -var - LastTopNode, - Child: PVirtualNode; - NewHeight: Integer; - NeedUpdate: Boolean; - ToggleData: TToggleAnimationData; - -begin - Assert(Assigned(Node), 'Node must not be nil.'); - NeedUpdate := False; - - // We don't need to switch the expand state if the node is being deleted otherwise some - // updates (e.g. visible node count) are done twice with disasterous results). - if [vsDeleting, vsToggling] * Node.States = [] then - begin - Include(Node.States, vsToggling); - - // LastTopNode is needed to know when the entire tree scrolled during toggling. - // It is of course only needed when we also update the display here. - if FUpdateCount = 0 then - LastTopNode := GetTopNode - else - LastTopNode := nil; - - if vsExpanded in Node.States then - begin - if DoCollapsing(Node) then - begin - NeedUpdate := True; - - if (FUpdateCount = 0) and (toAnimatedToggle in FOptions.FAnimationOptions) and not (tsCollapsing in FStates) then - begin - Application.CancelHint; - UpdateWindow(Handle); - - // animated collapsing - with ToggleData do - begin - Expand := False; - R := GetDisplayRect(Node, NoColumn, False); - R.Bottom := ClientHeight; - Inc(R.Top, NodeHeight[Node]); - - // No animation necessary if the node is below the current client height. - if R.Top < R.Bottom then - begin - Window := Handle; - DC := GetDC(Handle); - Self.Brush.Color := Color; - Brush := Self.Brush.Handle; - try - Animate(Min(R.Bottom - R.Top + 1, Node.TotalHeight - NodeHeight[Node]), FAnimationDuration, ToggleCallback, - @ToggleData); - finally - ReleaseDC(Window, DC); - end; - end; - end; - end; - - // collapse the node - AdjustTotalHeight(Node, NodeHeight[Node]); - if FullyVisible[Node] then - Dec(FVisibleCount, CountVisibleChildren(Node)); - Exclude(Node.States, vsExpanded); - DoCollapsed(Node); - - // Remove child nodes now, if enabled. - if (toAutoFreeOnCollapse in FOptions.FAutoOptions) and (Node.ChildCount > 0) then - begin - DeleteChildren(Node); - Include(Node.States, vsHasChildren); - end; - end; - end - else - if DoExpanding(Node) then - begin - NeedUpdate := True; - // expand the node, need to adjust the height - if not (vsInitialized in Node.States) then - InitNode(Node); - if (vsHasChildren in Node.States) and (Node.ChildCount = 0) then - InitChildren(Node); - - // Avoid setting the vsExpanded style if there are no child nodes. - if Node.ChildCount > 0 then - begin - // Iterate through the child nodes without initializing them. We have to determine the entire height. - NewHeight := 0; - Child := Node.FirstChild; - repeat - if vsVisible in Child.States then - Inc(NewHeight, Child.TotalHeight); - Child := Child.NextSibling; - until Child = nil; - - if FUpdateCount = 0 then - begin - ToggleData.R := GetDisplayRect(Node, NoColumn, False); - - // Do animated expanding if enabled and it is not the last visible node to be expanded. - if (ToggleData.R.Top < ClientHeight) and ([tsPainting, tsExpanding] * FStates = []) and - (toAnimatedToggle in FOptions.FAnimationOptions) and (GetNextVisibleNoInit(Node) <> nil) then - begin - Application.CancelHint; - UpdateWindow(Handle); - // animated expanding - with ToggleData do - begin - Inc(R.Top, NodeHeight[Node]); - R.Bottom := ClientHeight; - if R.Bottom > R.Top then - begin - Expand := True; - Window := Handle; - DC := GetDC(Handle); - - Self.Brush.Color := Color; - Brush := Self.Brush.Handle; - try - Animate(Min(R.Bottom - R.Top + 1, NewHeight), FAnimationDuration, ToggleCallback, @ToggleData); - finally - ReleaseDC(Window, DC); - end; - end; - end; - end; - end; - - Include(Node.States, vsExpanded); - AdjustTotalHeight(Node, NewHeight, True); - if FullyVisible[Node] then - Inc(FVisibleCount, CountVisibleChildren(Node)); - - DoExpanded(Node); - end; - end; - - if NeedUpdate then - begin - InvalidateCache; - if FUpdateCount = 0 then - begin - ValidateCache; - if Node.ChildCount > 0 then - begin - UpdateScrollbars(True); - // Scroll as much child nodes into view as possible if the node has been expanded. - if (toAutoScrollOnExpand in FOptions.FAutoOptions) and (vsExpanded in Node.States) then - begin - if Integer(Node.TotalHeight) <= ClientHeight then - ScrollIntoView(GetLastChild(Node), toCenterScrollIntoView in FOptions.SelectionOptions) - else - TopNode := Node; - end; - - // Check for automatically scrolled tree. - if LastTopNode <> GetTopNode then - Invalidate - else - InvalidateToBottom(Node); - end - else - InvalidateNode(Node); - end; - end; - Exclude(Node.States, vsToggling); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.UpdateAction(Action: TBasicAction): Boolean; - -// Support for standard actions. - -begin - if not Focused then - Result := inherited UpdateAction(Action) - else - begin - Result := (Action is TEditCut) or (Action is TEditCopy) - {$ifdef COMPILER_5_UP} or (Action is TEditDelete) {$endif COMPILER_5_UP}; - - if Result then - TAction(Action).Enabled := (FSelectionCount > 0) and - ({$ifdef COMPILER_5_UP} (Action is TEditDelete) or {$endif COMPILER_5_UP} (FClipboardFormats.Count > 0)) - else - begin - Result := Action is TEditPaste; - if Result then - TAction(Action).Enabled := True - else - begin - {$ifdef COMPILER_5_UP} - Result := Action is TEditSelectAll; - if Result then - TAction(Action).Enabled := (toMultiSelect in FOptions.FSelectionOptions) and (FVisibleCount > 0) - else - {$endif COMPILER_5_UP} - Result := inherited UpdateAction(Action); - end; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.UpdateHorizontalScrollBar(DoRepaint: Boolean); - -var - ScrollInfo: TScrollInfo; - -begin - if FHeader.UseColumns then - FRangeX := FHeader.FColumns.TotalWidth - else - FRangeX := GetMaxRightExtend; - - // Adjust effect scroll offset depending on bidi mode. - if UseRightToLeftAlignment then - FEffectiveOffsetX := Integer(FRangeX) - ClientWidth + FOffsetX - else - FEffectiveOffsetX := -FOffsetX; - - if FScrollBarOptions.ScrollBars in [ssHorizontal, ssBoth] then - begin - FillChar(ScrollInfo, SizeOf(ScrollInfo), 0); - ScrollInfo.cbSize := SizeOf(ScrollInfo); - ScrollInfo.fMask := SIF_ALL; - {$ifdef UseFlatScrollbars} - FlatSB_GetScrollInfo(Handle, SB_HORZ, ScrollInfo); - {$else} - GetScrollInfo(Handle, SB_HORZ, ScrollInfo); - {$endif UseFlatScrollbars} - - if (Integer(FRangeX) > ClientWidth) or FScrollBarOptions.AlwaysVisible then - begin - DoShowScrollBar(SB_HORZ, True); - - ScrollInfo.nMin := 0; - ScrollInfo.nMax := FRangeX; - ScrollInfo.nPos := FEffectiveOffsetX; - ScrollInfo.nPage := Max(0, ClientWidth + 1); - - ScrollInfo.fMask := SIF_ALL or ScrollMasks[FScrollBarOptions.AlwaysVisible]; - {$ifdef UseFlatScrollbars} - FlatSB_SetScrollInfo(Handle, SB_HORZ, ScrollInfo, DoRepaint); - {$else} - SetScrollInfo(Handle, SB_HORZ, ScrollInfo, DoRepaint); - {$endif UseFlatScrollbars} - end - else - begin - ScrollInfo.nMin := 0; - ScrollInfo.nMax := 0; - ScrollInfo.nPos := 0; - ScrollInfo.nPage := 0; - DoShowScrollBar(SB_HORZ, False); - {$ifdef UseFlatScrollbars} - FlatSB_SetScrollInfo(Handle, SB_HORZ, ScrollInfo, False); - {$else} - SetScrollInfo(Handle, SB_HORZ, ScrollInfo, False); - {$endif UseFlatScrollbars} - end; - - // Since the position is automatically changed if it doesn't meet the range - // we better read the current position back to stay synchronized. - {$ifdef UseFlatScrollbars} - FScrollOffsetX := FlatSB_GetScrollPos(Handle, SB_HORZ); - {$else} - //todo: Use get scrollinfo instead of GetScrollPos?? - FEffectiveOffsetX := GetScrollPos(Handle, SB_HORZ); - {$endif UseFlatScrollbars} - if UseRightToLeftAlignment then - SetOffsetX(-Integer(FRangeX) + ClientWidth + FEffectiveOffsetX) - else - SetOffsetX(-FEffectiveOffsetX); - end - else - begin - DoShowScrollBar(SB_HORZ, False); - - // Reset the current horizontal offset to account for window resize etc. - SetOffsetX(FOffsetX); - end; - Logger.Send(lcPaintDetails,'FEffectiveOffsetX after UpdateHScrollbar',FEffectiveOffsetX); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.UpdateScrollBars(DoRepaint: Boolean); - -// adjusts scrollbars to reflect current size and paint offset of the tree - -begin - if HandleAllocated then - begin - UpdateVerticalScrollBar(DoRepaint); - UpdateHorizontalScrollBar(DoRepaint); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.UpdateVerticalScrollBar(DoRepaint: Boolean); - -var - ScrollInfo: TScrollInfo; - -begin - // Total node height includes the height of the invisble root node. - if FRoot.TotalHeight < FDefaultNodeHeight then - FRoot.TotalHeight := FDefaultNodeHeight; - FRangeY := FRoot.TotalHeight - FRoot.NodeHeight + FBottomSpace; - - if FScrollBarOptions.ScrollBars in [ssVertical, ssBoth] then - begin - ScrollInfo.cbSize := SizeOf(ScrollInfo); - ScrollInfo.fMask := SIF_ALL; - {$ifdef UseFlatScrollbars} - FlatSB_GetScrollInfo(Handle, SB_VERT, ScrollInfo); - {$else} - GetScrollInfo(Handle, SB_VERT, ScrollInfo); - {$endif UseFlatScrollbars} - - if (Integer(FRangeY) > ClientHeight) or FScrollBarOptions.AlwaysVisible then - begin - DoShowScrollBar(SB_VERT, True); - - ScrollInfo.nMin := 0; - ScrollInfo.nMax := FRangeY; - ScrollInfo.nPos := -FOffsetY; - ScrollInfo.nPage := Max(0, ClientHeight + 1); - - ScrollInfo.fMask := SIF_ALL or ScrollMasks[FScrollBarOptions.AlwaysVisible]; - {$ifdef UseFlatScrollbars} - FlatSB_SetScrollInfo(Handle, SB_VERT, ScrollInfo, DoRepaint); - {$else} - SetScrollInfo(Handle, SB_VERT, ScrollInfo, DoRepaint); - {$endif UseFlatScrollbars} - end - else - begin - ScrollInfo.nMin := 0; - ScrollInfo.nMax := 0; - ScrollInfo.nPos := 0; - ScrollInfo.nPage := 0; - DoShowScrollBar(SB_VERT, False); - {$ifdef UseFlatScrollbars} - FlatSB_SetScrollInfo(Handle, SB_VERT, ScrollInfo, False); - {$else} - SetScrollInfo(Handle, SB_VERT, ScrollInfo, False); - {$endif UseFlatScrollbars} - end; - - // Since the position is automatically changed if it doesn't meet the range - // we better read the current position back to stay synchronized. - {$ifdef UseFlatScrollbars} - SetOffsetY(-FlatSB_GetScrollPos(Handle, SB_VERT)); - {$else} - SetOffsetY(-GetScrollPos(Handle, SB_VERT)); - {$endif UseFlatScrollBars} - end - else - begin - DoShowScrollbar(SB_VERT, False); - - // Reset the current vertical offset to account for window resize etc. - SetOffsetY(FOffsetY); - end; -end; - -function TBaseVirtualTree.UseRightToLeftAlignment: Boolean; -begin - //todo_lcl - Result:=False; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TBaseVirtualTree.UseRightToLeftReading: Boolean; - -// The tree can handle right-to-left reading also on non-middle-east systems, so we cannot use the same function as -// it is implemented in TControl. - -begin - Result := BiDiMode <> bdLeftToRight; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.ValidateChildren(Node: PVirtualNode; Recursive: Boolean); - -// Ensures that the children of the given node (and all their children, if Recursive is True) are initialized. -// Node must already be initialized - -var - Child: PVirtualNode; - -begin - if Node = nil then - Node := FRoot; - - if (vsHasChildren in Node.States) and (Node.ChildCount = 0) then - InitChildren(Node); - Child := Node.FirstChild; - while Assigned(Child) do - begin - ValidateNode(Child, Recursive); - Child := Child.NextSibling; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TBaseVirtualTree.ValidateNode(Node: PVirtualNode; Recursive: Boolean); - -// Ensures that the given node (and all its children, if Recursive is True) are initialized. - -var - Child: PVirtualNode; - -begin - if Node = nil then - Node := FRoot - else - if not (vsInitialized in Node.States) then - InitNode(Node); - - if Recursive then - begin - if (vsHasChildren in Node.States) and (Node.ChildCount = 0) then - InitChildren(Node); - Child := Node.FirstChild; - while Assigned(Child) do - begin - ValidateNode(Child, recursive); - Child := Child.NextSibling; - end; - 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 - StringOptions := Self.StringOptions; - 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); - 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.CMAutoAdjust(var Message: TLMessage); - -begin - AutoAdjustSize; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTEdit.CMExit(var Message: TLMessage); - -begin - if Assigned(FLink) and not FLink.FStopping then - with FLink, FTree do - begin - if (toAutoAcceptEditChange in TreeOptions.StringOptions) then - DoEndEdit - else - DoCancelEdit; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTEdit.CMRelease(var Message: TLMessage); - -begin - Free; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTEdit.CNCommand(var Message: TLMCommand); - -begin - if Assigned(FLink) and Assigned(FLink.FTree) and (Message.NotifyCode = EN_UPDATE) and - not (toGridExtensions in FLink.FTree.FOptions.FMiscOptions) and - not (vsMultiline in FLink.FNode.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. - if IsWinNT then - AutoAdjustSize - else - PostMessage(Handle, CM_AUTOADJUST, 0, 0); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTEdit.WMChar(var Message: TLMChar); - -begin - if not (Message.CharCode in [VK_ESCAPE, VK_TAB]) then - inherited; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTEdit.WMDestroy(var Message: TLMDestroy); - -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.FStopping 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: TLMNoParams); - -begin - inherited; - - Message.Result := Message.Result or DLGC_WANTALLKEYS or DLGC_WANTTAB or DLGC_WANTARROWS; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTEdit.WMKeyDown(var Message: TLMKeyDown); - -// Handles some control keys. - -var - Shift: TShiftState; - EndEdit: Boolean; - Tree: TBaseVirtualTree; - -begin - case Message.CharCode of - VK_ESCAPE: - begin - Tree := FLink.FTree; - FLink.FTree.DoCancelEdit; - Tree.SetFocus; - end; - VK_RETURN: - begin - EndEdit := not (vsMultiline in FLink.FNode.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.FTree; - FLink.FTree.InvalidateNode(FLink.FNode); - FLink.FTree.DoEndEdit; - Tree.SetFocus; - end; - end; - VK_UP: - begin - if not (vsMultiline in FLink.FNode.States) then - Message.CharCode := VK_LEFT; - inherited; - end; - VK_DOWN: - begin - if not (vsMultiline in FLink.FNode.States) then - Message.CharCode := VK_RIGHT; - inherited; - 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 - DC: HDC; - Size: TSize; - LastFont: THandle; - -begin - if not (vsMultiline in FLink.FNode.States) then - begin - // avoid flicker - SendMessage(Handle, WM_SETREDRAW, 0, 0); - - DC := GetDC(Handle); - LastFont := SelectObject(DC, Font.Handle); - try - // Read needed space for the current text. - {$ifdef TntSupport} - GetTextExtentPoint32W(DC, PWideChar(Text), Length(Text), Size); - {$else} - GetTextExtentPoint32(DC, PChar(Text), Length(Text), Size); - {$endif TntSupport} - Inc(Size.cx, 2 * FLink.FTree.FTextMargin); - - // Repaint associated node if the edit becomes smaller. - if Size.cx < Width then - FLink.FTree.InvalidateNode(FLink.FNode); - - if FLink.FAlignment = taRightJustify then - FLink.SetBounds(Rect(Left + Width - Size.cx, Top, Left + Width, Top + Height)) - else - FLink.SetBounds(Rect(Left, Top, Left + Size.cx, Top + Height)); - finally - SelectObject(DC, LastFont); - ReleaseDC(Handle, DC); - SendMessage(Handle, WM_SETREDRAW, 1, 0); - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVTEdit.CreateParams(var Params: TCreateParams); - -begin - inherited; - - // 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.FNode.States then - Style := Style and not (ES_AUTOHSCROLL or WS_HSCROLL) or WS_VSCROLL or ES_AUTOVSCROLL; - if tsUseThemes in FLink.FTree.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; - -//---------------------------------------------------------------------------------------------------------------------- - -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 - 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; - 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.FLink := nil; - FEdit.FRefLink := nil; - 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.FLink := nil; - FEdit.FRefLink := nil; - 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: WideString; - -begin - Result := Tree is TCustomVirtualStringTree; - if Result then - begin - FTree := Tree as TCustomVirtualStringTree; - FNode := Node; - FColumn := Column; - // Initial size, font and text of the node. - FTree.GetTextInfo(Node, Column, FEdit.Font, FTextBounds, Text); - FEdit.Font.Color := clWindowText; - FEdit.Parent := Tree; - //todo_lcl_check see effect of recreatewnd - RecreateWnd(FEdit); - FEdit.HandleNeeded; - 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: TLMessage); - -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 - Offset: Integer; - -begin - if not FStopping then - begin - with R do - begin - // 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 Left < 0 then - Left := 0; - if Right - Left < 30 then - begin - if FAlignment = taRightJustify then - Left := Right - 30 - else - Right := Left + 30; - end; - if Right > FTree.ClientWidth then - 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; - Offset := 2; - if tsUseThemes in FTree.FStates then - Inc(Offset); - InflateRect(R, -FTree.FTextMargin + Offset, Offset); - if not (vsMultiline in FNode.States) then - OffsetRect(R, 0, FTextBounds.Top - FEdit.Top); - - SendMessage(FEdit.Handle, EM_SETRECTNP, 0, Integer(@R)); - end; - end; -end; - -//----------------- TCustomVirtualString ------------------------------------------------------------------------------- - -constructor TCustomVirtualStringTree.Create(AOwner: TComponent); - -begin - inherited; - - FDefaultText := 'Node'; - FInternalDataOffset := AllocateInternalDataArea(SizeOf(Cardinal)); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TCustomVirtualStringTree.GetRenderStartValues(Source: TVSTTextSourceType; var Node: PVirtualNode; - var NextNodeProc: TGetNextNodeProc); - -begin - case Source of - tstInitialized: - begin - Node := GetFirstInitialized; - NextNodeProc := GetNextInitialized; - end; - tstSelected: - begin - Node := GetFirstSelected; - NextNodeProc := GetNextSelected; - end; - tstCutCopySet: - begin - Node := GetFirstCutCopy; - NextNodeProc := GetNextCutCopy; - end; - tstVisible: - begin - Node := GetFirstVisible; - NextNodeProc := GetNextVisible; - end; - else // tstAll - Node := GetFirst; - NextNodeProc := GetNext; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TCustomVirtualStringTree.GetOptions: TCustomStringTreeOptions; - -begin - Result := FOptions as TCustomStringTreeOptions; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TCustomVirtualStringTree.GetText(Node: PVirtualNode; Column: TColumnIndex): WideString; - -begin - Assert(Assigned(Node), 'Node must not be nil.'); - - if not (vsInitialized in Node.States) then - InitNode(Node); - Result := FDefaultText; - - DoGetText(Node, Column, ttNormal, Result); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TCustomVirtualStringTree.InitializeTextProperties(var PaintInfo: TVTPaintInfo); - -// Initializes default values for customization in PaintNormalText. - -begin - with PaintInfo do - begin - // Set default font values first. - Canvas.Font := Font; - - if (toHotTrack in FOptions.FPaintOptions) and (Node = FCurrentHotNode) then - begin - Canvas.Font.Style := Canvas.Font.Style + [fsUnderline]; - Canvas.Font.Color := FColors.HotColor; - end; - - // Change the font color only if the node also is drawn in selected style. - if poDrawSelection in PaintOptions then - begin - if (Column = FFocusedColumn) or (toFullRowSelect in FOptions.FSelectionOptions) then - begin - if Node = FDropTargetNode then - begin - if (FLastDropMode = dmOnNode) or (vsSelected in Node.States)then - Canvas.Font.Color := clHighlightText; - end - else - if vsSelected in Node.States then - begin - if Focused or (toPopupMode in FOptions.FPaintOptions) then - Canvas.Font.Color := clHighlightText; - end; - end; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TCustomVirtualStringTree.PaintNormalText(var PaintInfo: TVTPaintInfo; TextOutFlags: Integer; - Text: WideString); - -// This method is responsible for painting the given test to target canvas (under consideration of the given rectangles). -// The text drawn here is considered as the normal text in a node. -// Note: NodeWidth is the actual width of the text to be drawn. This does not necessarily correspond to the width of -// the node rectangle. The clipping rectangle comprises the entire node (including tree lines, buttons etc.). - -var - TripleWidth: Integer; - R: TRect; - DrawFormat: Cardinal; - Size: TSize; - -begin - Logger.EnterMethod(lcPaintDetails,'PaintNormalText') ; - InitializeTextProperties(PaintInfo); - with PaintInfo do - begin - R := ContentRect; - //todo_lcl See how TextStyle should be set - //Canvas.TextFlags := 0; - - // Multiline nodes don't need special font handling or text manipulation. - // Note: multiline support requires the Unicode version of DrawText, which is able to do word breaking. - // The emulation in this unit does not support this so we have to use the OS version. However - // DrawTextW is only available on NT/2000/XP and up. Hence there is only partial multiline support - // for 9x/Me. - if vsMultiline in Node.States then - begin - InflateRect(R, -FTextMargin, 0); - DoPaintText(Node, Canvas, Column, ttNormal); - // Disabled node color overrides all other variants. - if (vsDisabled in Node.States) or not Enabled then - Canvas.Font.Color := FColors.DisabledColor; - - // The edit control flag will ensure that no partial line is displayed, that is, only lines - // which are (vertically) fully visible are drawn. - DrawFormat := DT_NOPREFIX or DT_WORDBREAK or DT_END_ELLIPSIS or DT_EDITCONTROL or AlignmentToDrawFlag[Alignment]; - if BidiMode <> bdLeftToRight then - DrawFormat := DrawFormat or DT_RTLREADING; - end - else - begin - InflateRect(R, -FTextMargin, 0); - FFontChanged := False; - TripleWidth := FEllipsisWidth; - DoPaintText(Node, Canvas, Column, ttNormal); - if FFontChanged then - begin - // If the font has been changed then the ellipsis width must be recalculated. - TripleWidth := 0; - // Recalculate also the width of the normal text. - GetTextExtentPoint32W(Canvas.Handle, PWideChar(Text), Length(Text), Size); - NodeWidth := Size.cx + 2 * FTextMargin; - end; - - // Disabled node color overrides all other variants. - if (vsDisabled in Node.States) or not Enabled then - Canvas.Font.Color := FColors.DisabledColor; - - DrawFormat := DT_NOPREFIX or DT_VCENTER or DT_SINGLELINE; - if BidiMode <> bdLeftToRight then - DrawFormat := DrawFormat or DT_RTLREADING; - // Check if the text must be shortend. - if (Column > -1) and ((NodeWidth - 2 * FTextMargin) > R.Right - R.Left) then - begin - Text := DoShortenString(Canvas, Node, Column, Text, R.Right - R.Left, TripleWidth); - if Alignment = taRightJustify then - DrawFormat := DrawFormat or DT_RIGHT - else - DrawFormat := DrawFormat or DT_LEFT; - end - else - DrawFormat := DrawFormat or AlignmentToDrawFlag[Alignment]; - end; - //todo_lcl_check - if not Canvas.TextStyle.Opaque then - SetBkMode(Canvas.Handle, TRANSPARENT) - else - SetBkMode(Canvas.Handle, OPAQUE); - Logger.Send(lcPaintDetails,'Canvas.Brush.Color',Canvas.Brush.Color); - DoTextDrawing(PaintInfo, Text, R, DrawFormat); - end; - Logger.ExitMethod(lcPaintDetails,'PaintNormalText'); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TCustomVirtualStringTree.PaintStaticText(const PaintInfo: TVTPaintInfo; TextOutFlags: Integer; - const Text: WideString); - -// This method retrives and draws the static text bound to a particular node. - -var - R: TRect; - DrawFormat: Cardinal; - -begin - Logger.EnterMethod(lcPaintDetails,'PaintStaticText'); - with PaintInfo do - begin - Canvas.Font := Font; - if toFullRowSelect in FOptions.FSelectionOptions then - begin - if Node = FDropTargetNode then - begin - if (FLastDropMode = dmOnNode) or (vsSelected in Node.States)then - Canvas.Font.Color := clHighlightText - else - Canvas.Font.Color := Font.Color; - end - else - if vsSelected in Node.States then - begin - if Focused or (toPopupMode in FOptions.FPaintOptions) then - Canvas.Font.Color := clHighlightText - else - Canvas.Font.Color := Font.Color; - end; - end; - - DrawFormat := DT_NOPREFIX or DT_VCENTER or DT_SINGLELINE; - //todo_lcl See how Canvas.TextStyle should be - //Canvas.TextFlags := 0; - DoPaintText(Node, Canvas, Column, ttStatic); - - // Disabled node color overrides all other variants. - if (vsDisabled in Node.States) or not Enabled then - Canvas.Font.Color := FColors.DisabledColor; - - R := ContentRect; - if Alignment = taRightJustify then - Dec(R.Right, NodeWidth + FTextMargin) - else - Inc(R.Left, NodeWidth + FTextMargin); - //todo_lcl_check - if not Canvas.TextStyle.Opaque then - SetBkMode(Canvas.Handle, TRANSPARENT) - else - SetBkMode(Canvas.Handle, OPAQUE); - if IsWinNT then - Windows.DrawTextW(Canvas.Handle, PWideChar(Text), Length(Text), R, DrawFormat) - else - DrawTextW(Canvas.Handle, PWideChar(Text), Length(Text), R, DrawFormat, False); - end; - Logger.ExitMethod(lcPaintDetails,'PaintStaticText'); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TCustomVirtualStringTree.ReadText(Reader: TReader); - -begin - case Reader.NextValue of - vaLString, vaString: - SetDefaultText(Reader.ReadString); - else - SetDefaultText(Reader.ReadWideString); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TCustomVirtualStringTree.SetDefaultText(const Value: WideString); - -begin - if FDefaultText <> Value then - begin - FDefaultText := Value; - if not (csLoading in ComponentState) then - Invalidate; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TCustomVirtualStringTree.SetOptions(const Value: TCustomStringTreeOptions); - -begin - FOptions.Assign(Value); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TCustomVirtualStringTree.SetText(Node: PVirtualNode; Column: TColumnIndex; const Value: WideString); - -begin - DoNewText(Node, Column, Value); - InvalidateNode(Node); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TCustomVirtualStringTree.WriteText(Writer: TWriter); - -begin - Writer.WriteWideString(FDefaultText); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TCustomVirtualStringTree.WMSetFont(var Msg: TLMNoParams); - -// Whenever a new font is applied to the tree some default values are determined to avoid frequent -// determination of the same value. - -var - MemDC: HDC; - Run: PVirtualNode; - TM: TTextMetric; - Size: TSize; - Data: PInteger; - -begin - inherited; - //todo_lcl - { - MemDC := CreateCompatibleDC(0); - try - SelectObject(MemDC, Msg.Font); - GetTextMetrics(MemDC, TM); - FTextHeight := TM.tmHeight; - - GetTextExtentPoint32W(MemDC, '...', 3, Size); - FEllipsisWidth := Size.cx; - finally - DeleteDC(MemDC); - end; - - // Have to reset all node widths. - Run := FRoot.FirstChild; - while Assigned(Run) do - begin - Data := InternalData(Run); - if Assigned(Data) then - Data^ := 0; - Run := GetNextNoInit(Run); - end; - } -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TCustomVirtualStringTree.AdjustPaintCellRect(var PaintInfo: TVTPaintInfo; var NextNonEmpty: TColumnIndex); - -// In the case a node spans several columns (if enabled) we need to determine how many columns. -// Note: the autospan feature can only be used with left-to-right layout. - -begin - if (toAutoSpanColumns in FOptions.FAutoOptions) and FHeader.UseColumns and (PaintInfo.BidiMode = bdLeftToRight) then - with FHeader.FColumns, PaintInfo do - begin - // Start with the directly following column. - NextNonEmpty := GetNextVisibleColumn(Column); - - // Auto spanning columns can only be used for left-to-right directionality because the tree is drawn - // from left to right. For RTL directionality it would be necessary to draw it from right to left. - // While this could be managed, it becomes impossible when directionality is mixed. - repeat - if (NextNonEmpty = InvalidColumn) or not ColumnIsEmpty(Node, NextNonEmpty) or - (Items[NextNonEmpty].BidiMode <> bdLeftToRight) then - Break; - Inc(CellRect.Right, Items[NextNonEmpty].Width); - NextNonEmpty := GetNextVisibleColumn(NextNonEmpty); - until False; - end - else - inherited; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TCustomVirtualStringTree.CalculateTextWidth(Canvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex; - Text: WideString): Integer; - -// Determines the width of the given text. - -begin - Result := 2 * FTextMargin; - if Length(Text) > 0 then - begin - Canvas.Font := Font; - DoPaintText(Node, Canvas, Column, ttNormal); - - Inc(Result, DoTextMeasuring(Canvas, Node, Column, Text)); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TCustomVirtualStringTree.ColumnIsEmpty(Node: PVirtualNode; Column: TColumnIndex): Boolean; - -// For hit tests it is necessary to consider cases where columns are empty and automatic column spanning is enabled. -// This method simply checks the given column's text and if this is empty then the column is considered as being empty. - -begin - Result := Length(Text[Node, Column]) = 0; - // If there is no text then let the ancestor decide if the column is to be considered as being empty - // (e.g. by asking the application). If there is text then the column is never be considered as being empty. - if Result then - Result := inherited ColumnIsEmpty(Node, Column); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TCustomVirtualStringTree.DefineProperties(Filer: TFiler); - -begin - inherited; - - // Delphi still cannot handle wide strings properly while streaming - Filer.DefineProperty('WideDefaultText', ReadText, WriteText, FDefaultText <> 'Node'); - Filer.DefineProperty('StringOptions', ReadOldStringOptions, nil, False); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TCustomVirtualStringTree.DoCreateEditor(Node: PVirtualNode; Column: TColumnIndex): IVTEditLink; - -begin - Result := inherited DoCreateEditor(Node, Column); - // Enable generic label editing support if the application does not have own editors. - if Result = nil then - Result := TStringEditLink.Create; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TCustomVirtualStringTree.DoGetNodeHint(Node: PVirtualNode; Column: TColumnIndex; - var LineBreakStyle: TVTTooltipLineBreakStyle): WideString; - -begin - Result := inherited DoGetNodeHint(Node, Column, LineBreakStyle); - if Assigned(FOnGetHint) then - FOnGetHint(Self, Node, Column, LineBreakStyle, Result); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TCustomVirtualStringTree.DoGetNodeTooltip(Node: PVirtualNode; Column: TColumnIndex; - var LineBreakStyle: TVTTooltipLineBreakStyle): WideString; - -begin - Result := inherited DoGetNodeToolTip(Node, Column, LineBreakStyle); - if Assigned(FOnGetHint) then - FOnGetHint(Self, Node, Column, LineBreakStyle, Result) - else - Result := Text[Node, Column]; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TCustomVirtualStringTree.DoGetNodeWidth(Node: PVirtualNode; Column: TColumnIndex; Canvas: TCanvas = nil): Integer; - -// Returns the text width of the given node in pixels. -// This width is stored in the node's data member to increase access speed. - -var - Data: PInteger; - -begin - if (Column > NoColumn) and (vsMultiline in Node.States) then - Result := FHeader.Columns[Column].Width - else - begin - if Canvas = nil then - Canvas := Self.Canvas; - - if Column = FHeader.MainColumn then - begin - // Primary column or no columns. - Data := InternalData(Node); - if Assigned(Data) then - begin - Result := Data^; - if Result = 0 then - begin - Data^ := CalculateTextWidth(Canvas, Node, Column, Text[Node, Column]); - Result := Data^; - end; - end - else - Result := 0; - end - else - // any other column - Result := CalculateTextWidth(Canvas, Node, Column, Text[Node, Column]); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TCustomVirtualStringTree.DoGetText(Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType; - var Text: WideString); - -begin - if Assigned(FOnGetText) then - FOnGetText(Self, Node, Column, TextType, Text); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TCustomVirtualStringTree.DoIncrementalSearch(Node: PVirtualNode; const Text: WideString): Integer; - -// Since the string tree has access to node text it can do incremental search on its own. Use the event to -// override the default behavior. - -begin - Result := 0; - if Assigned(FOnIncrementalSearch) then - FOnIncrementalSearch(Self, Node, Text, Result) - else - // Default behavior is to match the search string with the start of the node text. - if Pos(Text, GetText(Node, FocusedColumn)) <> 1 then - Result := 1; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TCustomVirtualStringTree.DoNewText(Node: PVirtualNode; Column: TColumnIndex; Text: WideString); - -begin - if Assigned(FOnNewText) then - FOnNewText(Self, Node, Column, Text); - - // The width might have changed, so update the scrollbar. - if FUpdateCount = 0 then - UpdateHorizontalScrollBar(True); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TCustomVirtualStringTree.DoPaintNode(var PaintInfo: TVTPaintInfo); - -// Main output routine to print the text of the given node using the space provided in PaintInfo.ContentRect. - -var - S: WideString; - TextOutFlags: Integer; - -begin - Logger.EnterMethod(lcPaintDetails,'TCustomVirtualStringTree.DoPaintNode'); - // Set a new OnChange event for the canvas' font so we know if the application changes it in the callbacks. - // This long winded procedure is necessary because font changes (as well as brush and pen changes) are - // unfortunately not announced via the Canvas.OnChange event. - RedirectFontChangeEvent(PaintInfo.Canvas); - - // Determine main text direction as well as other text properties. - TextOutFlags := ETO_CLIPPED or RTLFlag[PaintInfo.BidiMode <> bdLeftToRight]; - S := Text[PaintInfo.Node, PaintInfo.Column]; - - // Paint the normal text first... - if Length(S) > 0 then - PaintNormalText(PaintInfo, TextOutFlags, S); - - // ... and afterwards the static text if not centered and the node is not multiline enabled. - if (Alignment <> taCenter) and not (vsMultiline in PaintInfo.Node.States) and (toShowStaticText in TreeOptions.FStringOptions) then - begin - S := ''; - with PaintInfo do - DoGetText(Node, Column, ttStatic, S); - if Length(S) > 0 then - PaintStaticText(PaintInfo, TextOutFlags, S); - end; - RestoreFontChangeEvent(PaintInfo.Canvas); - Logger.ExitMethod(lcPaintDetails,'TCustomVirtualStringTree.DoPaintNode'); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TCustomVirtualStringTree.DoPaintText(Node: PVirtualNode; const Canvas: TCanvas; Column: TColumnIndex; - TextType: TVSTTextType); - -begin - if Assigned(FOnPaintText) then - FOnPaintText(Self, Canvas, Node, Column, TextType); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TCustomVirtualStringTree.DoShortenString(Canvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex; - const S: WideString; Width: Integer; EllipsisWidth: Integer = 0): WideString; - -var - Done: Boolean; - -begin - Done := False; - if Assigned(FOnShortenString) then - FOnShortenString(Self, Canvas, Node, Column, S, Width, Result, Done); - if not Done then - Result := ShortenString(Canvas.Handle, S, Width, EllipsisWidth); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TCustomVirtualStringTree.DoTextDrawing(var PaintInfo: TVTPaintInfo; Text: WideString; CellRect: TRect; - DrawFormat: Cardinal); - -begin - if IsWinNT then - Windows.DrawTextW(PaintInfo.Canvas.Handle, PWideChar(Text), Length(Text), CellRect, DrawFormat) - else - DrawTextW(PaintInfo.Canvas.Handle, PWideChar(Text), Length(Text), CellRect, DrawFormat, False); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TCustomVirtualStringTree.DoTextMeasuring(Canvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex; - Text: WideString): Integer; - -var - Size: TSize; - -begin - GetTextExtentPoint32W(Canvas.Handle, PWideChar(Text), Length(Text), Size); - Result := Size.cx; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TCustomVirtualStringTree.GetOptionsClass: TTreeOptionsClass; - -begin - Result := TCustomStringTreeOptions; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TCustomVirtualStringTree.InternalData(Node: PVirtualNode): Pointer; - -begin - if (Node = FRoot) or (Node = nil) then - Result := nil - else - Result := PChar(Node) + FInternalDataOffset; - Logger.SendPointer('InternalData',Result); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TCustomVirtualStringTree.MainColumnChanged; - -var - Run: PVirtualNode; - Data: PInteger; - -begin - inherited; - - // Have to reset all node widths. - Run := FRoot.FirstChild; - while Assigned(Run) do - begin - Data := InternalData(Run); - if Assigned(Data) then - Data^ := 0; - Run := GetNextNoInit(Run); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TCustomVirtualStringTree.ReadChunk(Stream: TStream; Version: Integer; Node: PVirtualNode; ChunkType, - ChunkSize: Integer): Boolean; - -// read in the caption chunk if there is one - -var - NewText: WideString; - -begin - case ChunkType of - CaptionChunk: - begin - NewText := ''; - if ChunkSize > 0 then - begin - SetLength(NewText, ChunkSize div 2); - Stream.Read(PWideChar(NewText)^, ChunkSize); - end; - // Do a new text event regardless of the caption content to allow removing the default string. - Text[Node, FHeader.MainColumn] := NewText; - Result := True; - end; - else - Result := inherited ReadChunk(Stream, Version, Node, ChunkType, ChunkSize); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -type - TOldVTStringOption = (soSaveCaptions, soShowStaticText); - -procedure TCustomVirtualStringTree.ReadOldStringOptions(Reader: TReader); - -// Migration helper routine to silently convert forms containing the old tree options member into the new -// sub-options structure. - -var - OldOption: TOldVTStringOption; - EnumName: string; - -begin - // If we are at design time currently then let the designer know we changed something. - UpdateDesigner; - - // It should never happen at this place that there is something different than the old set. - if Reader.ReadValue = vaSet then - with TreeOptions do - begin - // Remove all default values set by the constructor. - StringOptions := []; - - while True do - begin - // Sets are stored with their members as simple strings. Read them one by one and map them to the new option - // in the correct sub-option set. - EnumName := Reader.ReadString; - if EnumName = '' then - Break; - OldOption := TOldVTStringOption(GetEnumValue(TypeInfo(TOldVTStringOption), EnumName)); - case OldOption of - soSaveCaptions: - StringOptions := FStringOptions + [toSaveCaptions]; - soShowStaticText: - StringOptions := FStringOptions + [toShowStaticText]; - end; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TCustomVirtualStringTree.RenderOLEData(const FormatEtcIn: TFormatEtc; out Medium: TStgMedium; - ForClipboard: Boolean): HResult; - -// Returns string expressions of all currently selected nodes in the Medium structure. - -begin - Result := inherited RenderOLEData(FormatEtcIn, Medium, ForClipboard); - if Failed(Result) then - try - if ForClipboard then - Medium.hGlobal := ContentToClipboard(FormatEtcIn.cfFormat, tstCutCopySet) - else - Medium.hGlobal := ContentToClipboard(FormatEtcIn.cfFormat, tstSelected); - - // Fill rest of the Medium structure if rendering went fine. - if Medium.hGlobal <> 0 then - begin - Medium.tymed := TYMED_HGLOBAL; - Medium.PunkForRelease := nil; - - Result := S_OK; - end; - except - Result := E_FAIL; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TCustomVirtualStringTree.WriteChunks(Stream: TStream; Node: PVirtualNode); - -// Adds another sibling chunk for Node storing the label if the node is initialized. -// Note: If the application stores a node's caption in the node's data member (which will be quite common) and needs to -// store more node specific data then it should use the OnSaveNode event rather than the caption autosave function -// (take out soSaveCaption from StringOptions). Otherwise the caption is unnecessarily stored twice. - -var - Header: TChunkHeader; - S: WideString; - Len: Integer; - -begin - inherited; - if (toSaveCaptions in TreeOptions.FStringOptions) and (Node <> FRoot) and - (vsInitialized in Node.States) then - with Stream do - begin - // Read the node's caption (primary column only). - S := Text[Node, FHeader.MainColumn]; - Len := 2 * Length(S); - if Len > 0 then - begin - // Write a new sub chunk. - Header.ChunkType := CaptionChunk; - Header.ChunkSize := Len; - Write(Header, SizeOf(Header)); - Write(PWideChar(S)^, Len); - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TCustomVirtualStringTree.ComputeNodeHeight(Canvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex; - S: WideString): Integer; - -// Default node height calculation for multi line nodes. This method can be used by the application to delegate the -// computation to the string tree. -// Canvas is used to compute that value by using its current font settings. -// Node and Column describe the cell to be used for the computation. -// S is the string for which the height must be computed. If this string is empty the cell text is used instead. - -var - DrawFormat: Cardinal; - BidiMode: TBidiMode; - Alignment: TAlignment; - PaintInfo: TVTPaintInfo; - Dummy: TColumnIndex; - -begin - if Length(S) = 0 then - S := Text[Node, Column]; - DrawFormat := DT_TOP or DT_NOPREFIX or DT_CALCRECT or DT_WORDBREAK; - if Column <= NoColumn then - begin - BidiMode := Self.BidiMode; - Alignment := Self.Alignment; - end - else - begin - BidiMode := Header.Columns[Column].BidiMode; - Alignment := Header.Columns[Column].Alignment; - end; - - if BidiMode <> bdLeftToRight then - ChangeBidiModeAlignment(Alignment); - - // Allow for autospanning. - PaintInfo.Node := Node; - PaintInfo.BidiMode := BidiMode; - PaintInfo.Column := Column; - PaintInfo.CellRect := Rect(0, 0, 0, 0); - if Column > NoColumn then - PaintInfo.CellRect.Right := FHeader.Columns[Column].Width - else - PaintInfo.CellRect.Right := ClientWidth; - AdjustPaintCellRect(PaintInfo, Dummy); - - if BidiMode <> bdLeftToRight then - DrawFormat := DrawFormat or DT_RIGHT or DT_RTLREADING - else - DrawFormat := DrawFormat or DT_LEFT; - if IsWinNT then - Windows.DrawTextW(Canvas.Handle, PWideChar(S), Length(S), PaintInfo.CellRect, DrawFormat) - else - DrawTextW(Canvas.Handle, PWideChar(S), Length(S), PaintInfo.CellRect, DrawFormat, False); - Result := PaintInfo.CellRect.Bottom - PaintInfo.CellRect.Top; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TCustomVirtualStringTree.ContentToClipboard(Format: Word; Source: TVSTTextSourceType): HGLOBAL; - -// This method constructs a shareable memory object filled with string data in the required format. Supported are: -// CF_TEXT - plain ANSI text (Unicode text is converted using the user's current locale) -// CF_UNICODETEXT - plain Unicode text -// CF_CSV - comma separated plain ANSI text -// CF_VRTF + CF_RTFNOOBS - rich text (plain ANSI) -// CF_HTML - HTML text encoded using UTF-8 -// -// Result is the handle to a globally allocated memory block which can directly be used for clipboard and drag'n drop -// transfers. The caller is responsible for freeing the memory. If for some reason the content could not be rendered -// the Result is 0. - - //--------------- local function -------------------------------------------- - - procedure MakeFragment(var HTML: string); - - // Helper routine to build a properly-formatted HTML fragment. - - const - Version = 'Version:1.0'#13#10; - StartHTML = 'StartHTML:'; - EndHTML = 'EndHTML:'; - StartFragment = 'StartFragment:'; - EndFragment = 'EndFragment:'; - DocType = ''; - HTMLIntro = '' + - ''; - HTMLExtro = ''; - NumberLengthAndCR = 10; - - // Let the compiler determine the description length. - DescriptionLength = Length(Version) + Length(StartHTML) + Length(EndHTML) + Length(StartFragment) + - Length(EndFragment) + 4 * NumberLengthAndCR; - - var - Description: string; - StartHTMLIndex, - EndHTMLIndex, - StartFragmentIndex, - EndFragmentIndex: Integer; - - begin - // The HTML clipboard format is defined by using byte positions in the entire block where HTML text and - // fragments start and end. These positions are written in a description. Unfortunately the positions depend on the - // length of the description but the description may change with varying positions. - // To solve this dilemma the offsets are converted into fixed length strings which makes it possible to know - // the description length in advance. - StartHTMLIndex := DescriptionLength; // position 0 after the description - StartFragmentIndex := StartHTMLIndex + Length(DocType) + Length(HTMLIntro); - EndFragmentIndex := StartFragmentIndex + Length(HTML); - EndHTMLIndex := EndFragmentIndex + Length(HTMLExtro); - - Description := Version + - SysUtils.Format('%s%.8d', [StartHTML, StartHTMLIndex]) + #13#10 + - SysUtils.Format('%s%.8d', [EndHTML, EndHTMLIndex]) + #13#10 + - SysUtils.Format('%s%.8d', [StartFragment, StartFragmentIndex]) + #13#10 + - SysUtils.Format('%s%.8d', [EndFragment, EndFragmentIndex]) + #13#10; - HTML := Description + DocType + HTMLIntro + HTML + HTMLExtro; - end; - - //--------------- end local function ---------------------------------------- - -var - Data: Pointer; - DataSize: Cardinal; - S: string; - WS: WideString; - P: Pointer; - -begin - {$ifdef NeedWindows} - Result := 0; - case Format of - CF_TEXT: - begin - S := ContentToText(Source, #9) + #0; - Data := PChar(S); - DataSize := Length(S); - end; - CF_UNICODETEXT: - begin - WS := ContentToUnicode(Source, #9) + #0; - Data := PWideChar(WS); - DataSize := 2 * Length(WS); - end; - else - if Format = CF_CSV then - S := ContentToText(Source, ListSeparator) + #0 - else - if (Format = CF_VRTF) or (Format = CF_VRTFNOOBJS) then - S := ContentToRTF(Source) + #0 - else - if Format = CF_HTML then - begin - S := ContentToHTML(Source); - // Build a valid HTML clipboard fragment. - MakeFragment(S); - S := S + #0; - end; - Data := PChar(S); - DataSize := Length(S); - end; - - if DataSize > 0 then - begin - Result := GlobalAlloc(GHND or GMEM_SHARE, DataSize); - P := GlobalLock(Result); - Move(Data^, P^, DataSize); - GlobalUnlock(Result); - end; - {$endif} -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TCustomVirtualStringTree.ContentToHTML(Source: TVSTTextSourceType; Caption: WideString = ''): string; - -// Renders the current tree content (depending on Source) as HTML text encoded in UTF-8. -// If Caption is not empty then it is used to create and fill the header for the table built here. -// Based on ideas and code from Frank van den Bergh and Andreas Hörstemeier. - -type - UCS2 = Word; - UCS4 = Cardinal; - -const - MaximumUCS4: UCS4 = $7FFFFFFF; - ReplacementCharacter: UCS4 = $0000FFFD; - -var - Buffer: TBufferedString; - - //--------------- local functions ------------------------------------------- - - function ConvertSurrogate(S1, S2: UCS2): UCS4; - - // Converts a pair of high and low surrogate into the corresponding UCS4 character. - - const - SurrogateOffset = ($D800 shl 10) + $DC00 - $10000; - - begin - Result := Word(S1) shl 10 + Word(S2) - SurrogateOffset; - end; - - //--------------------------------------------------------------------------- - - function UTF16ToUTF8(const S: WideString): string; - - // Converts the given Unicode text (which may contain surrogates) into - // the UTF-8 encoding used for the HTML clipboard format. - - const - FirstByteMark: array[0..6] of Byte = ($00, $00, $C0, $E0, $F0, $F8, $FC); - - var - Ch: UCS4; - I, J, T: Integer; - BytesToWrite: Cardinal; - - begin - if Length(S) = 0 then - Result := '' - else - begin - // Make room for the result. Assume worst case, there are only short texts to convert. - SetLength(Result, 6 * Length(S)); - T := 1; - I := 1; - while I <= Length(S) do - begin - Ch := UCS4(S[I]); - - // Is the character a surrogate? - if (Ch and $FFFFF800) = $D800 then - begin - Inc(I); - // Check the following char whether it forms a valid surrogate pair with the first character. - if (I <= Length(S)) and ((UCS4(S[I]) and $FFFFFC00) = $DC00) then - Ch := ConvertSurrogate(UCS2(Ch), UCS2(S[I])) - else // Skip invalid surrogate value. - Continue; - end; - - if Ch < $80 then - BytesToWrite := 1 - else - if Ch < $800 then - BytesToWrite := 2 - else - if Ch < $10000 then - BytesToWrite := 3 - else - if Ch < $200000 then - BytesToWrite := 4 - else - if Ch < $4000000 then - BytesToWrite := 5 - else - if Ch <= MaximumUCS4 then - BytesToWrite := 6 - else - begin - BytesToWrite := 2; - Ch := ReplacementCharacter; - end; - - for J := BytesToWrite downto 2 do - begin - Result[T + J - 1] := Char((Ch or $80) and $BF); - Ch := Ch shr 6; - end; - Result[T] := Char(Ch or FirstByteMark[BytesToWrite]); - Inc(T, BytesToWrite); - - Inc(I); - end; - SetLength(Result, T - 1); // set to actual length - end; - end; - - //--------------------------------------------------------------------------- - - procedure WriteColorAsHex(Color: TColor); - - var - WinColor: COLORREF; - I: Integer; - Component, - Value: Byte; - - begin - Buffer.Add('#'); - WinColor := ColorToRGB(Color); - I := 1; - while I <= 6 do - begin - Component := WinColor and $FF; - - Value := 48 + (Component shr 4); - if Value > $39 then - Inc(Value, 7); - Buffer.Add(Char(Value)); - Inc(I); - - Value := 48 + (Component and $F); - if Value > $39 then - Inc(Value, 7); - Buffer.Add(Char(Value)); - Inc(I); - - WinColor := WinColor shr 8; - end; - end; - - //--------------------------------------------------------------------------- - - procedure WriteStyle(Name: string; Font: TFont); - - // Creates a CSS style entry with the given name for the given font. - // If Name is empty then the entry is created as inline style. - - begin - if Length(Name) = 0 then - Buffer.Add(' style="{font:') - else - begin - Buffer.Add('.'); - Buffer.Add(Name); - Buffer.Add('{font:'); - end; - if fsUnderline in Font.Style then - Buffer.Add(' underline'); - if fsItalic in Font.Style then - Buffer.Add(' italic'); - if fsBold in Font.Style then - Buffer.Add(' bold'); - Buffer.Add(Format(' %dpt "%s";', [Font.Size, Font.Name])); - Buffer.Add('color:'); - WriteColorAsHex(Font.Color); - Buffer.Add(';}'); - if Length(Name) = 0 then - Buffer.Add('"'); - end; - - //--------------- end local functions --------------------------------------- - -var - I, J : Integer; - Level, MaxLevel: Cardinal; - AddHeader: string; - Save, Run: PVirtualNode; - GetNextNode: TGetNextNodeProc; - Text: WideString; - - RenderColumns: Boolean; - Columns: TColumnsArray; - ColumnColors: array of string; - Index: Integer; - IndentWidth, - LineStyleText: string; - Alignment: TAlignment; - BidiMode: TBidiMode; - - CellPadding: string; - -begin - Buffer := TBufferedString.Create; - try - // For customization by the application or descendants we use again the redirected font change event. - RedirectFontChangeEvent(Canvas); - - CellPadding := Format('padding-left:%dpx;padding-right:%0:dpx;', [FMargin]); - - IndentWidth := IntToStr(FIndent); - AddHeader := ' '; - // Add title if adviced so by giving a caption. - if Length(Caption) > 0 then - AddHeader := AddHeader + 'caption="' + UTF16ToUTF8(Caption) + '"'; - if Borderstyle <> bsNone then - AddHeader := AddHeader + Format(' border="%d" frame=box', [BorderWidth + 1]); - - // Create HTML table based on the tree structure. To simplify formatting we use styles defined in a small CSS area. - Buffer.Add(''); - Buffer.AddNewLine; - - // General table properties. - Buffer.Add(''); - Buffer.AddNewLine; - - Columns := nil; - ColumnColors := nil; - RenderColumns := FHeader.UseColumns; - if RenderColumns then - begin - Columns := FHeader.FColumns.GetVisibleColumns; - SetLength(ColumnColors, Length(Columns)); - end; - - GetRenderStartValues(Source, Run, GetNextNode); - Save := Run; - - MaxLevel := 0; - // The table consists of visible columns and rows as used in the tree, but the main tree column is splitted - // into several HTML columns to accomodate the indentation. - while Assigned(Run) do - begin - Level := GetNodeLevel(Run); - If Level > MaxLevel then - MaxLevel := Level; - Run := GetNextNode(Run); - end; - - if RenderColumns then - begin - Buffer.Add(''); - Buffer.AddNewLine; - // Make the first row in the HTML table an image of the tree header. - for I := 0 to High(Columns) do - begin - Buffer.Add(''); - end; - Buffer.Add(''); - Buffer.AddNewLine; - end; - - // Now go through the tree. - Run := Save; - while Assigned(Run) do - begin - Level := GetNodeLevel(Run); - Buffer.Add(' '); - Buffer.AddNewLine; - - I := 0; - while (I < Length(Columns)) or not RenderColumns do - begin - if RenderColumns then - Index := Columns[I].Index - else - Index := NoColumn; - - if not RenderColumns or (coVisible in Columns[I].FOptions) then - begin - // Call back the application to know about font customization. - Canvas.Font := Font; - FFontChanged := False; - DoPaintText(Run, Canvas, Index, ttNormal); - - if Index = Header.MainColumn then - begin - // Create a cell for each indentation level. - if RenderColumns and not (coParentColor in Columns[I].FOptions) then - begin - for J := 1 to Level do - begin - Buffer.Add(''); - end; - end - else - begin - for J := 1 to Level do - if J = 1 then - begin - Buffer.Add(' '); - end - else - Buffer.Add(' '); - end; - end; - - if FFontChanged then - begin - Buffer.Add(' '); - end; - - if not RenderColumns then - Break; - Inc(I); - end; - Run := GetNextNode(Run); - Buffer.Add(' '); - Buffer.AddNewLine; - end; - Buffer.Add('
bdLeftToRight then - begin - ChangeBidiModeAlignment(Alignment); - Buffer.Add(' dir="rtl"'); - end; - - // Consider aligment. - case Alignment of - taRightJustify: - Buffer.Add(' align=right'); - taCenter: - Buffer.Add(' align=center'); - else - Buffer.Add(' align=left'); - end; - - Index := Columns[I].Index; - // Merge cells of the header emulation in the main column. - if (MaxLevel > 0) and (Index = Header.MainColumn) then - begin - Buffer.Add(' colspan="'); - Buffer.Add(IntToStr(MaxLevel + 1)); - Buffer.Add('"'); - end; - - // The color of the header is usually clBtnFace. - Buffer.Add(' bgcolor='); - WriteColorAsHex(clBtnFace); - - // Set column width in pixels. - Buffer.Add(' width="'); - Buffer.Add(IntToStr(Columns[I].Width)); - Buffer.Add('px">'); - - if Length(Columns[I].Text) > 0 then - Buffer.Add(UTF16ToUTF8(Columns[I].Text)); - Buffer.Add('
    bdLeftToRight then - begin - ChangeBidiModeAlignment(Alignment); - Buffer.Add(' dir="rtl"'); - end; - - // Consider aligment. - case Alignment of - taRightJustify: - Buffer.Add(' align=right'); - taCenter: - Buffer.Add(' align=center'); - else - Buffer.Add(' align=left'); - end; - // Merge cells in the main column. - if (MaxLevel > 0) and (Index = FHeader.MainColumn) and (Level < MaxLevel) then - begin - Buffer.Add(' colspan="'); - Buffer.Add(IntToStr(MaxLevel - Level + 1)); - Buffer.Add('"'); - end; - if RenderColumns and not (coParentColor in Columns[I].FOptions) then - begin - Buffer.Add(' bgcolor='); - WriteColorAsHex(Columns[I].Color); - end; - Buffer.Add('>'); - Text := Self.Text[Run, Index]; - if Length(Text) > 0 then - begin - Text := UTF16ToUTF8(Text); - Buffer.Add(Text); - end; - Buffer.Add('
'); - - RestoreFontChangeEvent(Canvas); - - Result := Buffer.AsString; - finally - Buffer.Free; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TCustomVirtualStringTree.ContentToRTF(Source: TVSTTextSourceType): string; - -// Renders the current tree content (depending on Source) as RTF (rich text). -// Based on ideas and code from Frank van den Bergh and Andreas Hörstemeier. - -var - Fonts: TStringList; - Colors: TList; - CurrentFontIndex, - CurrentFontColor, - CurrentFontSize: Integer; - Buffer: TBufferedString; - - //--------------- local functions ------------------------------------------- - - procedure SelectFont(Font: string); - - var - I: Integer; - - begin - I := Fonts.IndexOf(Font); - if I > -1 then - begin - // Font has already been used - if I <> CurrentFontIndex then - begin - Buffer.Add('\f'); - Buffer.Add(IntToStr(I)); - CurrentFontIndex := I; - end; - end - else - begin - I := Fonts.Add(Font); - Buffer.Add('\f'); - Buffer.Add(IntToStr(I)); - CurrentFontIndex := I; - end; - end; - - //--------------------------------------------------------------------------- - - procedure SelectColor(Color: TColor); - - var - I: Integer; - - begin - I := Colors.IndexOf(Pointer(Color)); - if I > -1 then - begin - // Color has already been used - if I <> CurrentFontColor then - begin - Buffer.Add('\cf'); - Buffer.Add(IntToStr(I + 1)); - CurrentFontColor := I; - end; - end - else - begin - I := Colors.Add(Pointer(Color)); - Buffer.Add('\cf'); - Buffer.Add(IntToStr(I + 1)); - CurrentFontColor := I; - end; - end; - - //--------------------------------------------------------------------------- - - procedure TextPlusFont(Text: WideString; Font: TFont); - - var - UseUnderline, - UseItalic, - UseBold: Boolean; - I: Integer; - - begin - if Length(Text) > 0 then - begin - UseUnderline := fsUnderline in Font.Style; - if UseUnderline then - Buffer.Add('\ul'); - UseItalic := fsItalic in Font.Style; - if UseItalic then - Buffer.Add('\i'); - UseBold := fsBold in Font.Style; - if UseBold then - Buffer.Add('\b'); - SelectFont(Font.Name); - SelectColor(Font.Color); - if Font.Size <> CurrentFontSize then - begin - // Font size must be given in half points. - Buffer.Add('\fs'); - Buffer.Add(IntToStr(2 * Font.Size)); - CurrentFontSize := Font.Size; - end; - // Use escape sequences to note Unicode text. - Buffer.Add(' '); - // Note: Unicode values > 32767 must be expressed as negative numbers. This is implicitly done - // by interpreting the wide chars (word values) as small integers. - for I := 1 to Length(Text) do - Buffer.Add(Format('\u%d\''3f', [SmallInt(Text[I])])); - if UseUnderline then - Buffer.Add('\ul0'); - if UseItalic then - Buffer.Add('\i0'); - if UseBold then - Buffer.Add('\b0'); - end; - end; - - //--------------- end local functions --------------------------------------- - -var - Level, LastLevel: Integer; - I, J: Integer; - Save, Run: PVirtualNode; - GetNextNode: TGetNextNodeProc; - S, Tabs : string; - Text: WideString; - Twips: Integer; - - RenderColumns: Boolean; - Columns: TColumnsArray; - Index: Integer; - Alignment: TAlignment; - BidiMode: TBidiMode; - -begin - Buffer := TBufferedString.Create; - try - // For customization by the application or descendants we use again the redirected font change event. - RedirectFontChangeEvent(Canvas); - - Fonts := TStringList.Create; - Colors := TList.Create; - CurrentFontIndex := -1; - CurrentFontColor := -1; - CurrentFontSize := -1; - - Columns := nil; - Tabs := ''; - LastLevel := 0; - - RenderColumns := FHeader.UseColumns; - if RenderColumns then - Columns := FHeader.FColumns.GetVisibleColumns; - - GetRenderStartValues(Source, Run, GetNextNode); - Save := Run; - - // First make a table structure. The \rtf and other header stuff is included - // when the font and color tables are created. - Buffer.Add('\uc1\trowd\trgaph70'); - J := 0; - if RenderColumns then - begin - for I := 0 to High(Columns) do - begin - Inc(J, Columns[I].Width); - // This value must be expressed in twips (1 inch = 1440 twips). - Twips := Round(1440 * J / Screen.PixelsPerInch); - Buffer.Add('\cellx'); - Buffer.Add(IntToStr(Twips)); - end; - end - else - begin - Twips := Round(1440 * ClientWidth / Screen.PixelsPerInch); - Buffer.Add('\cellx'); - Buffer.Add(IntToStr(Twips)); - end; - - // Fill table header. - if RenderColumns then - begin - Buffer.Add('\pard\intbl'); - for I := 0 to High(Columns) do - begin - Alignment := Columns[I].Alignment; - BidiMode := Columns[I].BidiMode; - - // Alignment is not supported with older RTF formats, however it will be ignored. - if BidiMode <> bdLeftToRight then - ChangeBidiModeAlignment(Alignment); - case Alignment of - taRightJustify: - Buffer.Add('\qr'); - taCenter: - Buffer.Add('\qc'); - end; - - TextPlusFont(Columns[I].Text, Header.Font); - Buffer.Add('\cell'); - end; - Buffer.Add('\row'); - end; - - // Now write the contents. - Run := Save; - while Assigned(Run) do - begin - I := 0; - while not RenderColumns or (I < Length(Columns)) do - begin - if RenderColumns then - begin - Index := Columns[I].Index; - Alignment := Columns[I].Alignment; - BidiMode := Columns[I].BidiMode; - end - else - begin - Index := NoColumn; - Alignment := FAlignment; - BidiMode := Self.BidiMode; - end; - - if not RenderColumns or (coVisible in Columns[I].Options) then - begin - Text := Self.Text[Run, Index]; - Buffer.Add('\pard\intbl'); - - // Alignment is not supported with older RTF formats, however it will be ignored. - if BidiMode <> bdLeftToRight then - ChangeBidiModeAlignment(Alignment); - case Alignment of - taRightJustify: - Buffer.Add('\qr'); - taCenter: - Buffer.Add('\qc'); - end; - - // Call back the application to know about font customization. - Canvas.Font := Font; - FFontChanged := False; - DoPaintText(Run, Canvas, Index, ttNormal); - - if Index = Header.MainColumn then - begin - Level := GetNodeLevel(Run); - if Level <> LastLevel then - begin - LastLevel := Level; - Tabs := ''; - for J := 0 to Level - 1 do - Tabs := Tabs + '\tab'; - end; - if Level > 0 then - begin - Buffer.Add(Tabs); - Buffer.Add(' '); - TextPlusFont(Text, Canvas.Font); - Buffer.Add('\cell'); - end - else - begin - TextPlusFont(Text, Canvas.Font); - Buffer.Add('\cell'); - end; - end - else - begin - TextPlusFont(Text, Canvas.Font); - Buffer.Add('\cell'); - end; - end; - - if not RenderColumns then - Break; - Inc(I); - end; - Buffer.Add('\row'); - Run := GetNextNode(Run); - end; - - Buffer.Add('\pard\par'); - - // Build lists with fonts and colors. They have to be at the start of the document. - S := '{\rtf1\ansi\ansicpg1252\deff0\deflang1043{\fonttbl'; - for I := 0 to Fonts.Count - 1 do - S := S + Format('{\f%d %s;}', [I, Fonts[I]]); - S := S + '}'; - - S := S + '{\colortbl;'; - for I := 0 to Colors.Count - 1 do - begin - J := ColorToRGB(TColor(Colors[I])); - S := S + Format('\red%d\green%d\blue%d;', [J and $FF, (J shr 8) and $FF, (J shr 16) and $FF]); - end; - S := S + '}'; - - Result := S + Buffer.AsString + '}'; - Fonts.Free; - Colors.Free; - - RestoreFontChangeEvent(Canvas); - finally - Buffer.Free; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TCustomVirtualStringTree.ContentToText(Source: TVSTTextSourceType; Separator: Char): string; - -// Renders the current tree content (depending on Source) as plain ANSI text. -// If an entry contains the separator char or double quotes then it is wrapped with double quotes -// and existing double quotes are duplicated. -// Note: Unicode strings are implicitely converted to ANSI strings based on the currently active user locale. - -var - RenderColumns: Boolean; - Tabs: string; - GetNextNode: TGetNextNodeProc; - Run, Save: PVirtualNode; - Level, MaxLevel: Cardinal; - Columns: TColumnsArray; - LastColumn: TVirtualTreeColumn; - Index, - I: Integer; - Text: string; - Buffer: TBufferedString; - -begin - Columns := nil; - Buffer := TBufferedString.Create; - try - RenderColumns := FHeader.UseColumns; - if RenderColumns then - Columns := FHeader.FColumns.GetVisibleColumns; - - GetRenderStartValues(Source, Run, GetNextNode); - Save := Run; - - // The text consists of visible groups representing the columns, which are separated by one or more separator - // characters. There are always MaxLevel separator chars in a line (main column only). Either before the caption - // to ident it or after the caption to make the following column aligned. - MaxLevel := 0; - while Assigned(Run) do - begin - Level := GetNodeLevel(Run); - If Level > MaxLevel then - MaxLevel := Level; - Run := GetNextNode(Run); - end; - - SetLength(Tabs, MaxLevel); - FillChar(PChar(Tabs)^, MaxLevel, Separator); - - // First line is always the header if used. - if RenderColumns then - begin - LastColumn := Columns[High(Columns)]; - for I := 0 to High(Columns) do - begin - Buffer.Add(Columns[I].Text); - if Columns[I] <> LastColumn then - begin - if Columns[I].Index = Header.MainColumn then - begin - Buffer.Add(Tabs); - Buffer.Add(Separator); - end - else - Buffer.Add(Separator); - end; - end; - Buffer.AddNewLine; - end - else - LastColumn := nil; - - Run := Save; - if RenderColumns then - begin - while Assigned(Run) do - begin - for I := 0 to High(Columns) do - begin - if coVisible in Columns[I].Options then - begin - Index := Columns[I].Index; - // This line implicitly converts the Unicode text to ANSI. - Text := Self.Text[Run, Index]; - if Index = Header.MainColumn then - begin - Level := GetNodeLevel(Run); - Buffer.Add(Copy(Tabs, 1, Level)); - // Wrap the text with quotation marks if it contains the separator character. - if (Pos(Separator, Text) > 0) or (Pos('"', Text) > 0) then - Buffer.Add(AnsiQuotedStr(Text, '"')) - else - Buffer.Add(Text); - Buffer.Add(Copy(Tabs, 1, MaxLevel - Level)); - end - else - if (Pos(Separator, Text) > 0) or (Pos('"', Text) > 0) then - Buffer.Add(AnsiQuotedStr(Text, '"')) - else - Buffer.Add(Text); - - if Columns[I] <> LastColumn then - Buffer.Add(Separator); - end; - end; - Run := GetNextNode(Run); - Buffer.AddNewLine; - end; - end - else - begin - while Assigned(Run) do - begin - // This line implicitly converts the Unicode text to ANSI. - Text := Self.Text[Run, NoColumn]; - Level := GetNodeLevel(Run); - Buffer.Add(Copy(Tabs, 1, Level)); - Buffer.Add(Text); - Buffer.AddNewLine; - - Run := GetNextNode(Run); - end; - end; - - Result := Buffer.AsString; - finally - Buffer.Free; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TCustomVirtualStringTree.ContentToUnicode(Source: TVSTTextSourceType; Separator: WideChar): WideString; - -// Renders the current tree content (depending on Source) as Unicode text. -// If an entry contains the separator char then it is wrapped with double quotation marks. -// Note: There is no QuotedStr function for Unicode in the VCL (like AnsiQuotedStr) so we have the limitation here -// that an entry must not contain double quotation marks, otherwise import into other programs might fail! - -const - WideCRLF: WideString = #13#10; - -var - RenderColumns: Boolean; - Tabs: WideString; - GetNextNode: TGetNextNodeProc; - Run, Save: PVirtualNode; - - Columns: TColumnsArray; - LastColumn: TVirtualTreeColumn; - Level, MaxLevel: Cardinal; - Index, - I: Integer; - Text: WideString; - Buffer: TWideBufferedString; - -begin - Columns := nil; - - Buffer := TWideBufferedString.Create; - try - RenderColumns := FHeader.UseColumns; - if RenderColumns then - Columns := FHeader.FColumns.GetVisibleColumns; - - GetRenderStartValues(Source, Run, GetNextNode); - Save := Run; - - // The text consists of visible groups representing the columns, which are separated by one or more separator - // characters. There are always MaxLevel separator chars in a line (main column only). Either before the caption - // to ident it or after the caption to make the following column aligned. - MaxLevel := 0; - while Assigned(Run) do - begin - Level := GetNodeLevel(Run); - If Level > MaxLevel then - MaxLevel := Level; - Run := GetNextNode(Run); - end; - - SetLength(Tabs, MaxLevel); - for I := 1 to MaxLevel do - Tabs[I] := Separator; - - // First line is always the header if used. - if RenderColumns then - begin - LastColumn := Columns[High(Columns)]; - for I := 0 to High(Columns) do - begin - Buffer.Add(Columns[I].Text); - if Columns[I] <> LastColumn then - begin - if Columns[I].Index = Header.MainColumn then - begin - Buffer.Add(Tabs); - Buffer.Add(Separator); - end - else - Buffer.Add(Separator); - end; - end; - Buffer.AddNewLine; - end - else - LastColumn := nil; - - Run := Save; - if RenderColumns then - begin - while Assigned(Run) do - begin - for I := 0 to High(Columns) do - begin - if coVisible in Columns[I].Options then - begin - Index := Columns[I].Index; - Text := Self.Text[Run, Index]; - if Index = Header.MainColumn then - begin - Level := GetNodeLevel(Run); - Buffer.Add(Copy(Tabs, 1, Level)); - // Wrap the text with quotation marks if it contains the separator character. - if Pos(Separator, Text) > 0 then - begin - Buffer.Add('"'); - Buffer.Add(Text); - Buffer.Add('"'); - end - else - Buffer.Add(Text); - Buffer.Add(Copy(Tabs, 1, MaxLevel - Level)); - end - else - if Pos(Separator, Text) > 0 then - begin - Buffer.Add('"'); - Buffer.Add(Text); - Buffer.Add('"'); - end - else - Buffer.Add(Text); - - if Columns[I] <> LastColumn then - Buffer.Add(Separator); - end; - end; - Run := GetNextNode(Run); - Buffer.AddNewLine; - end; - end - else - begin - while Assigned(Run) do - begin - Text := Self.Text[Run, NoColumn]; - Level := GetNodeLevel(Run); - Buffer.Add(Copy(Tabs, 1, Level)); - Buffer.Add(Text); - Buffer.AddNewLine; - - Run := GetNextNode(Run); - end; - end; - Result := Buffer.AsString; - finally - Buffer.Free; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TCustomVirtualStringTree.GetTextInfo(Node: PVirtualNode; Column: TColumnIndex; const AFont: TFont; var R: TRect; - var Text: WideString); - -// Returns the font, the text and its bounding rectangle to the caller. R is returned as the closest -// bounding rectangle around Text. - -var - NewHeight: Integer; - TM: TTextMetric; - -begin - // Get default font and initialize the other parameters. - inherited GetTextInfo(Node, Column, AFont, R, Text); - - Canvas.Font := AFont; - - FFontChanged := False; - RedirectFontChangeEvent(Canvas); - DoPaintText(Node, Canvas, Column, ttNormal); - if FFontChanged then - begin - AFont.Assign(Canvas.Font); - GetTextMetrics(Canvas.Handle, TM); - NewHeight := TM.tmHeight; - end - else // Otherwise the correct font is already there and we only need to set the correct height. - NewHeight := FTextHeight; - RestoreFontChangeEvent(Canvas); - - // Alignment to the actual text. - Text := Self.Text[Node, Column]; - R := GetDisplayRect(Node, Column, True, not (vsMultiline in Node.States)); - if toShowHorzGridLines in TreeOptions.PaintOptions then - Dec(R.Bottom); - InflateRect(R, 0, -(R.Bottom - R.Top - NewHeight) div 2); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TCustomVirtualStringTree.InvalidateNode(Node: PVirtualNode): TRect; - -var - Data: PInteger; - -begin - Result := inherited InvalidateNode(Node); - // Reset node width so changed text attributes are applied correctly. - if Assigned(Node) then - begin - Data := InternalData(Node); - if Assigned(Data) then - Data^ := 0; - // Reset height measured flag too to cause a re-issue of the OnMeasureItem event. - Exclude(Node.States, vsHeightMeasured); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TCustomVirtualStringTree.Path(Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType; - Delimiter: WideChar): WideString; - -// Constructs a string containing the node and all its parents. The last character in the returned path is always the -// given delimiter. - -var - S: WideString; - -begin - if (Node = nil) or (Node = FRoot) then - Result := Delimiter - else - begin - Result := ''; - while Node <> FRoot do - begin - DoGetText(Node, Column, TextType, S); - Result := S + Delimiter + Result; - Node := Node.Parent; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TCustomVirtualStringTree.ReinitNode(Node: PVirtualNode; Recursive: Boolean); - -var - Data: PInteger; - -begin - inherited; - // Reset node width so changed text attributes are applied correctly. - if Assigned(Node) and (Node <> FRoot) then - begin - Data := InternalData(Node); - if Assigned(Data) then - Data^ := 0; - // vsHeightMeasured is already removed in the base tree. - end; -end; - -//----------------- TVirtualStringTree --------------------------------------------------------------------------------- - -function TVirtualStringTree.GetOptions: TStringTreeOptions; - -begin - Result := FOptions as TStringTreeOptions; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TVirtualStringTree.SetOptions(const Value: TStringTreeOptions); - -begin - FOptions.Assign(Value); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TVirtualStringTree.GetOptionsClass: TTreeOptionsClass; - -begin - Result := TStringTreeOptions; -end; - -//----------------- TCustomVirtualDrawTree ----------------------------------------------------------------------------- - -procedure TCustomVirtualDrawTree.DoDrawHint(Canvas: TCanvas; Node: PVirtualNode; R: TRect; Column: TColumnIndex); - -begin - if Assigned(FOnDrawHint) then - FOnDrawHint(Self, Canvas, Node, R, Column); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TCustomVirtualDrawTree.DoGetHintSize(Node: PVirtualNode; Column: TColumnIndex; var R: TRect); - -begin - if Assigned(FOnGetHintSize) then - FOnGetHintSize(Self, Node, Column, R); -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; - -//----------------- 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; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure Register; -begin - RegisterComponents('VirtualTreeView', [TVirtualDrawTree,TVirtualStringTree]); -end; - -initialization - {$I virtualtrees.lrs} - // Necessary for dynamic package loading. - Initialized := False; - NeedToUnitialize := False; - - // This watcher is used whenever a global structure could be modified by more than one thread. - Watcher := TVTCriticalSection.Create; -finalization - if Initialized then - FinalizeGlobalStructures; - - InternalClipboardFormats.Free; - InternalClipboardFormats := nil; - Watcher.Free; - Watcher := nil; - {$ifdef EnableAccessible} - if VTAccessibleFactory <> nil then - begin - VTAccessibleFactory.Free; - VTAccessibleFactory := nil; - end; - {$endif} -end. - - - diff --git a/components/virtualtreeview/demos/mininal/Main.lfm b/components/virtualtreeview/demos/mininal/Main.lfm deleted file mode 100644 index 1fcd94720..000000000 --- a/components/virtualtreeview/demos/mininal/Main.lfm +++ /dev/null @@ -1,103 +0,0 @@ -object MainForm: TMainForm - Left = 353 - Height = 481 - Top = 172 - Width = 425 - HorzScrollBar.Page = 424 - VertScrollBar.Page = 480 - ActiveControl = VST - Caption = 'Simple Virtual Treeview demo' - Font.Height = -11 - Font.Name = 'MS Sans Serif' - OnCreate = FormCreate - object Label1: TLabel - Left = 12 - Height = 14 - Top = 12 - Width = 117 - Caption = 'Last operation duration:' - Color = clNone - ParentColor = False - end - object VST: TVirtualStringTree - Left = 8 - Height = 318 - Top = 36 - Width = 397 - Anchors = [akTop, akLeft, akRight, akBottom] - Colors.BorderColor = clWindowText - Colors.HotColor = clBlack - Header.AutoSizeIndex = -1 - Header.Font.Height = -11 - Header.Font.Name = 'MS Sans Serif' - Header.MainColumn = -1 - Header.Options = [hoColumnResize, hoDrag] - HintAnimation = hatNone - IncrementalSearch = isAll - RootNodeCount = 100 - TabOrder = 0 - TreeOptions.AnimationOptions = [toAnimatedToggle] - TreeOptions.AutoOptions = [toAutoDropExpand, toAutoTristateTracking] - TreeOptions.MiscOptions = [toEditable, toInitOnSave, toToggleOnDblClick, toWheelPanning] - TreeOptions.PaintOptions = [toShowButtons, toShowRoot, toShowTreeLines, toThemeAware, toUseBlendedImages] - TreeOptions.SelectionOptions = [toMultiSelect, toCenterScrollIntoView] - OnFreeNode = VSTFreeNode - OnGetText = VSTGetText - OnInitNode = VSTInitNode - Columns = <> - end - object ClearButton: TButton - Left = 97 - Height = 25 - Top = 421 - Width = 129 - Anchors = [akLeft, akBottom] - BorderSpacing.InnerBorder = 4 - Caption = 'Clear tree' - OnClick = ClearButtonClick - TabOrder = 1 - end - object AddOneButton: TButton - Left = 96 - Height = 25 - Top = 361 - Width = 130 - Anchors = [akLeft, akBottom] - BorderSpacing.InnerBorder = 4 - Caption = 'Add node(s) to root' - OnClick = AddButtonClick - TabOrder = 2 - end - object Edit1: TEdit - Left = 8 - Height = 21 - Top = 377 - Width = 81 - Anchors = [akLeft, akBottom] - TabOrder = 3 - Text = '1' - end - object Button1: TButton - Tag = 1 - Left = 96 - Height = 25 - Top = 389 - Width = 130 - Anchors = [akLeft, akBottom] - BorderSpacing.InnerBorder = 4 - Caption = 'Add node(s) as children' - OnClick = AddButtonClick - TabOrder = 4 - end - object CloseButton: TButton - Left = 330 - Height = 25 - Top = 421 - Width = 75 - Anchors = [akRight, akBottom] - BorderSpacing.InnerBorder = 4 - Caption = 'Close' - OnClick = CloseButtonClick - TabOrder = 5 - end -end diff --git a/components/virtualtreeview/demos/mininal/Main.lrs b/components/virtualtreeview/demos/mininal/Main.lrs deleted file mode 100644 index e82672ace..000000000 --- a/components/virtualtreeview/demos/mininal/Main.lrs +++ /dev/null @@ -1,38 +0,0 @@ -LazarusResources.Add('TMainForm','FORMDATA',[ - 'TPF0'#9'TMainForm'#8'MainForm'#4'Left'#3'a'#1#6'Height'#3#225#1#3'Top'#3#172 - +#0#5'Width'#3#169#1#18'HorzScrollBar.Page'#3#168#1#18'VertScrollBar.Page'#3 - +#224#1#13'ActiveControl'#7#3'VST'#7'Caption'#6#28'Simple Virtual Treeview de' - +'mo'#11'Font.Height'#2#245#9'Font.Name'#6#13'MS Sans Serif'#8'OnCreate'#7#10 - +'FormCreate'#0#6'TLabel'#6'Label1'#4'Left'#2#12#6'Height'#2#14#3'Top'#2#12#5 - +'Width'#2'u'#7'Caption'#6#24'Last operation duration:'#5'Color'#7#6'clNone' - +#11'ParentColor'#8#0#0#18'TVirtualStringTree'#3'VST'#4'Left'#2#8#6'Height'#3 - +'>'#1#3'Top'#2'$'#5'Width'#3#141#1#7'Anchors'#11#5'akTop'#6'akLeft'#7'akRigh' - +'t'#8'akBottom'#0#18'Colors.BorderColor'#7#12'clWindowText'#15'Colors.HotCol' - +'or'#7#7'clBlack'#20'Header.AutoSizeIndex'#2#255#18'Header.Font.Height'#2#245 - +#16'Header.Font.Name'#6#13'MS Sans Serif'#17'Header.MainColumn'#2#255#14'Hea' - +'der.Options'#11#14'hoColumnResize'#6'hoDrag'#0#13'HintAnimation'#7#7'hatNon' - +'e'#17'IncrementalSearch'#7#5'isAll'#13'RootNodeCount'#2'd'#8'TabOrder'#2#0 - +#28'TreeOptions.AnimationOptions'#11#16'toAnimatedToggle'#0#23'TreeOptions.A' - +'utoOptions'#11#16'toAutoDropExpand'#22'toAutoTristateTracking'#0#23'TreeOpt' - +'ions.MiscOptions'#11#10'toEditable'#12'toInitOnSave'#18'toToggleOnDblClick' - +#14'toWheelPanning'#0#24'TreeOptions.PaintOptions'#11#13'toShowButtons'#10't' - +'oShowRoot'#15'toShowTreeLines'#12'toThemeAware'#18'toUseBlendedImages'#0#28 - +'TreeOptions.SelectionOptions'#11#13'toMultiSelect'#22'toCenterScrollIntoVie' - +'w'#0#10'OnFreeNode'#7#11'VSTFreeNode'#9'OnGetText'#7#10'VSTGetText'#10'OnIn' - +'itNode'#7#11'VSTInitNode'#7'Columns'#14#0#0#0#7'TButton'#11'ClearButton'#4 - +'Left'#2'a'#6'Height'#2#25#3'Top'#3#165#1#5'Width'#3#129#0#7'Anchors'#11#6'a' - +'kLeft'#8'akBottom'#0#25'BorderSpacing.InnerBorder'#2#4#7'Caption'#6#10'Clea' - +'r tree'#7'OnClick'#7#16'ClearButtonClick'#8'TabOrder'#2#1#0#0#7'TButton'#12 - +'AddOneButton'#4'Left'#2'`'#6'Height'#2#25#3'Top'#3'i'#1#5'Width'#3#130#0#7 - +'Anchors'#11#6'akLeft'#8'akBottom'#0#25'BorderSpacing.InnerBorder'#2#4#7'Cap' - +'tion'#6#19'Add node(s) to root'#7'OnClick'#7#14'AddButtonClick'#8'TabOrder' - +#2#2#0#0#5'TEdit'#5'Edit1'#4'Left'#2#8#6'Height'#2#21#3'Top'#3'y'#1#5'Width' - +#2'Q'#7'Anchors'#11#6'akLeft'#8'akBottom'#0#8'TabOrder'#2#3#4'Text'#6#1'1'#0 - +#0#7'TButton'#7'Button1'#3'Tag'#2#1#4'Left'#2'`'#6'Height'#2#25#3'Top'#3#133 - +#1#5'Width'#3#130#0#7'Anchors'#11#6'akLeft'#8'akBottom'#0#25'BorderSpacing.I' - +'nnerBorder'#2#4#7'Caption'#6#23'Add node(s) as children'#7'OnClick'#7#14'Ad' - +'dButtonClick'#8'TabOrder'#2#4#0#0#7'TButton'#11'CloseButton'#4'Left'#3'J'#1 - +#6'Height'#2#25#3'Top'#3#165#1#5'Width'#2'K'#7'Anchors'#11#7'akRight'#8'akBo' - +'ttom'#0#25'BorderSpacing.InnerBorder'#2#4#7'Caption'#6#5'Close'#7'OnClick'#7 - +#16'CloseButtonClick'#8'TabOrder'#2#5#0#0#0 -]); diff --git a/components/virtualtreeview/demos/mininal/Main.pas b/components/virtualtreeview/demos/mininal/Main.pas deleted file mode 100644 index a0699274b..000000000 --- a/components/virtualtreeview/demos/mininal/Main.pas +++ /dev/null @@ -1,190 +0,0 @@ -unit Main; - -{$MODE Delphi} -{$define DEBUG} - -// Demonstration project for TVirtualStringTree to generally show how to get started. -// Written by Mike Lischke. - -interface - -uses - {$ifdef DEBUG} - vtlogger, ipcchannel, - {$endif} - LCLIntf, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, - VirtualTrees, StdCtrls, ExtCtrls, LResources, Buttons; - -type - TMainForm = class(TForm) - VST: TVirtualStringTree; - ClearButton: TButton; - AddOneButton: TButton; - Edit1: TEdit; - Button1: TButton; - Label1: TLabel; - CloseButton: TButton; - procedure FormCreate(Sender: TObject); - procedure ClearButtonClick(Sender: TObject); - procedure AddButtonClick(Sender: TObject); - procedure VSTGetText(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType; - var Text: WideString); - procedure VSTFreeNode(Sender: TBaseVirtualTree; Node: PVirtualNode); - procedure VSTInitNode(Sender: TBaseVirtualTree; ParentNode, Node: PVirtualNode; - var InitialStates: TVirtualNodeInitStates); - procedure CloseButtonClick(Sender: TObject); - end; - -var - MainForm: TMainForm; - -//---------------------------------------------------------------------------------------------------------------------- - -implementation - - -type - // This is a very simple record we use to store data in the nodes. - // Since the application is responsible to manage all data including the node's caption - // this record can be considered as minimal requirement in all VT applications. - // Extend it to whatever your application needs. - PMyRec = ^TMyRec; - TMyRec = record - Caption: WideString; - end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TMainForm.FormCreate(Sender: TObject); - -begin - {$ifdef DEBUG} - Logger.ActiveClasses:=[];//[lcScroll,lcPaint]; - Logger.Channels.Add(TIPCChannel.Create); - Logger.Clear; - Logger.MaxStackCount:=10; - {$endif} - // Let the tree know how much data space we need. - VST.NodeDataSize := SizeOf(TMyRec); - // Set an initial number of nodes. - VST.RootNodeCount := 20; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TMainForm.ClearButtonClick(Sender: TObject); - -var - Start: Cardinal; - -begin - Screen.Cursor := crHourGlass; - try - Start := GetTickCount; - VST.Clear; - Label1.Caption := Format('Last operation duration: %d ms', [GetTickCount - Start]); - finally - Screen.Cursor := crDefault; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TMainForm.AddButtonClick(Sender: TObject); - -var - Count: Cardinal; - Start: Cardinal; - -begin - // Add some nodes to the treeview. - Screen.Cursor := crHourGlass; - with VST do - try - Start := GetTickCount; - case (Sender as TButton).Tag of - 0: // add to root - begin - Count := StrToInt(Edit1.Text); - RootNodeCount := RootNodeCount + Count; - end; - 1: // add as child - if Assigned(FocusedNode) then - begin - Count := StrToInt(Edit1.Text); - ChildCount[FocusedNode] := ChildCount[FocusedNode] + Count; - Expanded[FocusedNode] := True; - InvalidateToBottom(FocusedNode); - end; - end; - Label1.Caption := Format('Last operation duration: %d ms', [GetTickCount - Start]); - finally - Screen.Cursor := crDefault; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TMainForm.VSTGetText(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType; - var Text: WideString); - -var - Data: PMyRec; - -begin - // A handler for the OnGetText event is always needed as it provides the tree with the string data to display. - // Note that we are always using WideString. - Data := Sender.GetNodeData(Node); - if Assigned(Data) then - Text := Data.Caption; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TMainForm.VSTFreeNode(Sender: TBaseVirtualTree; Node: PVirtualNode); - -var - Data: PMyRec; - -begin - Data := Sender.GetNodeData(Node); - // Explicitely free the string, the VCL cannot know that there is one but needs to free - // it nonetheless. For more fields in such a record which must be freed use Finalize(Data^) instead touching - // every member individually. - if Assigned(Data) then - Data.Caption := ''; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TMainForm.VSTInitNode(Sender: TBaseVirtualTree; ParentNode, Node: PVirtualNode; - var InitialStates: TVirtualNodeInitStates); - -var - Data: PMyRec; - -begin - with Sender do - begin - Data := GetNodeData(Node); - // Construct a node caption. This event is triggered once for each node but - // appears asynchronously, which means when the node is displayed not when it is added. - Data.Caption := Format('Level %d, Index %d', [GetNodeLevel(Node), Node.Index]); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TMainForm.CloseButtonClick(Sender: TObject); - -begin - Close; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -initialization - {$i Main.lrs} - -end. - diff --git a/components/virtualtreeview/demos/mininal/Minimal.exe.Manifest b/components/virtualtreeview/demos/mininal/Minimal.exe.Manifest deleted file mode 100644 index ed4c13f15..000000000 --- a/components/virtualtreeview/demos/mininal/Minimal.exe.Manifest +++ /dev/null @@ -1 +0,0 @@ - Windows Shell \ No newline at end of file diff --git a/components/virtualtreeview/demos/mininal/minimal_lcl.lpi b/components/virtualtreeview/demos/mininal/minimal_lcl.lpi deleted file mode 100644 index 6df5fd2fb..000000000 --- a/components/virtualtreeview/demos/mininal/minimal_lcl.lpi +++ /dev/null @@ -1,73 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff --git a/components/virtualtreeview/demos/mininal/minimal_lcl.lpr b/components/virtualtreeview/demos/mininal/minimal_lcl.lpr deleted file mode 100644 index dd0f70b1c..000000000 --- a/components/virtualtreeview/demos/mininal/minimal_lcl.lpr +++ /dev/null @@ -1,18 +0,0 @@ -program minimal_lcl; - -{$mode objfpc}{$H+} - -uses - {$IFDEF UNIX}{$IFDEF UseCThreads} - cthreads, - {$ENDIF}{$ENDIF} - Interfaces, // this includes the LCL widgetset - Forms - { add your units here }, Main, miscutils_package, virtualtreeview_package; - -begin - Application.Initialize; - Application.CreateForm(TMainForm, MainForm); - Application.Run; -end. - diff --git a/components/virtualtreeview/demos/objects/MVCDemoMain.lfm b/components/virtualtreeview/demos/objects/MVCDemoMain.lfm deleted file mode 100644 index c54560f0d..000000000 --- a/components/virtualtreeview/demos/objects/MVCDemoMain.lfm +++ /dev/null @@ -1,212 +0,0 @@ -object fmMVCDemo: TfmMVCDemo - Left = 258 - Height = 480 - Top = 174 - Width = 709 - HorzScrollBar.Page = 708 - VertScrollBar.Page = 479 - ActiveControl = edCaption - Caption = 'Virtual Tree - MVC Demo written by Marian Aldenhövel' - Font.Height = -11 - Font.Name = 'MS Sans Serif' - OnCreate = FormCreate - object pnlControls: TPanel - Height = 84 - Top = 396 - Width = 709 - Align = alBottom - BevelInner = bvLowered - BevelOuter = bvNone - Caption = ' ' - TabOrder = 0 - object Label1: TLabel - Left = 51 - Height = 14 - Top = 8 - Width = 42 - Alignment = taRightJustify - Caption = 'Caption:' - Color = clNone - ParentColor = False - end - object Label3: TLabel - Left = 33 - Height = 14 - Top = 31 - Width = 58 - Alignment = taRightJustify - Caption = 'Subcaption:' - Color = clNone - ParentColor = False - end - object Label4: TLabel - Left = 7 - Height = 14 - Top = 56 - Width = 88 - Alignment = taRightJustify - Caption = 'Incidence (0..63):' - Color = clNone - ParentColor = False - end - object Label2: TLabel - Left = 212 - Height = 92 - Top = 4 - Width = 186 - Caption = 'Edit the current node.'#13#10#13#10'Note that you are setting data in a structure without referring to a visual component except for the information about what node currently has the focus.' - Color = clNone - ParentColor = False - WordWrap = True - end - object edCaption: TEdit - Left = 92 - Height = 21 - Top = 5 - Width = 112 - OnChange = edCaptionChange - TabOrder = 0 - Text = 'edCaption' - end - object edSubcaption: TEdit - Left = 92 - Height = 21 - Top = 29 - Width = 112 - OnChange = edSubcaptionChange - TabOrder = 1 - Text = 'edCaption' - end - object edIncidence: TEdit - Left = 92 - Height = 21 - Top = 53 - Width = 59 - OnChange = edIncidenceChange - OnKeyDown = nil - OnKeyPress = edIncidenceKeyPress - TabOrder = 2 - Text = '0' - end - object UpDown1: TUpDown - Left = 151 - Height = 21 - Top = 53 - Width = 15 - Associate = edIncidence - Max = 63 - TabOrder = 3 - end - object btnAdd: TButton - Left = 429 - Height = 25 - Top = 4 - Width = 75 - BorderSpacing.InnerBorder = 4 - Caption = '+ Add a child' - OnClick = btnAddClick - TabOrder = 4 - end - object btnDelete: TButton - Left = 429 - Height = 25 - Top = 32 - Width = 75 - BorderSpacing.InnerBorder = 4 - Caption = '- delete node' - OnClick = btnDeleteClick - TabOrder = 5 - end - object cbLive: TCheckBox - Left = 618 - Height = 13 - Top = 9 - Width = 48 - Caption = 'Live!' - Font.Height = -11 - Font.Name = 'MS Sans Serif' - Font.Style = [fsBold] - OnClick = cbLiveClick - TabOrder = 6 - end - end - object ImageList1: TImageList - left = 120 - top = 143 - Bitmap = { - 6C690500000010000000100000009C0100002F2A2058504D202A2F0A73746174 - 69632063686172202A677261706869635B5D203D207B0A223136203136203320 - 31222C0A222E2063204E6F6E65222C0A222C20632023303030303030222C0A22 - 2D20632023464646464646222C0A222E2E2E2E2E2E2E2E2E2E2E2E2E2E2E2E22 - 2C0A222E2E2E2E2E2E2E2E2E2E2E2E2E2E2E2E222C0A222E2E2E2E2E2E2E2E2E - 2C2C2E2E2E2E2E222C0A222E2E2E2E2E2E2E2E2C2D2D2C2E2E2E2E222C0A222E - 2E2E2E2E2E2E2E2C2D2D2D2C2E2E2E222C0A222E2E2E2E2E2E2E2E2C2D2D2D2C - 2E2E2E222C0A222E2E2E2E2E2E2E2E2C2D2D2D2C2E2E2E222C0A222E2E2E2E2E - 2E2E2E2C2D2D2C2E2E2E2E222C0A222E2E2E2E2E2E2E2E2C2D2D2C2E2E2E2E22 - 2C0A222E2E2E2E2E2E2E2E2C2D2D2C2E2E2E2E222C0A222E2E2E2E2E2E2E2E2C - 2C2C2C2E2E2E2E222C0A222E2E2E2E2E2E2E2E2C2D2D2C2E2E2E2E222C0A222E - 2E2E2E2E2E2E2E2C2D2D2C2E2E2E2E222C0A222E2E2E2E2E2E2E2E2C2C2C2C2E - 2E2E2E222C0A222E2E2E2E2E2E2E2E2E2E2E2E2E2E2E2E222C0A222E2E2E2E2E - 2E2E2E2E2E2E2E2E2E2E2E227D0A9C0100002F2A2058504D202A2F0A73746174 - 69632063686172202A677261706869635B5D203D207B0A223136203136203320 - 31222C0A222E2063204E6F6E65222C0A222C20632023303030303030222C0A22 - 2D20632023303043304330222C0A222E2E2E2E2E2E2E2E2E2E2E2E2E2E2E2E22 - 2C0A222E2E2E2E2E2E2E2E2E2E2E2E2E2E2E2E222C0A222E2E2E2E2E2E2E2E2E - 2C2C2E2E2E2E2E222C0A222E2E2E2E2E2E2E2E2C2D2D2C2E2E2E2E222C0A222E - 2E2E2E2E2E2E2E2C2D2D2D2C2E2E2E222C0A222E2E2E2E2E2E2E2E2C2D2D2D2C - 2E2E2E222C0A222E2E2E2E2E2E2E2E2C2D2D2D2C2E2E2E222C0A222E2E2E2E2E - 2E2E2E2C2D2D2C2E2E2E2E222C0A222E2E2E2E2E2E2E2E2C2D2D2C2E2E2E2E22 - 2C0A222E2E2E2E2E2E2E2E2C2D2D2C2E2E2E2E222C0A222E2E2E2E2E2E2E2E2C - 2C2C2C2E2E2E2E222C0A222E2E2E2E2E2E2E2E2C2D2D2C2E2E2E2E222C0A222E - 2E2E2E2E2E2E2E2C2D2D2C2E2E2E2E222C0A222E2E2E2E2E2E2E2E2C2C2C2C2E - 2E2E2E222C0A222E2E2E2E2E2E2E2E2E2E2E2E2E2E2E2E222C0A222E2E2E2E2E - 2E2E2E2E2E2E2E2E2E2E2E227D0A9C0100002F2A2058504D202A2F0A73746174 - 69632063686172202A677261706869635B5D203D207B0A223136203136203320 - 31222C0A222E2063204E6F6E65222C0A222C20632023303030303030222C0A22 - 2D20632023303043303030222C0A222E2E2E2E2E2E2E2E2E2E2E2E2E2E2E2E22 - 2C0A222E2E2E2E2E2E2E2E2E2E2E2E2E2E2E2E222C0A222E2E2E2E2E2E2E2E2E - 2C2C2E2E2E2E2E222C0A222E2E2E2E2E2E2E2E2C2D2D2C2E2E2E2E222C0A222E - 2E2E2E2E2E2E2E2C2D2D2D2C2E2E2E222C0A222E2E2E2E2E2E2E2E2C2D2D2D2C - 2E2E2E222C0A222E2E2E2E2E2E2E2E2C2D2D2D2C2E2E2E222C0A222E2E2E2E2E - 2E2E2E2C2D2D2C2E2E2E2E222C0A222E2E2E2E2E2E2E2E2C2D2D2C2E2E2E2E22 - 2C0A222E2E2E2E2E2E2E2E2C2D2D2C2E2E2E2E222C0A222E2E2E2E2E2E2E2E2C - 2C2C2C2E2E2E2E222C0A222E2E2E2E2E2E2E2E2C2D2D2C2E2E2E2E222C0A222E - 2E2E2E2E2E2E2E2C2D2D2C2E2E2E2E222C0A222E2E2E2E2E2E2E2E2C2C2C2C2E - 2E2E2E222C0A222E2E2E2E2E2E2E2E2E2E2E2E2E2E2E2E222C0A222E2E2E2E2E - 2E2E2E2E2E2E2E2E2E2E2E227D0A9C0100002F2A2058504D202A2F0A73746174 - 69632063686172202A677261706869635B5D203D207B0A223136203136203320 - 31222C0A222E2063204E6F6E65222C0A222C20632023303030303030222C0A22 - 2D20632023464630303030222C0A222E2E2E2E2E2E2E2E2E2E2E2E2E2E2E2E22 - 2C0A222E2E2E2E2E2E2E2E2E2E2E2E2E2E2E2E222C0A222E2E2E2E2E2E2E2E2E - 2C2C2E2E2E2E2E222C0A222E2E2E2E2E2E2E2E2C2D2D2C2E2E2E2E222C0A222E - 2E2E2E2E2E2E2E2C2D2D2D2C2E2E2E222C0A222E2E2E2E2E2E2E2E2C2D2D2D2C - 2E2E2E222C0A222E2E2E2E2E2E2E2E2C2D2D2D2C2E2E2E222C0A222E2E2E2E2E - 2E2E2E2C2D2D2C2E2E2E2E222C0A222E2E2E2E2E2E2E2E2C2D2D2C2E2E2E2E22 - 2C0A222E2E2E2E2E2E2E2E2C2D2D2C2E2E2E2E222C0A222E2E2E2E2E2E2E2E2C - 2C2C2C2E2E2E2E222C0A222E2E2E2E2E2E2E2E2C2D2D2C2E2E2E2E222C0A222E - 2E2E2E2E2E2E2E2C2D2D2C2E2E2E2E222C0A222E2E2E2E2E2E2E2E2C2C2C2C2E - 2E2E2E222C0A222E2E2E2E2E2E2E2E2E2E2E2E2E2E2E2E222C0A222E2E2E2E2E - 2E2E2E2E2E2E2E2E2E2E2E227D0A9C0100002F2A2058504D202A2F0A73746174 - 69632063686172202A677261706869635B5D203D207B0A223136203136203320 - 31222C0A222E2063204E6F6E65222C0A222C20632023303030303030222C0A22 - 2D20632023464646463030222C0A222E2E2E2E2E2E2E2E2E2E2E2E2E2E2E2E22 - 2C0A222E2E2E2E2E2E2E2E2E2E2E2E2E2E2E2E222C0A222E2E2E2E2E2E2E2E2E - 2C2C2E2E2E2E2E222C0A222E2E2E2E2E2E2E2E2C2D2D2C2E2E2E2E222C0A222E - 2E2E2E2E2E2E2E2C2D2D2D2C2E2E2E222C0A222E2E2E2E2E2E2E2E2C2D2D2D2C - 2E2E2E222C0A222E2E2E2E2E2E2E2E2C2D2D2D2C2E2E2E222C0A222E2E2E2E2E - 2E2E2E2C2D2D2C2E2E2E2E222C0A222E2E2E2E2E2E2E2E2C2D2D2C2E2E2E2E22 - 2C0A222E2E2E2E2E2E2E2E2C2D2D2C2E2E2E2E222C0A222E2E2E2E2E2E2E2E2C - 2C2C2C2E2E2E2E222C0A222E2E2E2E2E2E2E2E2C2D2D2C2E2E2E2E222C0A222E - 2E2E2E2E2E2E2E2C2D2D2C2E2E2E2E222C0A222E2E2E2E2E2E2E2E2C2C2C2C2E - 2E2E2E222C0A222E2E2E2E2E2E2E2E2E2E2E2E2E2E2E2E222C0A222E2E2E2E2E - 2E2E2E2E2E2E2E2E2E2E2E227D0A - } - end - object timLive: TTimer - Enabled = False - Interval = 100 - OnTimer = timLiveTimer - left = 120 - top = 172 - end -end diff --git a/components/virtualtreeview/demos/objects/MVCDemoMain.lrs b/components/virtualtreeview/demos/objects/MVCDemoMain.lrs deleted file mode 100644 index f0d22e570..000000000 --- a/components/virtualtreeview/demos/objects/MVCDemoMain.lrs +++ /dev/null @@ -1,77 +0,0 @@ -{ This is an automatically generated lazarus resource file } - -LazarusResources.Add('TfmMVCDemo','FORMDATA',[ - 'TPF0'#10'TfmMVCDemo'#9'fmMVCDemo'#4'Left'#3#2#1#6'Height'#3#224#1#3'Top'#3 - +#174#0#5'Width'#3#197#2#18'HorzScrollBar.Page'#3#196#2#18'VertScrollBar.Page' - +#3#223#1#13'ActiveControl'#7#9'edCaption'#7'Caption'#6'5Virtual Tree - MVC D' - +'emo written by Marian Aldenh'#195#182'vel'#11'Font.Height'#2#245#9'Font.Nam' - +'e'#6#13'MS Sans Serif'#8'OnCreate'#7#10'FormCreate'#0#6'TPanel'#11'pnlContr' - +'ols'#6'Height'#2'T'#3'Top'#3#140#1#5'Width'#3#197#2#5'Align'#7#8'alBottom' - +#10'BevelInner'#7#9'bvLowered'#10'BevelOuter'#7#6'bvNone'#7'Caption'#6#1' '#8 - +'TabOrder'#2#0#0#6'TLabel'#6'Label1'#4'Left'#2'3'#6'Height'#2#14#3'Top'#2#8#5 - +'Width'#2'*'#9'Alignment'#7#14'taRightJustify'#7'Caption'#6#8'Caption:'#5'Co' - +'lor'#7#6'clNone'#11'ParentColor'#8#0#0#6'TLabel'#6'Label3'#4'Left'#2'!'#6'H' - +'eight'#2#14#3'Top'#2#31#5'Width'#2':'#9'Alignment'#7#14'taRightJustify'#7'C' - +'aption'#6#11'Subcaption:'#5'Color'#7#6'clNone'#11'ParentColor'#8#0#0#6'TLab' - +'el'#6'Label4'#4'Left'#2#7#6'Height'#2#14#3'Top'#2'8'#5'Width'#2'X'#9'Alignm' - +'ent'#7#14'taRightJustify'#7'Caption'#6#18'Incidence (0..63):'#5'Color'#7#6 - +'clNone'#11'ParentColor'#8#0#0#6'TLabel'#6'Label2'#4'Left'#3#212#0#6'Height' - +#2'\'#3'Top'#2#4#5'Width'#3#186#0#7'Caption'#6#179'Edit the current node.'#13 - +#10#13#10'Note that you are setting data in a structure without referring to' - +' a visual component except for the information about what node currently ha' - +'s the focus.'#5'Color'#7#6'clNone'#11'ParentColor'#8#8'WordWrap'#9#0#0#5'TE' - +'dit'#9'edCaption'#4'Left'#2'\'#6'Height'#2#21#3'Top'#2#5#5'Width'#2'p'#8'On' - +'Change'#7#15'edCaptionChange'#8'TabOrder'#2#0#4'Text'#6#9'edCaption'#0#0#5 - +'TEdit'#12'edSubcaption'#4'Left'#2'\'#6'Height'#2#21#3'Top'#2#29#5'Width'#2 - +'p'#8'OnChange'#7#18'edSubcaptionChange'#8'TabOrder'#2#1#4'Text'#6#9'edCapti' - +'on'#0#0#5'TEdit'#11'edIncidence'#4'Left'#2'\'#6'Height'#2#21#3'Top'#2'5'#5 - +'Width'#2';'#8'OnChange'#7#17'edIncidenceChange'#9'OnKeyDown'#13#10'OnKeyPre' - +'ss'#7#19'edIncidenceKeyPress'#8'TabOrder'#2#2#4'Text'#6#1'0'#0#0#7'TUpDown' - +#7'UpDown1'#4'Left'#3#151#0#6'Height'#2#21#3'Top'#2'5'#5'Width'#2#15#9'Assoc' - +'iate'#7#11'edIncidence'#3'Max'#2'?'#8'TabOrder'#2#3#0#0#7'TButton'#6'btnAdd' - +#4'Left'#3#173#1#6'Height'#2#25#3'Top'#2#4#5'Width'#2'K'#25'BorderSpacing.In' - +'nerBorder'#2#4#7'Caption'#6#13'+ Add a child'#7'OnClick'#7#11'btnAddClick'#8 - +'TabOrder'#2#4#0#0#7'TButton'#9'btnDelete'#4'Left'#3#173#1#6'Height'#2#25#3 - +'Top'#2' '#5'Width'#2'K'#25'BorderSpacing.InnerBorder'#2#4#7'Caption'#6#13'-' - +' delete node'#7'OnClick'#7#14'btnDeleteClick'#8'TabOrder'#2#5#0#0#9'TCheckB' - +'ox'#6'cbLive'#4'Left'#3'j'#2#6'Height'#2#13#3'Top'#2#9#5'Width'#2'0'#7'Capt' - +'ion'#6#5'Live!'#11'Font.Height'#2#245#9'Font.Name'#6#13'MS Sans Serif'#10'F' - +'ont.Style'#11#6'fsBold'#0#7'OnClick'#7#11'cbLiveClick'#8'TabOrder'#2#6#0#0#0 - +#10'TImageList'#10'ImageList1'#4'left'#2'x'#3'top'#3#143#0#6'Bitmap'#10'.'#8 - +#0#0'li'#5#0#0#0#16#0#0#0#16#0#0#0#156#1#0#0'/* XPM */'#10'static char *grap' - +'hic[] = {'#10'"16 16 3 1",'#10'". c None",'#10'", c #000000",'#10'"- c #FFF' - +'FFF",'#10'"................",'#10'"................",'#10'".........,,.....' - +'",'#10'"........,--,....",'#10'"........,---,...",'#10'"........,---,...",' - +#10'"........,---,...",'#10'"........,--,....",'#10'"........,--,....",'#10 - +'"........,--,....",'#10'"........,,,,....",'#10'"........,--,....",'#10'"..' - +'......,--,....",'#10'"........,,,,....",'#10'"................",'#10'".....' - +'..........."}'#10#156#1#0#0'/* XPM */'#10'static char *graphic[] = {'#10'"1' - +'6 16 3 1",'#10'". c None",'#10'", c #000000",'#10'"- c #00C0C0",'#10'".....' - +'...........",'#10'"................",'#10'".........,,.....",'#10'"........' - +',--,....",'#10'"........,---,...",'#10'"........,---,...",'#10'"........,--' - +'-,...",'#10'"........,--,....",'#10'"........,--,....",'#10'"........,--,..' - +'..",'#10'"........,,,,....",'#10'"........,--,....",'#10'"........,--,...."' - +','#10'"........,,,,....",'#10'"................",'#10'"................"}' - +#10#156#1#0#0'/* XPM */'#10'static char *graphic[] = {'#10'"16 16 3 1",'#10 - +'". c None",'#10'", c #000000",'#10'"- c #00C000",'#10'"................",' - +#10'"................",'#10'".........,,.....",'#10'"........,--,....",'#10 - +'"........,---,...",'#10'"........,---,...",'#10'"........,---,...",'#10'"..' - +'......,--,....",'#10'"........,--,....",'#10'"........,--,....",'#10'".....' - +'...,,,,....",'#10'"........,--,....",'#10'"........,--,....",'#10'"........' - +',,,,....",'#10'"................",'#10'"................"}'#10#156#1#0#0'/*' - +' XPM */'#10'static char *graphic[] = {'#10'"16 16 3 1",'#10'". c None",'#10 - +'", c #000000",'#10'"- c #FF0000",'#10'"................",'#10'"............' - +'....",'#10'".........,,.....",'#10'"........,--,....",'#10'"........,---,..' - +'.",'#10'"........,---,...",'#10'"........,---,...",'#10'"........,--,....",' - +#10'"........,--,....",'#10'"........,--,....",'#10'"........,,,,....",'#10 - +'"........,--,....",'#10'"........,--,....",'#10'"........,,,,....",'#10'"..' - ,'..............",'#10'"................"}'#10#156#1#0#0'/* XPM */'#10'static' - +' char *graphic[] = {'#10'"16 16 3 1",'#10'". c None",'#10'", c #000000",'#10 - +'"- c #FFFF00",'#10'"................",'#10'"................",'#10'".......' - +'..,,.....",'#10'"........,--,....",'#10'"........,---,...",'#10'"........,-' - +'--,...",'#10'"........,---,...",'#10'"........,--,....",'#10'"........,--,.' - +'...",'#10'"........,--,....",'#10'"........,,,,....",'#10'"........,--,....' - +'",'#10'"........,--,....",'#10'"........,,,,....",'#10'"................",' - +#10'"................"}'#10#0#0#6'TTimer'#7'timLive'#7'Enabled'#8#8'Interval' - +#2'd'#7'OnTimer'#7#12'timLiveTimer'#4'left'#2'x'#3'top'#3#172#0#0#0#0 -]); diff --git a/components/virtualtreeview/demos/objects/MVCDemoMain.pas b/components/virtualtreeview/demos/objects/MVCDemoMain.pas deleted file mode 100644 index 19aa8692d..000000000 --- a/components/virtualtreeview/demos/objects/MVCDemoMain.pas +++ /dev/null @@ -1,218 +0,0 @@ -unit MVCDemoMain; - -{$MODE Delphi} - -{ (c) 2000 Marian Aldenhövel - Hainstraße 8 - 53121 Bonn - +49 228 6203366 - Fax: +49 228 624031 - marian@mba-software.de - - Free: You may use this code in every way you find it useful or fun. - - Main form for the MVCDemo-Project. See MVCTypes.pas for Details. } - -interface - -uses LCLIntf,Messages,SysUtils,Classes,Graphics,Controls,Forms,Dialogs, - MVCTypes,MVCPanel,StdCtrls,ExtCtrls,ImgList,VirtualTrees,ComCtrls, - Buttons, LResources, vtlogger,ipcchannel; - -type TfmMVCDemo=class(TForm) - pnlControls:TPanel; - ImageList1:TImageList; - edCaption:TEdit; - Label1:TLabel; - Label2:TLabel; - edSubcaption:TEdit; - Label3:TLabel; - edIncidence: TEdit; - Label4: TLabel; - UpDown1: TUpDown; - btnAdd: TButton; - btnDelete: TButton; - cbLive: TCheckBox; - timLive: TTimer; - procedure FormCreate(Sender:TObject); - procedure edCaptionChange(Sender:TObject); - procedure TreeViewChange(Sender:TBaseVirtualTree;Node:PVirtualNode); - procedure edIncidenceKeyPress(Sender:TObject;var Key:Char); - procedure edSubcaptionChange(Sender:TObject); - procedure edIncidenceChange(Sender:TObject); - procedure btnAddClick(Sender:TObject); - procedure btnDeleteClick(Sender: TObject); - procedure cbLiveClick(Sender: TObject); - procedure timLiveTimer(Sender: TObject); - private - P:TMVCPanel; - FTree:TMVCTree; - procedure UpdateFromNode; - function FocusedNode:TMVCNode; - function CreateDefaultTree:TMVCTree; - end; - -var fmMVCDemo:TfmMVCDemo; - -implementation - - -function TfmMVCDemo.CreateDefaultTree:TMVCTree; -{ recurse and curse :-) } -var i,j,k:integer; -begin - Result:=TMVCTree.Create; - for i:=0 to 2 do - with Result.Root.CreateChild do - begin - Caption:='Root'; - SubCaption:='Number '+IntToStr(i); - Incidence:=5+random(30); - for j:=0 to 2 do - with CreateChild do - begin - Caption:='Child'; - SubCaption:='Number '+IntToStr(j); - Incidence:=random(64); - for k:=0 to 1 do - with CreateChild do - begin - Caption:='Grandchild'; - SubCaption:='Number '+IntToStr(k); - Incidence:=random(64); - end; - end; - end; -end; - -procedure TfmMVCDemo.FormCreate(Sender: TObject); -begin - Logger.Channels.Add(TIPCChannel.Create); - Logger.ActiveClasses:=[lcEditLink]; - Logger.Clear; - P:=TMVCPanel.Create(Self); - with P do - begin - Parent:=Self; - Align:=alClient; - TreeView.Images:=ImageList1; - { Now this is what it's all about: - You have a structure - represented here by a call that creates - a tree. All you do is assign it to a property of the Viewer, - bingo. } - FTree:=CreateDefaultTree; - Tree:=FTree; - P.TreeView.OnChange:=TreeViewChange; - P.TreeView.FullExpand(NIL); - UpdateFromNode; - end; -end; - -procedure TfmMVCDemo.TreeViewChange(Sender:TBaseVirtualTree;Node:PVirtualNode); -begin - UpdateFromNode; -end; - -procedure TfmMVCDemo.UpdateFromNode; -begin - if FocusedNode=NIL - then - begin - edCaption.Text:= ''; - edCaption.Enabled:= False; - edSubCaption.Text:= ''; - edSubCaption.Enabled:=False; - edIncidence.Text:= ''; - edIncidence.Enabled:= False; - btnDelete.Enabled:=False; - end - else - begin - edCaption.Text:= FocusedNode.Caption; - edCaption.Enabled:= True; - edSubCaption.Text:= FocusedNode.SubCaption; - edSubCaption.Enabled:=True; - edIncidence.Text:= IntToStr(FocusedNode.Incidence); - edIncidence.Enabled:= True; - btnDelete.Enabled:= True; - end; -end; - -function TfmMVCDemo.FocusedNode:TMVCNode; -begin - with P.TreeView do - if FocusedNode<>NIL - then Result:=MVCNode[FocusedNode] - else Result:=NIL; -end; - -procedure TfmMVCDemo.edIncidenceKeyPress(Sender:TObject;var Key:Char); -begin - if not(Key in ['0'..'9',#8]) then Key:=#0; -end; - -procedure TfmMVCDemo.edSubcaptionChange(Sender:TObject); -begin - if FocusedNode<>NIL - then FocusedNode.SubCaption:=edSubCaption.Text; -end; - -procedure TfmMVCDemo.edCaptionChange(Sender:TObject); -begin - if FocusedNode<>NIL then FocusedNode.Caption:=edCaption.Text; -end; - -procedure TfmMVCDemo.edIncidenceChange(Sender:TObject); -begin - try - if FocusedNode<>NIL then - if edIncidence.Text='' - then FocusedNode.Incidence:=0 - else FocusedNode.Incidence:=StrToInt(edIncidence.Text); - except - ShowMessage('Enter a number between 0 and 63'); - end; -end; - -procedure TfmMVCDemo.btnAddClick(Sender:TObject); -var R:TMVCNode; -begin - if FocusedNode<>NIL - then R:=FocusedNode - else R:=FTree.Root; - with R do - begin - R:=CreateChild; - R.Caption:='New'; - end; -end; - -procedure TfmMVCDemo.btnDeleteClick(Sender: TObject); -begin - FocusedNode.Free; -end; - -procedure TfmMVCDemo.cbLiveClick(Sender: TObject); -begin - timLive.Enabled:=cbLive.Checked; -end; - -procedure TfmMVCDemo.timLiveTimer(Sender: TObject); -var N:TMVCNode; -begin - { Change the Incidence-Field of one node on every - level in one branch of the tree. } - N:=FTree.Root; - while Assigned(N) do - begin - N.Incidence:=5+random(63); - if N.ChildCount>0 - then N:=N.Child[random(N.ChildCount)] - else N:=NIL; - end; -end; - -initialization - {$i MVCDemoMain.lrs} - Randomize; -end. diff --git a/components/virtualtreeview/demos/objects/MVCPanel.pas b/components/virtualtreeview/demos/objects/MVCPanel.pas deleted file mode 100644 index e48b729c5..000000000 --- a/components/virtualtreeview/demos/objects/MVCPanel.pas +++ /dev/null @@ -1,127 +0,0 @@ -unit MVCPanel; - -{$MODE Delphi} - -{ (c) 2000 Marian Aldenhövel - Hainstraße 8 - 53121 Bonn - +49 228 6203366 - Fax: +49 228 624031 - marian@mba-software.de - - Free: You may use this code in every way you find it useful or fun. - - This declares a Panel that hold another Panel and a TMVCTreeView. In - this Application is not at all useful, you could just as well create the - components at designtime. - - The reason why the component is here is because it hints at the - possibility to use a TMVCTreeView in a hypothetical compound component - TMVMTreeEditor that adds more controls that modify the same structure. - - It also shows how to initialize the Columns of a runtime-created - TVirtualTree. -} - -interface - -uses LCLIntf,Controls,Graphics,SysUtils,Classes,ExtCtrls,StdCtrls, - MVCTypes,VirtualTrees; - -type TMVCPanel=class(TCustomPanel) - private - FpnlTop:TPanel; - FTrvItems:TMVCTreeView; - procedure SetItems(aTree:TMVCTree); - function GetItems:TMVCTree; - protected - procedure CreateWnd; override; - public - constructor Create(aOwner:TComponent); override; - - property TreeView:TMVCTreeView read FtrvItems; - property Tree:TMVCTree read GetItems write SetItems; - end; - -implementation - -procedure TMVCPanel.SetItems(aTree:TMVCTree); -begin - { Just link the Items to the TreeView, no processing of our own. } - FtrvItems.Tree:=aTree; -end; - -function TMVCPanel.GetItems:TMVCTree; -begin - Result:=FtrvItems.Tree; -end; - -constructor TMVCPanel.Create(aOwner:TComponent); -begin - inherited Create(aOwner); - BevelOuter:=bvNone; - Caption:=' '; - - FpnlTop:=TPanel.Create(Self); - with FpnlTop do - begin - Parent:=Self; - Align:=alTop; - Height:=30; - Caption:='SomePanel'; - BevelOuter:=bvNone; - BevelInner:=bvLowered; - end; - - FtrvItems:=TMVCTreeView.Create(Self); - with FtrvItems do - begin - Parent:=Self; - Align:=alClient; - end; -end; - -procedure TMVCPanel.CreateWnd; -begin - inherited CreateWnd; - - with FtrvItems, TreeOptions do - begin - PaintOptions:=PaintOptions+[toShowButtons, // display collapse/expand - toShowHorzGridLines, // display horizontal lines - toShowRoot, // show lines also at root level - toShowTreeLines, // display tree lines to show - // hierarchy of nodes - // buttons left to a node - toShowVertGridLines]; // display vertical lines - // (depending on columns) to - // simulate a grid - MiscOptions := MiscOptions+[toEditable]; - SelectionOptions := SelectionOptions+[toExtendedFocus]; - // to simulate a grid - with Header do - begin - Height:=18; - Options:=Options+[hoVisible]; - Background:=clBtnFace; - AutoSize:=True; - with Columns.Add do - begin - Text:='Caption'; - Width:=300; - end; - with Columns.Add do - begin - Text:='SubCaption'; - Width:=100; - end; - with Columns.Add do - begin - Text:='Incidence'; - Width:=100; - end; - end; - end; -end; - -end. diff --git a/components/virtualtreeview/demos/objects/MVCTypes.pas b/components/virtualtreeview/demos/objects/MVCTypes.pas deleted file mode 100644 index cc83d8fd3..000000000 --- a/components/virtualtreeview/demos/objects/MVCTypes.pas +++ /dev/null @@ -1,1048 +0,0 @@ -unit MVCTypes; - -{$MODE Delphi} - -{ (c) 2000 Marian Aldenhövel - Hainstraße 8 - 53121 Bonn - +49 228 6203366 - Fax: +49 228 624031 - marian@mba-software.de - - Free: You may use this code in every way you find it useful or fun. - - Say you have a hierarchical (a flat list is a special case of such - a hierarchy :-)) structure in memory or a file. Now you need to - visualize that structure or give the user the ability to edit it. - - Traditionally you have two options: - - 1) Store the hierarchy in a TTreeView and should you need more - data than a simple hierarchy store pointers to that data in the - Data-property of the TTreeNode. - - This is an indecent mix of structure and visualization. The minute - you need to access and process that structure whithout displaying - it you either need to duplicate it or find yourself using - invisible TTreeView - so called TTreeViewNotViews :-). - - 2) Fill a TreeView with your Data and take very good care to - propagate each and every change and edit from the TTreeView to - your Data. - - This is a real pain in many parts of the body. - - Using Mike Lischkes fantastic virtual tree you can use a more modern - approach: - - Make a descendant of the Treeview that "knows" about your structure. - The Tree can be linked to your data and will now automatically - follow changes and vice-versa. I call this the "assign-and-forget"- - Method. - - This demo ist a simplified version of a component I use in one of my - current projects. Read the code to find out about it. - - Note that in this demo the definition and implementation of both - Structure and Tree are kept in a single unit. This is just for - ease of reading and distribution - in a real-world project it is - a good idea to keep them separate even if it means exposing fields - of the Nodes you would not need to expose otherwise. That way it - is easier to replace the visualization or change the implementation - of the structure without compromising the system. - - } - - -interface - -uses Windows, LCLIntf,Messages,SysUtils,Graphics,VirtualTrees,Classes,StdCtrls, - Controls,Forms,ImgList,LCLType, delphicompat, vtlogger; - -type { TMVCNode is the encapsulation of a single Node in the structure. - This implementation is a bit bloated because in my project - everything is in memory at all times. - In such an implementation there is not much "virtual" about the - tree anymore - still it's of incredible usefulness as you will - see. } - TMVCNode=class(TObject) - private - { Here's the data associated with a single Node in the - tree. This structure defines a caption and a subcaption, add - whatever defines your data completely. } - FParent:TMVCNode; - FChildren:TList; - FCheckState:TCheckState; - FCaption,FSubCaption:string; - { The FIncidence-Field is special in the way that it's - value is never displayed directly but used to - graphically alter the node's display. In my project it - is a "weight" showing the number of hits from a - database. Here it is displayed next to the caption - as a colored speck. } - FIncidence:integer; - - { Here's where we start to think of visualization. This - field points to the VirtualNode in a virtual tree that - is associated with the Node - if there is one, - otherwise it is NIL, there may be no virtual node - allocated for the TMVCNode or no tree linked. } - FVirtualNode:PVirtualNode; - - { Here are reader/writer-methods for the properties that - define our data. We need set-properties because we want - to update linked nodes directly. } - procedure SetCaption(aCaption:string); - procedure SetSubCaption(aSubCaption:string); - procedure SetCheckState(aCheckState:TCheckState); - procedure SetIncidence(aValue:integer); - function GetChildCount:integer; - function GetChild(n:integer):TMVCNode; - public - constructor Create; - destructor Destroy; override; - - { Take a look at our data and pick an icon from the - Imagelist to be displayed in the tree. } - function GetImageIndex:integer; virtual; - { Tell the tree to invalidate the node it displayes the - information for this Node in. It will be repainted - next } - procedure InvalidateVirtualNode; - - { properties exposing our internal data to the world. - set-methods are given so the Node can always invalidate - its node. } - property CheckState:TCheckState read FCheckState write SetCheckState; - property Caption:string read FCaption write SetCaption; - property SubCaption:string read FSubCaption write SetSubCaption; - property Incidence:integer read FIncidence write SetIncidence; - - property Parent:TMVCNode read FParent; - property ChildCount:integer read GetChildCount; - property Child[n:integer]:TMVCNode read GetChild; - function CreateChild:TMVCNode; - procedure RemoveChild(n:integer); - procedure DestroyChild(n:integer); - - { This field is only exposed because I advise you to put - the Tree-Code in a separate unit and then you won't get - far privatizing it. Allowing public write-access to it - is a bit hairy though, you should never write to the - field outside of this or the Tree-unit. - This is where a friend-declaration is missing from OP} - property VirtualNode:PVirtualNode read FVirtualNode write FVirtualNode; - end; - - { TMVCTree keeps the TMVCNodes. It also maintains the link to a - virtual treeview. } - TMVCTree=class - private - { This is the Root of the Tree. In this Demo that Root is there - purely to hold the structure together, it is never displayed - - just like TVirtualTrees own Root. } - FRoot:TMVCNode; - - { The Viewer-Field points to any component or object - used to visualize or edit this structure. It is - not really used in this demo, in a real application - you will find situations where you have to find out - whether you are linked and if so where to. - - Why is the Viewer declared as TObject and not as - the specific class? Two reasons: - - 1) The viewer should be implemented in a different - unit, either there or here you will have to - cast or you will build a circular reference. I - choose to cast here because - - 2) You may want to have _different_ viewers for - the same structure. Keeping that in mind you - may even want to change the declaration to - a list of linked viewers... } - FSettingViewer:integer; - FViewer:TObject; - - { Access-methods to expose the list in a type safe - way. } - - { A set-method that updates the link to a viewer. } - procedure SetViewer(aViewer:TObject); - - public - constructor Create; - destructor Destroy; override; - - property Root:TMVCNode read FRoot; - - { Assign to this to create or break the link with - a viewer. If you are about to add, remove or edit - a zillion Nodes you can call BeginUpdate and - EndUpdate. In this demo they just do the same for - any assigned viewer - Caution: The demo does not - make provisions for the case where you call - BeginUpdate and then switch to another viewer! } - property Viewer:TObject read FViewer write SetViewer; - procedure BeginUpdate; - procedure EndUpdate; - end; - - { Here's the Viewer. I have descended from the base class to maximize - the functionality that is moved to our code, should you be happy - with any of the predeclared descendants use of them. } - TMVCEditLink=class; - TMVCTreeView=class(TBaseVirtualTree) - private - { This is a pointer to the structure associated with - this viewer. } - FTree:TMVCTree; - FInternalDataOffset: Cardinal; // offset to the internal data - - { Make and break the link with a list } - procedure SetTree(aTree:TMVCTree); - - { These are for direct access to our structure - through the viewer. You can use them to find - the TMVCNode that corresponds to a selected - VirtualNode for instance. } - function GetMVCNode(VirtualNode:PVirtualNode):TMVCNode; - procedure SetMVCNode(VirtualNode:PVirtualNode; aNode:TMVCNode); - - function GetOptions: TVirtualTreeOptions; - procedure SetOptions(const Value: TVirtualTreeOptions); - protected - { Overridden methods of the tree, see their implementation for - details on what they do and why they are overridden. } - function DoGetNodeWidth(Node: PVirtualNode; Column: TColumnIndex; Canvas: TCanvas = nil): Integer; override; - procedure DoPaintNode(var PaintInfo: TVTPaintInfo); override; - procedure DoInitChildren(Node:PVirtualNode;var ChildCount:Cardinal); override; - procedure DoInitNode(aParent,aNode:PVirtualNode; - var aInitStates:TVirtualNodeInitStates); override; - procedure DoFreeNode(aNode:PVirtualNode); override; - function DoGetImageIndex(Node: PVirtualNode; Kind: TVTImageKind; Column: TColumnIndex; - var Ghosted: Boolean; var Index: Integer): TCustomImageList; override; - procedure DoChecked(aNode:PVirtualNode); override; - function DoCreateEditor(Node: PVirtualNode; Column: TColumnIndex): IVTEditLink; override; - function InternalData(Node: PVirtualNode): Pointer; - function InternalDataSize: Cardinal; - - function GetOptionsClass: TTreeOptionsClass; override; - public - constructor Create(AOwner: TComponent); override; - destructor Destroy; override; - - { Properties for the link to a list and the individual Node. - these form the interface to the application. See the main form - to check it out. } - property Tree:TMVCTree read FTree write SetTree; - property MVCNode[VirtualNode:PVirtualNode]:TMVCNode read GetMVCNode; - - function GetNodeText(aNode:TMVCNode; - aColumn:integer):string; - procedure SetNodeText(aNode:TMVCNode; - aColumn:integer; - aText:string); - published - { We descend from the base class, publish whatever you want to. - The demo only needs the Header, it is initialized in the fixed - panel-code. } - property TreeOptions: TVirtualTreeOptions read GetOptions write SetOptions; - property Header; - property Images; - property OnChange; - end; - - TMVCEdit=class(TCustomEdit) - private - FLink:TMVCEditLink; - procedure WMChar(var Message: TWMChar); message WM_CHAR; - procedure WMKeyDown(var Message: TWMKeyDown); message WM_KEYDOWN; - procedure WMKillFocus(var Msg: TWMKillFocus); message WM_KILLFOCUS; - protected - procedure AutoAdjustSize; - procedure CreateParams(var Params:TCreateParams); override; - public - constructor Create(Link:TMVCEditLink); reintroduce; - end; - - TMVCEditLink=class(TInterfacedObject,IVTEditLink) - private - FEdit:TMVCEdit; // a normal custom edit control - FTree:TMVCTreeView; // a back reference to the tree calling - FNode:PVirtualNode; // the node to be edited - FColumn:Integer; // the column of the node - public - constructor Create; - destructor Destroy; override; - - function BeginEdit: Boolean; stdcall; - function CancelEdit: Boolean; stdcall; - function EndEdit: Boolean; stdcall; - function GetBounds: TRect; stdcall; - function PrepareEdit(Tree: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex): Boolean; stdcall; - procedure ProcessMessage(var Message: TMessage); stdcall; - procedure SetBounds(R:TRect); stdcall; - - property Tree:TMVCTreeView read FTree; - end; - - -implementation - -{ Let's go } - -{ *********************************************************************** } - -constructor TMVCNode.Create; -begin - inherited Create; - FChildren:=TList.Create; -end; - -destructor TMVCNode.Destroy; -begin - if Assigned(FParent) then - with FParent do - RemoveChild(FChildren.IndexOf(Self)); - { When destroying free all children. } - while ChildCount>0 do DestroyChild(0); - - inherited Destroy; -end; - -function TMVCNode.GetImageIndex:integer; -begin - { Take a close look at your data and return the index of whatever image - you want next to it. Here we base the choice on the length of the - caption. No caption, no icon. } - if Caption='' - then Result:=-1 else Result:=(Length(Caption) mod 4); -end; - -procedure TMVCNode.InvalidateVirtualNode; -var T:TBaseVirtualTree; -begin - { If the tree has a node that displays this Node then invalidate it. } - if Assigned(FVirtualNode) then - begin - T := TreeFromNode(FVirtualNode); - T.InvalidateNode(FVirtualNode); - end; -end; - -procedure TMVCNode.SetCheckState(aCheckState:TCheckState); -begin - { Update the checkstate that is stored in our Node. If the tree has a - node for the Node then invalidate it. } - if aCheckState=FCheckstate then exit; - FCheckState:=aCheckState; - if Assigned(FVirtualNode) then FVirtualNode.CheckState:=aCheckState; - InvalidateVirtualNode; -end; - -procedure TMVCNode.SetIncidence(aValue:integer); -begin - { Set the Nodes property Incidence and invalidate the node in the tree - if there is one. We fix the value into its valid range. } - if aValue=FIncidence then exit; - FIncidence:=aValue; - if FIncidence<0 - then FIncidence:=0 - else - if FIncidence>63 - then FIncidence:=63; - InvalidateVirtualNode; -end; - -procedure TMVCNode.SetCaption(aCaption:string); -begin - { Set the Nodes property Caption and invalidate the node in the tree - if there is one. } - if aCaption=FCaption then exit; - FCaption:=aCaption; - InvalidateVirtualNode; -end; - -procedure TMVCNode.SetSubCaption(aSubCaption:string); -begin - { Set the Nodes property Subcaption and invalidate the node in the tree - if there is one. } - if aSubCaption=FSubCaption then exit; - FSubCaption:=aSubCaption; - InvalidateVirtualNode; -end; - -function TMVCNode.GetChildCount:integer; -begin - Result:=FChildren.Count; -end; - -function TMVCNode.GetChild(n:integer):TMVCNode; -begin - Result:=TMVCNode(FChildren[n]); -end; - -function TMVCNode.CreateChild:TMVCNode; -begin - Result:=TMVCNode.Create; - Result.FParent:=Self; - FChildren.Add(Result); - if Assigned(FVirtualNode) then - with TreeFromNode(FVirtualNode) do - begin - ReinitNode(FVirtualNode,False); - InvalidateToBottom(FVirtualNode); - end; -end; - -procedure TMVCNode.RemoveChild(n:integer); -var C:TMVCNode; -begin - { Remove Child number n from our Children-List and the tree } - C:=Child[n]; - C.FParent:=NIL; - FChildren.Delete(n); - if Assigned(C.FVirtualNode) then - TreeFromNode(C.FVirtualNode).DeleteNode(C.FVirtualNode); -end; - -procedure TMVCNode.DestroyChild(n:integer); -var C:TMVCNode; -begin - C:=Child[n]; - RemoveChild(n); - C.Free; -end; - -{*************************************************************************} - -constructor TMVCTree.Create; -begin - inherited Create; - FRoot:=TMVCNode.Create; -end; - -destructor TMVCTree.Destroy; -begin - { Upon destruction we need to break the link to the Viewer and free - all our Nodes and last the list itself. } - Viewer:=NIL; - FRoot.Free; - FRoot:=NIL; - inherited Destroy; -end; - -procedure TMVCTree.SetViewer(aViewer:TObject); -begin - { Assign a viewer, De-Assign a viewer (by passing NIL) and assigning - a different viewer than the one that is already linked. } - - { Prevent recursion when the viewer itself sets this property. } - if FSettingViewer>0 then exit; - - inc(FSettingViewer); - try - { First de-assign any viewer that is already linked. } - if Assigned(FViewer) then TMVCTreeView(FViewer).Tree:=NIL; - { Set our field to point to the new viewer. } - FViewer:=aViewer; - { Now assign this List to the new viewer. } - if Assigned(FViewer) then TMVCTreeView(FViewer).Tree:=Self; - finally - dec(FSettingViewer); - end; -end; - -procedure TMVCTree.BeginUpdate; -begin - if Assigned(FViewer) then TMVCTreeView(FViewer).BeginUpdate; -end; - -procedure TMVCTree.EndUpdate; -begin - if Assigned(FViewer) then TMVCTreeView(FViewer).EndUpdate; -end; - -{ *********************************************************************** } - -{ Now the tree. } - -{ The internal node-data assigned to every virtual node consist only of - a reference to an instance of TMVCNode. } -type PMyNodeData=^TMyNodeData; - TMyNodeData=packed record Node:TMVCNode end; - -destructor TMVCTreeView.Destroy; -begin - { When destroying the tree, break the link with the list. Note that - we do NOT set FNodes:=NIL. By using the Set-Method it is made sure - that the List gets notified of our demise and sets its own reference - to NIL too. } - Tree:=NIL; - inherited Destroy; -end; - -procedure TMVCTreeView.SetTree(aTree:TMVCTree); -begin - if FTree=aTree then exit; - - { If we already have a list, break the link to it. } - if Assigned(FTree) then FTree.Viewer:=NIL; - - { Now make a link to the new structure: } - FTree:=aTree; - if Assigned(FTree) - then - begin - FTree.Viewer:=Self; - RootNodeCount:=FTree.Root.ChildCount; - if FTree.Root.ChildCount>0 then ValidateNode(GetFirst, False); - end - else RootNodeCount:=0; -end; - -function TMVCTreeView.GetMVCNode(VirtualNode:PVirtualNode):TMVCNode; -begin - { Return the reference to the TMVCNode that is represented by - Virtualnode } - if VirtualNode=NIL - then Result:=NIL - else Result:=PMyNodeData(InternalData(VirtualNode)).Node; -end; - -procedure TMVCTreeView.SetMVCNode(VirtualNode:PVirtualNode;aNode:TMVCNode); -begin - { Note the relationship between a VirtualNode and the TMVCNode it - represents in the Nodes data. } - PMyNodeData(InternalData(VirtualNode)).Node:=aNode; -end; - -function TMVCTreeView.DoCreateEditor(Node: PVirtualNode; Column: TColumnIndex): IVTEditLink; -var Link:TMVCEditLink; -begin - Result:=inherited DoCreateEditor(Node,Column); - if Result=nil then - begin - Link:=TMVCEditLink.Create; - Result:=Link; - end; -end; - -function TMVCTreeView.DoGetNodeWidth(Node: PVirtualNode; Column: TColumnIndex; Canvas: TCanvas = nil): Integer; -{ How wide is the the node in pixels. This is interesting if the graphic - representation includes elements that are not text and whose width needs - to be calculated. Here we draw a bar whose width corresponds to the - value of the Incidence-property of the MVCNode. } -var N:TMVCNode; - Text: string; -begin - N:=GetMVCNode(Node); - if Canvas = nil then - Canvas := Self.Canvas; - if not Assigned(N) - then Result:=0 - else - begin - Text:=GetNodeText(N, Column); - Result:=Canvas.TextWidth(Text); - if Column + 1 in [0, 1] then - Result := Result + 8 + N.Incidence; - end; -end; - -function TMVCTreeView.GetNodeText(aNode:TMVCNode;aColumn:integer):string; -{ This method returns the text that is to be displayed in aColumn for - the Node aNode. It is in a separate function so that it can be used - for the calculation of width and for the actual drawing. You could - also process the data from the actual Node as stored in your structure - to give some other text as shown here for the third column. } -begin - case aColumn of - -1,0:Result:=aNode.Caption; - 1:Result:=aNode.SubCaption; - 2:case aNode.Incidence of - 0..5:Result:='under 6'; - 6..20:Result:='6 to 21'; - 21..62:Result:='21 or above'; - 63:Result:='Max.'; - else Result:='What?'; - end; (* of case Incidence *) - else Result:='What *"§ added columns without giving data?'; - end; (* of case aColumn *) -end; - -procedure TMVCTreeView.SetNodeText(aNode:TMVCNode;aColumn:integer;aText:string); -{ Set the text for the node and column. This is called by the editor when - editing has finished. } -begin - case aColumn of - -1,0:aNode.Caption:=aText; - 1:aNode.SubCaption:=aText; - else { Error, this column should not / cannot be edited } - end; (* of case aColumn *) -end; - -procedure TMVCTreeView.DoPaintNode(var PaintInfo: TVTPaintInfo); -{ Here we actually draw the graphical representation of the node. It is - drawn one cell, i.e. Node/Column at a time. All relevant data is either - passed as a parameter or we look it up in our TMVCNode-Structure that - is linked to the Node via the internal data. } - -var N:TMVCNode; - SaveFontColor:TColor; - Flags:Integer; - TxtRect:TRect; - NodeText:string; - OldBrushColor,OldPenColor:TColor; - - procedure SaveDC; - begin - OldBrushColor:=PaintInfo.Canvas.Brush.Color; - OldPenColor:=PaintInfo.Canvas.Pen.Color; - end; - - procedure RestoreDC; - begin - PaintInfo.Canvas.Brush.Color:=OldBrushColor; - PaintInfo.Canvas.Pen.Color:=OldPenColor; - end; - -begin - SaveDC; { No-brainer: We save and restore every canvas-setting, we _ever_ - change in this method. So initial and final state - of the canvas are of no concern. } - try - with PaintInfo, Canvas do - begin - Font:=Self.Font; - - { Get a reference to our data. If this fails bail out - this - should not happen anyway. If it does you will notice on screen. - Paranoics add assertions as you like. } - N:=MVCNode[Node]; if N=NIL then exit; - - { Get the text-string to be displayed in the column. } - NodeText:=GetNodeText(N, Column); - - { Some shuffling of feet and rectangles. Try for yourself what - happens here be adding offsets, changing colors etc.. } - if (toHotTrack in Self.TreeOptions.PaintOptions) and - (Node=HotNode) - then Font.Style:=Font.Style+[fsUnderline] - else Font.Style:=Font.Style-[fsUnderline]; - - if vsSelected in Node.States - then - begin - if Focused - then (* Selected, focused *) - begin - Brush.Color:=clHighLight; - Font.Color:=clWhite; - end - else (* Selected, non-focused *) - begin - Brush.Color:=clBtnFace; - Font.Color:=Self.Font.Color; - end; - { Fill out the entire rectangle } - FillRect(ContentRect); - end - else (* not selected, see Mikes samples on what is going on... *) - if Node=DropTargetNode - then - begin - if LastDropMode=dmOnNode - then - begin - Brush.Color:=clHighLight; - Font.Color:=clWhite; - end - else - begin - Brush.Style:=bsClear; - Font.Color:=Self.Font.Color; - end; - FillRect(ContentRect); - end; - - if Focused - and (FocusedNode=Node) and - not(toFullRowSelect in Self.TreeOptions.SelectionOptions) - then - begin - if Self.Color=clGray - then Brush.Color:=clWhite - else Brush.Color:=clBlack; - SaveFontColor:=Font.Color; - Font.Color:=Self.Color; - Windows.DrawFocusRect(Handle,ContentRect); - Font.Color:=SaveFontColor; - end; - - { Disabled node color overrides all other variants } - if vsDisabled in Node.States then Font.Color:=clBtnShadow; - - if Column+1 in [0,1] then - begin - { Draw the Incidence-Bar } - Pen.Color:=clBlack; - Brush.Style:=bsSolid; - { Mix a color for an incidence-value } - Brush.Color:= RGB(4 * N.Incidence, 128, 255 - 4 * N.Incidence); - Rectangle(ContentRect.Left+2, - ContentRect.Top+2, - ContentRect.Left+2+N.Incidence, - ContentRect.Bottom-2); - end; - - { Paint corresponding text } - Brush.Color:=Color; - SetBkMode(Handle,TRANSPARENT); - - TxtRect.Left:= ContentRect.Left; - TxtRect.Top:= ContentRect.Top; - TxtRect.Right:= ContentRect.Right; - TxtRect.Bottom:=ContentRect.Bottom; - if Column+1 in [0,1] - then TxtRect.Left:=TxtRect.Left+6+N.Incidence; - Flags:=DT_LEFT or DT_SINGLELINE or DT_VCENTER; - DrawText(Handle,PChar(NodeText),Length(NodeText),TxtRect,Flags); - end; { of with Canvas } - finally - RestoreDC; - end; -end; - -procedure TMVCTreeView.DoFreeNode(aNode:PVirtualNode); -{ A virtual node is being freed by the tree. Make sure the associated Node - loses its pointer to the node. } -var N:TMVCNode; -begin - N:=MVCNode[aNode]; - if Assigned(N) then - begin - N.VirtualNode:=NIL; - SetMVCNode(aNode,NIL); - end; - inherited DoFreeNode(aNode); -end; - -procedure TMVCTreeView.DoInitChildren(Node:PVirtualNode;var ChildCount:Cardinal); -begin - inherited DoInitChildren(Node,ChildCount); - ChildCount:=MVCNode[Node].ChildCount; -end; - -procedure TMVCTreeView.DoInitNode(aParent,aNode:PVirtualNode; - var aInitStates:TVirtualNodeInitStates); -{ The tree has just allocated a new virtual node. Link it to the TMVCNode - it is to represent. } -var P,I:TMVCNode; -begin - inherited DoInitNode(aParent,aNode,aInitStates); - with aNode^ do - begin - { Wich MVCNode corresponds to the virtual node being initialized? - Find the Parent-MVCNode via the Parent-VirtualNode } - if (aParent=RootNode) or (aParent=NIL) - then P:=FTree.Root - else P:=MVCNode[aParent]; - { MVCNode we are looking for is child number aIndex. } - I:=P.Child[Index]; - - { Now set all the data the Treeview needs plus our link to the node } - SetMVCNode(aNode,I); - I.VirtualNode:=aNode; - - if I.ChildCount>0 - then Include(aInitStates,ivsHasChildren) - else Exclude(aInitStates,ivsHasChildren); - CheckState:=I.CheckState; - end; -end; - -function TMVCTreeView.DoGetImageIndex(Node: PVirtualNode; Kind: TVTImageKind; Column: TColumnIndex; - var Ghosted: Boolean; var Index: Integer): TCustomImageList; -{ The tree requests the image-index for a Node and column. } -var N:TMVCNode; -begin - Result:= nil; - case Column of - -1,0:begin - { We only want Icons in the first column. Ask the node which - one it wants. } - N:=MVCNode[Node]; - if N=NIL { No node assigned, this should not happen. } - then Index:=-1 - else Index:=N.GetImageIndex; - end; - else Index:=-1; - end; -end; - -procedure TMVCTreeView.DoChecked(aNode:PVirtualNode); -{ In the tree a node has been checked, unchecked or whatever change to - the CheckState happens. Propagate that to the TMVCNode. } -var N:TMVCNode; -begin - if Assigned(FTree) then - begin - N:=MVCNode[aNode]; - if Assigned(N) then N.CheckState:=aNode^.CheckState; - end; - inherited DoChecked(aNode); -end; - -function TMVCTreeView.InternalData(Node: PVirtualNode): Pointer; - -begin - if (Node = RootNode) or (Node = nil) then - Result := nil - else - Result := PChar(Node) + FInternalDataOffset; -end; - -function TMVCTreeView.InternalDataSize: Cardinal; - -begin - // The size of the internal data this tree class needs. - Result := SizeOf(TMyNodeData); -end; - -constructor TMVCEditLink.Create; -begin - inherited; - FEdit := TMVCEdit.Create(Self); - with FEdit do - begin - Visible := False; - Ctl3D := False; - BorderStyle := bsSingle; - AutoSize := False; - end; -end; - -destructor TMVCEditLink.Destroy; -begin - FEdit.Free; - inherited; -end; - -function TMVCEditLink.BeginEdit: Boolean; -begin - Logger.Send(lcEditLink,'FEdit.Handle',FEdit.Handle); - Result := True; - FEdit.Show; - FEdit.SetFocus; -end; - -function TMVCEditLink.CancelEdit: Boolean; -begin - Result := True; - // to show the kill focus handler that we don't need a second notification for the tree - FTree:=nil; - FEdit.Hide; -end; - -function TMVCEditLink.EndEdit: Boolean; -var LastTree:TMVCTreeView; - MVCNode:TMVCNode; -begin - Result := True; - try - if Assigned(FTree) then - begin - if FEdit.Modified then - begin - MVCNode:=FTree.MVCNode[FNode]; - // keep tree reference because the application might want to change the focuse while - // processing the NewText event - LastTree:=FTree; - FTree:=nil; - - LastTree.SetNodeText(MVCNode,FColumn,FEdit.Caption); - end; - FTree:=nil; - end; - finally - FEdit.Hide; - end; -end; - -function TMVCEditLink.GetBounds: TRect; -begin - Result:=FEdit.BoundsRect; -end; - -function TMVCEditLink.PrepareEdit(Tree:TBaseVirtualTree;Node:PVirtualNode;Column:TColumnIndex): Boolean; -// retrieves the true text bounds from the owner tree -var R:TRect; - MVCNode:TMVCNode; -begin - Result := True; - FTree:=Tree as TMVCTreeView; - - FNode:=Node; - FColumn:=Column; - - MVCNode:=FTree.MVCNode[Node]; - - FEdit.Caption:=FTree.GetNodeText(MVCNode,Column); - FEdit.Parent:=Tree; - R:=FTree.GetDisplayRect(Node,Column,True); - - { In the primary column there is the "Incidence-Bar". Adjust the left - side of the rect to exclude it } - if Column+1 in [0,1] then R.Left:=R.Left+MVCNode.Incidence; - - with R do - begin - // set the edit's bounds but make sure there's a minimum width and the right border does not - // extend beyond the parent's right border - if Right-Left<50 then Right:=Left+50; - if Right>FTree.Width then Right:=FTree.Width; - FEdit.SetBounds(Left,Top,Right-Left,Bottom-Top); - FEdit.Font:=FTree.Font; - end; -end; - -procedure TMVCEditLink.SetBounds(R: TRect); -begin - // ignore this one as we get here the entire node rect but want the minimal text bounds -end; - -constructor TMVCEdit.Create(Link:TMVCEditLink); -begin - inherited Create(nil); - ShowHint:=False; - ParentShowHint:=False; - FLink:=Link; -end; - -procedure TMVCEdit.WMChar(var Message: TWMChar); -// handle character keys -begin - Logger.EnterMethod(lcEditLink,'WMChar'); - // avoid beep - if Message.CharCode <> VK_ESCAPE then - begin - inherited; - if Message.CharCode > $20 then AutoAdjustSize; - end; - Logger.ExitMethod(lcEditLink,'WMChar'); -end; - -procedure TMVCEdit.WMKeyDown(var Message: TWMKeyDown); -// handles some control keys (either redirection to tree, edit window size or clipboard handling) -begin - Logger.EnterMethod(lcEditLink,'TMVCEdit.WMKeyDown'); - case Message.CharCode of - // pretend these keycodes were send to the tree - VK_ESCAPE, - VK_UP, - VK_DOWN: - FLink.FTree.WndProc(TMessage(Message)); - VK_RETURN: - FLink.FTree.DoEndEdit; - // standard clipboard actions, - // Caution: to make these work you must not use default TAction classes like TEditPaste etc. in the application! - Ord('C'): - if (Message.KeyData and MK_CONTROL) <> 0 then CopyToClipboard; - Ord('X'): - if (Message.KeyData and MK_CONTROL) <> 0 then - begin - CutToClipboard; - AutoAdjustSize; - end; - Ord('V'): - if (Message.KeyData and MK_CONTROL) <> 0 then - begin - PasteFromClipboard; - AutoAdjustSize; - end; - else - inherited; - // second level for keys to be passed to its target - case Message.CharCode of - VK_BACK, - VK_DELETE: - AutoAdjustSize; - end; - end; - Logger.ExitMethod(lcEditLink,'TMVCEdit.WMKeyDown'); -end; - -procedure TMVCEdit.WMKillFocus(var Msg: TWMKillFocus); -begin - Logger.EnterMethod(lcEditLink,'TMVCEdit.WMKillFocus'); - inherited; - // FLink.FTree is set to nil if the link doesn't need to notify the tree (e.g. hiding the edit causes - // a kill focus message) - if Assigned(FLink.FTree) then FLink.FTree.DoCancelEdit; - Logger.ExitMethod(lcEditLink,'TMVCEdit.WMKillFocus'); -end; - -procedure TMVCEdit.AutoAdjustSize; -var - DC: HDC; - Size: TSize; - EditRect, - TreeRect: TRect; -begin - DC := GetDc(Handle); - GetTextExtentPoint32(DC, PChar(Text), Length(Text), Size); - // determine minimum and maximum sizes - if Size.cx < 50 then Size.cx := 50; - EditRect := ClientRect; - MapWindowPoints(Handle, HWND_DESKTOP, EditRect, 2); - TreeRect := FLink.FTree.ClientRect; - MapWindowPoints(FLink.FTree.Handle, HWND_DESKTOP, TreeRect, 2); - if (EditRect.Left + Size.cx) > TreeRect.Right then Size.cx := TreeRect.Right - EditRect.Left; - SetWindowPos(Handle, 0, 0, 0, Size.cx, Height, SWP_NOMOVE or SWP_NOOWNERZORDER or SWP_NOZORDER); - ReleaseDC(Handle, DC); -end; - -procedure TMVCEdit.CreateParams(var Params:TCreateParams); -begin - Ctl3D := False; - inherited; -end; - -procedure TMVCEditLink.ProcessMessage(var Message: TMessage); -begin - // nothing to do -end; - -constructor TMVCTreeView.Create(AOwner: TComponent); -begin - inherited; - FInternalDataOffset := AllocateInternalDataArea(SizeOf(Cardinal)); -end; - -function TMVCTreeView.GetOptions: TVirtualTreeOptions; - -begin - Result := inherited TreeOptions as TVirtualTreeOptions; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure TMVCTreeView.SetOptions(const Value: TVirtualTreeOptions); - -begin - TreeOptions.Assign(Value); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function TMVCTreeView.GetOptionsClass: TTreeOptionsClass; - -begin - Result := TVirtualTreeOptions; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -end. diff --git a/components/virtualtreeview/demos/objects/mvcdemo.lpi b/components/virtualtreeview/demos/objects/mvcdemo.lpi deleted file mode 100644 index 3eac47e8b..000000000 --- a/components/virtualtreeview/demos/objects/mvcdemo.lpi +++ /dev/null @@ -1,76 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff --git a/components/virtualtreeview/demos/objects/mvcdemo.lpr b/components/virtualtreeview/demos/objects/mvcdemo.lpr deleted file mode 100644 index 5a16cbf0d..000000000 --- a/components/virtualtreeview/demos/objects/mvcdemo.lpr +++ /dev/null @@ -1,18 +0,0 @@ -program mvcdemo; - -{$mode objfpc}{$H+} - -uses - {$IFDEF UNIX}{$IFDEF UseCThreads} - cthreads, - {$ENDIF}{$ENDIF} - Interfaces, // this includes the LCL widgetset - Forms - { add your units here }, MVCDemoMain; - -begin - Application.Initialize; - Application.CreateForm(TfmMVCDemo, fmMVCDemo); - Application.Run; -end. - diff --git a/components/virtualtreeview/lclconstants.inc b/components/virtualtreeview/lclconstants.inc deleted file mode 100644 index 45123c424..000000000 --- a/components/virtualtreeview/lclconstants.inc +++ /dev/null @@ -1,161 +0,0 @@ -// Message constants that are not defined in LCL - - WM_APP = $8000; - -// ExtTextOut Options - - ETO_RTLREADING = 128; - -//DrawText options - - DT_RTLREADING = 131072; - -// Clipboard constants - - CF_BITMAP = 2; - CF_DIB = 8; - CF_PALETTE = 9; - CF_ENHMETAFILE = 14; - CF_METAFILEPICT = 3; - CF_OEMTEXT = 7; - CF_TEXT = 1; - CF_UNICODETEXT = 13; - CF_DIF = 5; - CF_DSPBITMAP = 130; - CF_DSPENHMETAFILE = 142; - CF_DSPMETAFILEPICT = 131; - CF_DSPTEXT = 129; - CF_GDIOBJFIRST = 768; - CF_GDIOBJLAST = 1023; - CF_HDROP = 15; - CF_LOCALE = 16; - CF_OWNERDISPLAY = 128; - CF_PENDATA = 10; - CF_PRIVATEFIRST = 512; - CF_PRIVATELAST = 767; - CF_RIFF = 11; - CF_SYLK = 4; - CF_WAVE = 12; - CF_TIFF = 6; - CF_MAX = 17; - -// Win32 colors - CLR_NONE = $ffffffff; - CLR_DEFAULT = $ff000000; - -//DrawFrameControl constants - DFCS_HOT = $1000; - -//Thread support - //This values is for win32, how about others?? - INFINITE = $FFFFFFFF; - -//OLE Support - E_OUTOFMEMORY = HRESULT($8007000E); - E_INVALIDARG = HRESULT($80070057); - E_NOINTERFACE = HRESULT($80004002); - E_POINTER = HRESULT($80004003); - E_HANDLE = HRESULT($80070006); - E_ABORT = HRESULT($80004004); - E_FAIL = HRESULT($80004005); - E_ACCESSDENIED = HRESULT($80070005); - - DV_E_TYMED = HRESULT($80040069); - DV_E_CLIPFORMAT = HRESULT($8004006A); - DV_E_LINDEX = HRESULT($80040068); - DV_E_DVASPECT = HRESULT($8004006B); - - OLE_E_ADVISENOTSUPPORTED = HRESULT($80040003); - OLE_S_USEREG = HRESULT($00040000); - - DATA_S_SAMEFORMATETC = HRESULT($00040130); - - DRAGDROP_S_DROP = HRESULT($00040100); - DRAGDROP_S_CANCEL = HRESULT($00040101); - DRAGDROP_S_USEDEFAULTCURSORS = HRESULT($00040102); - - NOERROR = 0; - - SPI_GETDRAGFULLWINDOWS = 38; - -// windows management - SWP_HIDEWINDOW = 128; - SWP_SHOWWINDOW = 64; - -//Imagelists - ILD_NORMAL = 0; - -// Set WindowPos - SWP_FRAMECHANGED = 32; - SWP_NOOWNERZORDER = 512; - SWP_NOSENDCHANGING = 1024; - - { RedrawWindow } - RDW_ERASE = 4; - RDW_FRAME = 1024; - RDW_INTERNALPAINT = 2; - RDW_INVALIDATE = 1; - RDW_NOERASE = 32; - RDW_NOFRAME = 2048; - RDW_NOINTERNALPAINT = 16; - RDW_VALIDATE = 8; - RDW_ERASENOW = 512; - RDW_UPDATENOW = 256; - RDW_ALLCHILDREN = 128; - RDW_NOCHILDREN = 64; - -//SetRedraw - WM_SETREDRAW = 11; - -//Dummy - CM_PARENTFONTCHANGED = 1999; - -//Wheel - WHEEL_DELTA = 120; - WHEEL_PAGESCROLL = High(DWord); - SPI_GETWHEELSCROLLLINES = 104; - -//MultiByte - MB_USEGLYPHCHARS = 4; - LOCALE_IDEFAULTANSICODEPAGE = 4100; - -//Image list - ILD_TRANSPARENT = $00000001; - ILD_MASK = $00000010; - ILD_IMAGE = $00000020; - - ILD_ROP = $00000040; - - ILD_BLEND25 = $00000002; - ILD_BLEND50 = $00000004; - ILD_OVERLAYMASK = $00000F00; - - { GetDCEx } - DCX_WINDOW = $1; - DCX_CACHE = $2; - DCX_PARENTCLIP = $20; - DCX_CLIPSIBLINGS = $10; - DCX_CLIPCHILDREN = $8; - DCX_NORESETATTRS = $4; - DCX_LOCKWINDOWUPDATE = $400; - DCX_EXCLUDERGN = $40; - DCX_INTERSECTRGN = $80; - DCX_VALIDATE = $200000; - - SCantWriteResourceStreamError = 'CantWriteResourceStreamError'; - - //command - EN_UPDATE = 1024; - - ES_AUTOHSCROLL = $80; - ES_AUTOVSCROLL = $40; - ES_CENTER = $1; - ES_LEFT = 0; - ES_LOWERCASE = $10; - ES_MULTILINE = $4; - ES_NOHIDESEL = $100; - - - EM_SETRECTNP = 180; - - DT_END_ELLIPSIS = 32768; diff --git a/components/virtualtreeview/lclfunctions.inc b/components/virtualtreeview/lclfunctions.inc deleted file mode 100644 index 523f844b4..000000000 --- a/components/virtualtreeview/lclfunctions.inc +++ /dev/null @@ -1,246 +0,0 @@ -//Used in DrawTextW -{ -function GetTextAlign(DC: HDC): UINT; -begin - Logger.AddCheckPoint(lcDummyFunctions,'GetTextAlign'); - Result:=TA_TOP or TA_LEFT; -end; -} -//Used in DrawTextW, ShortenString, TVirtualTreeColumn.ComputeHeaderLayout, TVirtualTreeColumns.DrawButtonText, -// TVTEdit.AutoAdjustSize, TCustomVirtualStringTree.PaintNormalText, TCustomVirtualStringTree.WMSetFont -// TCustomVirtualStringTree.DoTextMeasuring -{ -function GetTextExtentPoint32W(DC: HDC; Str: PWideChar; Count: Integer; var Size: TSize): Boolean; -var - TempStr: String; -begin - Logger.AddCheckPoint(lcDummyFunctions,'GetTextExtentPoint32W'); - TempStr:=WideCharToString(Str); - Result:=GetTextExtentPoint(DC, PChar(TempStr), Length(TempStr), Size); -end; -} -//Used in DrawTextW -{ -function ExtTextOutW(DC: HDC; X, Y: Integer; Options: LongInt; Rect: PRect; - Str: PWideChar; Count: LongInt; Dx: PInteger): Boolean; -var - TempStr: String; -begin - Logger.AddCheckPoint(lcDummyFunctions,'ExtTextOutW'); - TempStr:=WideCharToString(Str); - Result:= ExtTextOut(DC, X, Y, Options, Rect, PChar(TempStr), Length(TempStr), Dx); -end; -} - -//Used in TVirtualTreeHintWindow.CalcHintRect, TVirtualTreeColumn.ComputeHeaderLayout -// TBaseVirtualTree.CollectSelectedNodesRTL, TBaseVirtualTree.DetermineHitPositionRTL -// TBaseVirtualTree.UpdateEditBounds, TBaseVirtualTree.GetDisplayRect, PaintTree, -// TStringEditLink.PrepareEdit, TCustomVirtualStringTree.ComputeNodeHeight etc - -procedure ChangeBiDiModeAlignment(var Alignment: TAlignment); -begin - case Alignment of - taLeftJustify: Alignment := taRightJustify; - taRightJustify: Alignment := taLeftJustify; - end; -end; - -function INDEXTOOVERLAYMASK(i : longint) : longint; -{ return type might be wrong } -begin - INDEXTOOVERLAYMASK:=i shl 8; -end; - - -function MAKEROP4(fore,back : longint) : DWORD; -begin - MAKEROP4:=DWORD((DWORD(back shl 8) and $FF000000) or DWORD(fore)); -end; - -function Failed(Status : HRESULT) : BOOL; -begin - Failed:=Status and HRESULT($80000000)<>0; -end; - -function MapWindowPoints(hWndFrom, hWndTo: HWND; lpPoints: PPoint; cPoints: UINT): Integer; -var - I:integer; - FromRect,ToRect: TRect; -begin - Logger.AddCheckPoint(lcDummyFunctions,'MapWiindowsPoints'); - //todo: implement result - GetWindowRect(hWndFrom,FromRect); - GetWindowRect(hWndTo,ToRect); - for i:=0 to cPoints - 1 do - begin - (lpPoints+i)^.x:=(FromRect.Left - ToRect.Left) + (lpPoints+i)^.x; - (lpPoints+i)^.y:=(FromRect.Top - ToRect.Top) + (lpPoints+i)^.y; - end; -end; - - -function InvalidateRect(aHandle : HWND; ARect : pRect; bErase : Boolean) : Boolean; -begin - Logger.EnterMethod(lcPaint,'InvalidateRect'); - Logger.Send(lcPaint,'Rect',ARect^); - Logger.SendCallStack(lcPaint,'CallStack'); - Result:=Windows.InvalidateRect(aHandle,ARect,bErase); - Logger.ExitMethod(lcPaint,'InvalidateRect'); -end; - -{$ifndef NeedWindows} - -//Dummy function. Used in many places -function ImageList_DrawEx(himl:THandle; i:longint; hdcDst:HDC; x:longint; - y:longint;dx:longint; dy:longint; rgbBk:COLORREF; rgbFg:COLORREF; fStyle:UINT):Boolean; -begin - Logger.AddCheckPoint(lcDummyFunctions,'ImageList_DrawEx'); -end; - -//Used in TVirtualTreeColumns.AnimatedResize -function GetWindowDC(hWnd:HWND):HDC; -begin - Logger.AddCheckPoint(lcDummyFunctions,'GetWindowDC'); -end; - -//Used in TVTDragImage.DragTo, TVirtualTreeColumns.AnimatedResize, TBaseVirtualTree.ToggleCallback, -//TBaseVirtualTree.TileBackground - -function ScrollDC(hDC:HDC; dx:longint; dy:longint; var lprcScroll:TRECT; - var lprcClip:TRECT;hrgnUpdate:HRGN; lprcUpdate:PRECT):Boolean; -begin - Logger.AddCheckPoint(lcDummyFunctions,'ScrollDC'); -end; - - -// TCustomVirtualTreeOptions.SetPaintOptions, TVTHeader.Invalidate, TVTColors.SetColor -//CMEnabledChanged, TBaseVirtualTree.WMEnable, TBaseVirtualTree.WMVScroll, -// TBaseVirtualTree.UpdateWindowAndDragImage, TBaseVirtualTree.RepaintNode -function RedrawWindow(hWnd:HWND; lprcUpdate:PRECT; hrgnUpdate:HRGN; - flags:LongWord):Boolean; overload; -begin - Logger.AddCheckPoint(lcDummyFunctions,'RedrawWindow'); -end; - -function RedrawWindow(hWnd:HWND; var lprcUpdate:TRECT; hrgnUpdate:HRGN; - flags:UINT):Boolean; overload; -begin -end; -//Used in LimitPaintingToArea -function LPtoDP(_para1:HDC; _para2:PPOINT; _para3:longint):Boolean; -begin - Logger.AddCheckPoint(lcDummyFunctions,'LPtoDP'); -end; - -//Used to the brush of dottedline -function CreatePatternBrush(_para1:HBITMAP):HBRUSH; -var - ALog: TLogBrush; -begin - Logger.AddCheckPoint(lcDummyFunctions,'CreatePatternBrush'); - //lcl_todo - with ALog do - begin - lbStyle:=0; - lbColor:=0; - lbHatch:=0; - end; - Result:=CreateBrushIndirect(ALog); -end; - -function GetBkColor(_para1:HDC):COLORREF; -begin - Logger.AddCheckPoint(lcDummyFunctions,'GetBkColor'); -end; - - -function ImageList_DragShowNolock(fShow:Boolean): Boolean; -begin - Logger.AddCheckPoint(lcDummyFunctions,'ImageList_DragShowNoLock'); -end; - -function GetKeyboardState(lpKeyState:PBYTE):Boolean; -begin - Logger.AddCheckPoint(lcDummyFunctions,'GetKeyboardState'); -end; - -function ToAscii(uVirtKey:UINT; uScanCode:UINT; lpKeyState:PBYTE; - lpChar: PChar; uFlags:UINT):longint; -begin - Logger.AddCheckPoint(lcDummyFunctions,'ToAscii'); -end; - -function SystemParametersInfo(uiAction:UINT; uiParam:UINT; - pvParam:Pointer; fWinIni:UINT):Boolean; -begin - Logger.AddCheckPoint(lcDummyFunctions,'SystemParameterInfo'); -end; - -function SetTimer(hWnd:HWND; nIDEvent:UINT; uElapse:UINT; lpTimerFunc:Pointer):UINT; -begin - Logger.AddCheckPoint(lcDummyFunctions,'SetTimer'); -end; - -function SubtractRect(lprcDst:TRECT; lprcSrc1:TRECT; lprcSrc2:TRECT):Boolean; -begin - Logger.AddCheckPoint(lcDummyFunctions,'SubtractRect'); -end; - -function DeferWindowPos(hWinPosInfo:THandle; hWnd:THandle; hWndInsertAfter:THandle; - x:longint; y:longint;cx:longint; cy:longint; uFlags:UINT):THandle; -begin - Logger.AddCheckPoint(lcDummyFunctions,'DeferWindowPos'); -end; - -function BeginDeferWindowPos(nNumWindows:longint):THandle; -begin - Logger.AddCheckPoint(lcDummyFunctions,'BeginDeferWindowPos'); -end; - -function EndDeferWindowPos(hWinPosInfo:THandle):Boolean; -begin - Logger.AddCheckPoint(lcDummyFunctions,'EndDeferWindowpos'); -end; - -function GetLocaleInfo(Locale:DWord; LCType:DWord; lpLCData:PChar; cchData:longint):longint; -begin - Logger.AddCheckPoint(lcDummyFunctions,'GetLocaleInfo'); -end; - -function GetACP:UINT; -begin - Logger.AddCheckPoint(lcDummyFunctions,'GetACP'); -end; - -function MultiByteToWideChar(CodePage:UINT; dwFlags:DWORD; lpMultiByteStr:PChar; - cchMultiByte:longint; lpWideCharStr:PWideChar; cchWideChar:longint):longint; -begin - Logger.AddCheckPoint(lcDummyFunctions,'MultiByteToWideChar'); -end; - -function GetKeyboardLayout(dwLayout:DWORD):THandle; -begin - Logger.AddCheckPoint(lcDummyFunctions,'GetKeyboardLayout'); -end; - -function DefWindowProc(hWnd:HWND; Msg:UINT; wParam:WPARAM; lParam:LPARAM):LRESULT; -begin - Logger.AddCheckPoint(lcDummyFunctions,'DefWindowProc'); -end; - -function GetDCEx(hWnd:HWND; hrgnClip:HRGN; flags:DWORD):HDC; -begin - Logger.AddCheckPoint(lcDummyFunctions,'GetDCEx'); -end; - -function OffsetRgn(_para1:HRGN; _para2:longint; _para3:longint):longint; -begin - Logger.AddCheckPoint(lcDummyFunctions,'OffsetRegion'); -end; - -function SetBrushOrgEx(_para1:HDC; _para2:longint; _para3:longint; _para4:PPOINT):Boolean; -begin - Logger.AddCheckPoint(lcDummyFunctions,'SetBrushOrgEx'); -end; - -{$endif} diff --git a/components/virtualtreeview/lcltypes.inc b/components/virtualtreeview/lcltypes.inc deleted file mode 100644 index b8e2bb277..000000000 --- a/components/virtualtreeview/lcltypes.inc +++ /dev/null @@ -1,6 +0,0 @@ - - - - //TBiDiMode = (bdLeftToRight, bdRightToLeft, bdRightToLeftNoAlign, bdRightToLeftReadingOnly); - - diff --git a/components/virtualtreeview/port.log b/components/virtualtreeview/port.log deleted file mode 100644 index 870612ddd..000000000 --- a/components/virtualtreeview/port.log +++ /dev/null @@ -1,187 +0,0 @@ -Port started in 26/01/07 -1) Remove Delphi/Windows dependencies -* Determine what windows functions are used. Store in windows_functions.txt -* Undefine ThemeSupport in VTConfig.inc -* Comment OleAcc unit from uses -* Convert windows messages to LCL correspondent. Store in windows_messages.txt -* toShowButtons duplicated in DefaultPaintOptions (Delphi compiles this!!) -* unclosed comment in OLE Drag definitions -* VTV uses OLE to drag and drop and clipboard. Necessary to see how LCL handle this. For now enclose all - clipboard and drag and drop ole under ifdefs -* added {$mode delphi}{$H+} -* Change header of TEnumFormatETC, TVTDragManager, TVTDataObject to match fpc -* Add Types unit (TSize) -* THintWindow.IsHintMsg is not implemented in LCL. Comment the code -* Commented Consts and AxCtrls units in implementation -* Isolated NC functions. They are used to paint the header -* Isolated GetControlsAlignment. (Is not used in the LCL) -* Commented TStringEditLink HideSelection and OEMConvert published formats -* Added lcltypes.inc -* Added TBidiMode and BidiMode property set default to LTR -* Commented Bevel* properties publishing -* Commented ParentBidiMode property -* Commented implementation of RaiseLastOSError -* Added missing clipboard constants -* Added LCLIntf unit -* Replaced GetClipboardFormatName by ClipboardFormatToMimeType in RegisterVTClipboardFormat -* Replaced RegisterClipboardFormat by ClipboardRegisterFormat -* Added win32 color constants -* Removed ISWin2k and XP since was not used. Assume IsWinNt true -* Removed Global HintFont var used to < Delphi4. Use Screen.HintFont. -* Commented the global imagelists code. Will be implemented later -* Added dummy GetTextAlign function -* Added simple ExtTextOutW and GetTextExtentPoint32W functions. Will be revisited later -* Commented code that was using GetCurrentObject -* Commented code for a bug in the Delphi package code -* Changed way to get NeedToUnitialize. Removed succeeded -* Replaced LoadCursor by LoadCursorFromLazarusResource. -* Added virtualtrees.lrs -* Changed WorkEvent from THandle to TEvent -* Added INFINITE constant -* Removed RaiseLastOSError -* Changed typecast of EnterStates in TWorkerThread.ChangeTreeStates -* Changed parameter of ReleaseStgMedium to a Pointer -* Replaced unkForRelease for PunkForRelease in TStgMedium records, similar with stm and stg -* Isolated DragFunctions dependent of windows -* replaced lstrLenW by fpc way -* Replace Windows.DrawTextW by customized -* Added TVirtualTreeHintWindow.BidiMode property -* Replace UpdateBounds by SetBounds in Hint show routine -* In TCustomVirtualTreeOptions.SetMiscOptions called RecreateWnd -* Commented ValidateRect functions -* Implemented procedure ChangeBiDiModeAlignment -* Isolated code from TVTDragImage.MakeAlphaChannel -* In LoadFromStream changed typecast to longword -* Added dummy ImageList_DrawEx implementation -* Replaced ZeroMemory by FillChar -* Commented BevelKind in PaintHeadder -* Implemented TBaseVirtualTree.UseRightToLeftAlignment dummy function -* Isolated Header messages handling -* Added missing SetWindowPos constants -* Implemented MapWindowPoints -* Added dummy RedrawWindow function -* Commented call to DestroyWindowHandle in Destroy. Probably will not be necessary since the header will be - in the client area -* Used Application.ProcessMessages in InterruptValidation instead of direct call -* Added dummy LPtoDP -* Replaced LoadBitmap by LoadFromLazarusResource -* Added dummy CreatePatternBrush -* Added Dummy GetBkColor -* Replaced Reader.ReadStr by Reader.ReadString -* Added WM_SETREDRAW constant -* Added MAKEROP4 -* Added dummy ImageList_DragShowNolock -* Replaced GetUpdateRect in WMPaint -* Added dummy ToAscii and GetKeyboardState -* Added WHEEL_ constants -* Added Dummy SystemParametersInfo -* Added Dummy SetTimer, isolated timer functions -* Isolated CreateParams function -* Added Failed function -* Added dummy SubtractRect function -* Replaced Canvas.TextFlags by TextStyle -* Added LResources unit -* Used the PackArray Implmentation from original port -* The TCanvas of VCL does not has width and height as LCL does. This cause conflict with "with" operator -* Implemented TOLEStream -* Fixed bug in LCL.GetScrollPos -* Fixed Draw problems due to TCanvas.Color -* Fixed Align problems of TVirtualNode (Hint from original port) -* Fixed MouseWheel -* Fixed drawing problem when using ScrollBar or MouseWheel -* Implemented Support for check images - -#Major Tasks# -< > General Painting - [ ] The NodeBitmap width/Height is not reseted when erasing the background -< > Define the UNICODE support schema. Probably change from widestring to ansistring and let LCL do the rest - [ ] Use GetTextExtentPoint instead of GetTextExtentPoint32 since the later is a wrapper to the former in LCL - [ ] For now all rendering will be done with DrawTextW wrapper > Windows.DrawTextW -< > Find a way to mantain OLE drag and Drop in windows - [ ] Also maintain OLE ClipBoard?? Necessary?? -< > Replace TWMTimer since is only called in win32. Or implement in GTK Intf? -< > Implement Imagelist handling - [ ] See a properly way to setup the ImageLists (avoid current hack) -< > GetCurrentObject used for blending does not exists in LCL. Add it? - [ ] Gtk.GetObject does not return dmBits (is always nil) -> Is not viable to implement - GetObject under Gtk. See another way to do alpha blend (Disable in GTK??) -< > Implement the header - [ ] BevelEdges is used to paint the Header. See if is worth implementing it - [ ] Process the header messages or do another way - [ ] See if DestroyWindowHandle is necessary in Destroy -< > Bidi Support - [ ]Properly Implement TBaseVirtualTree.UseRightToLeftAlignment -#Secondary Tasks# -< > (low) OleAcc: MSAA (Accessibility) -<*> WMContextMenu: replace by DoContextPopup??. Add to LCL?? - [*] Fix Double MouseRUp - [*] in line 2042 of callback simplify -<-> pceltFetched in TEnumFormatEtc.Next is declared as ULong in fpc but PLongInt in Delphi - [*] Already reported. No response -< > Implement THintWindow.IsHintMsg ? -< > Add TLMEnable ?? -< > Replace WMSetFont since LM_SETFONT is not used in LCL -<*> Replace RaiseLastOSError. Is used in only one place -> Removed -< > IsWinNT is currently set to True. See if will support win98 and how do it -< > See what todo with GetTextAlign. Implement in LCL?? -< > Thread support - [ ] Replace TVTCriticalSection by SyncObjs.TCriticalSection?? - [ ] See appropriate value for INFINITE constant in Linux/BSD etc -< > TWorkerThread.ChangeTreeStates uses SendMessage. See if it works both in win and linux -<-> In fpc TStgMedium records have PunkForRelease instead of unkForRelease, same for stm and stg - [*] Already reported. No response -< > Add a way to replace TBitmap.Scanline and all advanced graphics routines - [ ] Use TLazIntfImage? - [ ] Properly implement CreatePatternBrush or find a way to paint the lines -< > Implement GetBkColor in LCL -< > Begin/EndUpdate uses WM_SETREDRAW message to avoid painting. See a crossplatform way of doing it -<*> Translate MAKEROP4 from C to Pascal. Done copied from fpc -< > TCMMouseWheel type is not used in Lazarus. Remove -< > Revise CM* functions and messages -< > Implement SubtractRect -< > Implement WMSetFont -< > Implement PackArray using asm - [ ] Wait for fpc2.2 - [ ] Adapt for fpc - [ ] Create versions for not i386 - -#Checks# -< > See if getting the length of PWideChar by typecasting to WideString is correct -< > See if the Hint is being show in the correct place -< > See the effect of using RecreateWnd (in TCustomVirtualTreeOptions.SetMiscOptions) -<*> WM_NCPAINT: see the behavior under LCL - [*] Is not handled. TControl will never receive it -< > TVMGet* functions: probably it can be ignored, since is windows specific and not necessary at all -< > See if WM_COPY can be mapped to LM_COPYTOCLIP -< > See WM_ENABLE,WM_GETDLGCODE behavior under lcl/win32 -< > See function of WM_GETOBJECT and if is necessary to add to LCL -< > See the difference between TWMPaint and TLMPaint -< > TWMPrint and WM_PRINT. See if is necessary -< > In SetCursor uses TLMessage. Investigate -< > See if GetRGBColor is necessary. Probably not. If so remove color constants -< > Found no way to replace ValidateRect in Hint Window animation. See how to replace it -< > See if the typecasts to longword in TVirtualTreeColumn.LoadFromStream is correct -< > See te meaning of Bevel* properties. See what values it should be in LCL -<*> See if custom MapWindowPoints is returning correct values - [*] AFAIK yes -< > See if Application.ProcessMessages in InterruptValidation will work (WM_QUIT handling??) -<*> See if windows.GetUpdateRect is equal to PaintStruct in WM Paint - [*] Yes and no. The values of GetUpdateRect and rcPaint is equal in most times. So is safe to use it - But GetUpdateRect will always return an empty Rect when called inside LM_PAINT because there's a - prior BeginPaint call -< > In TWMKillfocus the code to nullify the active control is probably not necessary -< > See if DeleteObject is necessary in AdjustCursorPanning -< > See if WHEEL_ constants are valids under gtk -< > See if is necessary WM_SYSCOLORCHANGE -< > See if is necessary handle LM_SETCURSOR (not used in LCL) -< > See how replace CreateParams -< > See if Canvas Respect TextStyle properties and if is necessary to set the bk in PaintNormalText -< > IStream.SetSize expects ULARGE_INTEGER instead of LARGE_INTEGER -< > Remove TRect copy in FillRect -< > In paint tree avoid using TBitmap.Canvas since it does a check each time is called -< > Why there's a extra 1 in the NodeBitmap that clears the backGround -< > See code duplicate in TBitmap.SetWidthHeight -< > Document problem of TCanvas.Color -< > Document differences between WMMouseWheel -< > Document Differences between WMPaint -< > Document that ScrollWindow does not exists in gtk diff --git a/components/virtualtreeview/resources/VT_CHECK_DARK.bmp b/components/virtualtreeview/resources/VT_CHECK_DARK.bmp deleted file mode 100644 index fd1176ef0..000000000 Binary files a/components/virtualtreeview/resources/VT_CHECK_DARK.bmp and /dev/null differ diff --git a/components/virtualtreeview/resources/VT_CHECK_LIGHT.bmp b/components/virtualtreeview/resources/VT_CHECK_LIGHT.bmp deleted file mode 100644 index b30e00110..000000000 Binary files a/components/virtualtreeview/resources/VT_CHECK_LIGHT.bmp and /dev/null differ diff --git a/components/virtualtreeview/resources/VT_FLAT.bmp b/components/virtualtreeview/resources/VT_FLAT.bmp deleted file mode 100644 index 8a2d425af..000000000 Binary files a/components/virtualtreeview/resources/VT_FLAT.bmp and /dev/null differ diff --git a/components/virtualtreeview/resources/VT_HEADERSPLIT.cur b/components/virtualtreeview/resources/VT_HEADERSPLIT.cur deleted file mode 100644 index 8d78c7171..000000000 Binary files a/components/virtualtreeview/resources/VT_HEADERSPLIT.cur and /dev/null differ diff --git a/components/virtualtreeview/resources/VT_MOVEALL.cur b/components/virtualtreeview/resources/VT_MOVEALL.cur deleted file mode 100644 index 9bf5a5a01..000000000 Binary files a/components/virtualtreeview/resources/VT_MOVEALL.cur and /dev/null differ diff --git a/components/virtualtreeview/resources/VT_MOVEE.cur b/components/virtualtreeview/resources/VT_MOVEE.cur deleted file mode 100644 index 54de6d871..000000000 Binary files a/components/virtualtreeview/resources/VT_MOVEE.cur and /dev/null differ diff --git a/components/virtualtreeview/resources/VT_MOVEEW.cur b/components/virtualtreeview/resources/VT_MOVEEW.cur deleted file mode 100644 index 7d9fb2894..000000000 Binary files a/components/virtualtreeview/resources/VT_MOVEEW.cur and /dev/null differ diff --git a/components/virtualtreeview/resources/VT_MOVEN.cur b/components/virtualtreeview/resources/VT_MOVEN.cur deleted file mode 100644 index dc1acb487..000000000 Binary files a/components/virtualtreeview/resources/VT_MOVEN.cur and /dev/null differ diff --git a/components/virtualtreeview/resources/VT_MOVENE.cur b/components/virtualtreeview/resources/VT_MOVENE.cur deleted file mode 100644 index 337a91204..000000000 Binary files a/components/virtualtreeview/resources/VT_MOVENE.cur and /dev/null differ diff --git a/components/virtualtreeview/resources/VT_MOVENS.cur b/components/virtualtreeview/resources/VT_MOVENS.cur deleted file mode 100644 index 337a91204..000000000 Binary files a/components/virtualtreeview/resources/VT_MOVENS.cur and /dev/null differ diff --git a/components/virtualtreeview/resources/VT_MOVENW.cur b/components/virtualtreeview/resources/VT_MOVENW.cur deleted file mode 100644 index a95776684..000000000 Binary files a/components/virtualtreeview/resources/VT_MOVENW.cur and /dev/null differ diff --git a/components/virtualtreeview/resources/VT_MOVES.cur b/components/virtualtreeview/resources/VT_MOVES.cur deleted file mode 100644 index b319725ac..000000000 Binary files a/components/virtualtreeview/resources/VT_MOVES.cur and /dev/null differ diff --git a/components/virtualtreeview/resources/VT_MOVESE.cur b/components/virtualtreeview/resources/VT_MOVESE.cur deleted file mode 100644 index ce0a5ef7e..000000000 Binary files a/components/virtualtreeview/resources/VT_MOVESE.cur and /dev/null differ diff --git a/components/virtualtreeview/resources/VT_MOVESW.cur b/components/virtualtreeview/resources/VT_MOVESW.cur deleted file mode 100644 index b2e753766..000000000 Binary files a/components/virtualtreeview/resources/VT_MOVESW.cur and /dev/null differ diff --git a/components/virtualtreeview/resources/VT_MOVEW.cur b/components/virtualtreeview/resources/VT_MOVEW.cur deleted file mode 100644 index ceaa02a9b..000000000 Binary files a/components/virtualtreeview/resources/VT_MOVEW.cur and /dev/null differ diff --git a/components/virtualtreeview/resources/VT_TICK_DARK.bmp b/components/virtualtreeview/resources/VT_TICK_DARK.bmp deleted file mode 100644 index cf14fd21d..000000000 Binary files a/components/virtualtreeview/resources/VT_TICK_DARK.bmp and /dev/null differ diff --git a/components/virtualtreeview/resources/VT_TICK_LIGHT.bmp b/components/virtualtreeview/resources/VT_TICK_LIGHT.bmp deleted file mode 100644 index bed0bf8a7..000000000 Binary files a/components/virtualtreeview/resources/VT_TICK_LIGHT.bmp and /dev/null differ diff --git a/components/virtualtreeview/resources/VT_XPBUTTONMINUS.bmp b/components/virtualtreeview/resources/VT_XPBUTTONMINUS.bmp deleted file mode 100644 index 03323ae06..000000000 Binary files a/components/virtualtreeview/resources/VT_XPBUTTONMINUS.bmp and /dev/null differ diff --git a/components/virtualtreeview/resources/VT_XPBUTTONPLUS.bmp b/components/virtualtreeview/resources/VT_XPBUTTONPLUS.bmp deleted file mode 100644 index 474ebdca9..000000000 Binary files a/components/virtualtreeview/resources/VT_XPBUTTONPLUS.bmp and /dev/null differ diff --git a/components/virtualtreeview/resources/createres.bat b/components/virtualtreeview/resources/createres.bat deleted file mode 100644 index af2ed41d5..000000000 --- a/components/virtualtreeview/resources/createres.bat +++ /dev/null @@ -1 +0,0 @@ -lazres ..\virtualtrees.lrs VT_HEADERSPLIT.cur VT_MOVEALL.cur VT_MOVEE.cur VT_MOVEEW.cur VT_MOVEN.cur VT_MOVENE.cur VT_MOVENS.cur VT_MOVENW.cur VT_MOVES.cur VT_MOVESE.cur VT_MOVESW.cur VT_MOVEW.cur VT_XPBUTTONPLUS.bmp VT_XPBUTTONMINUS.bmp VT_CHECK_LIGHT.bmp VT_CHECK_DARK.bmp VT_FLAT.bmp VT_TICK_DARK.bmp VT_TICK_LIGHT.bmp VT_UTILITIES.bmp VT_XP.bmp \ No newline at end of file diff --git a/components/virtualtreeview/virtualtrees.lrs b/components/virtualtreeview/virtualtrees.lrs deleted file mode 100644 index a564dbc7e..000000000 --- a/components/virtualtreeview/virtualtrees.lrs +++ /dev/null @@ -1,1682 +0,0 @@ -LazarusResources.Add('VT_HEADERSPLIT','CUR',[ - #0#0#2#0#1#0' '#0#0#15#0#14#0'0'#1#0#0#22#0#0#0'('#0#0#0' '#0#0#0'@'#0#0#0#1 - +#0#1#0#0#0#0#0#0#1#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#255#255#255#0 - +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#7 - +#128#0#0#4#128#0#0#4#128#0#0#4#128#0#0#4#128#0#0'D'#136#0#0#164#148#0#1'<' - +#242#0#2#0#1#0#2#0#1#0#1'<'#242#0#0#164#148#0#0'D'#136#0#0#4#128#0#0#4#128#0 - +#0#4#128#0#0#4#128#0#0#7#128#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#255 - +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 - +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#248'' - +#255#255#248''#255#255#248''#255#255#248''#255#255#248''#255#255#184'w' - +#255#255#24'c'#255#254#0#1#255#252#0#0#255#252#0#0#255#254#0#1#255#255#24'c' - +#255#255#184'w'#255#255#248''#255#255#248''#255#255#248''#255#255#248'' - +#255#255#248''#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 - +#255#255#255#255#255#255 -]); -LazarusResources.Add('VT_MOVEALL','CUR',[ - #0#0#2#0#1#0' '#0#0#16#0#16#0'0'#1#0#0#22#0#0#0'('#0#0#0' '#0#0#0'@'#0#0#0#1 - +#0#1#0#0#0#0#0#0#1#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#255#255#255#0 - +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#1#128#0#0#2'@'#0#0#4' '#0#0#8#16#0#0#16#8 - +#0#0' '#4#0#0''#254#0#0#160#5#0#1' '#4#128#2'!'#132'@'#4'"D '#8'$$'#16#8'$$' - +#16#4'"D '#2'!'#132'@'#1' '#4#128#0#160#5#0#0''#254#0#0' '#4#0#0#16#8#0#0#8 - +#16#0#0#4' '#0#0#2'@'#0#0#1#128#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#255#255#255 - +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#254''#255#255#252 - +'?'#255#255#248#31#255#255#240#15#255#255#224#7#255#255#192#3#255#255#128#1 - +#255#255#31#248#255#254#31#248''#252#30'x?'#248#28'8'#31#240#24#24#15#240#24 - +#24#15#248#28'8'#31#252#30'x?'#254#31#248''#255#31#248#255#255#128#1#255#255 - +#192#3#255#255#224#7#255#255#240#15#255#255#248#31#255#255#252'?'#255#255#254 - +''#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 -]); -LazarusResources.Add('VT_MOVEE','CUR',[ - #0#0#2#0#1#0' '#0#0#16#0#16#0#232#2#0#0#22#0#0#0'('#0#0#0' '#0#0#0'@'#0#0#0#1 - +#0#4#0#0#0#0#0#128#2#0#0#0#0#0#0#0#0#0#0#16#0#0#0#0#0#0#0#0#0#0#0#0#0#128#0#0 - +#128#0#0#0#128#128#0#128#0#0#0#128#0#128#0#128#128#0#0#192#192#192#0#128#128 - +#128#0#0#0#255#0#0#255#0#0#0#255#255#0#255#0#0#0#255#0#255#0#255#255#0#0#255 - +#255#255#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 - +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 - +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 - +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 - +#0#0#0#0#0#0#0#15#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#15#240#0#0#0#0#0#0#0#0#0#0#0 - +#0#0#0#15#15#0#0#0#0#0#0#0#0#0#0#0#0#0#0#15#0#240#0#0#0#0#0#0#0#0#0#0#15#240 - +#0#15#0#15#0#0#0#0#0#0#0#0#0#0#240#15#0#15#0#0#240#0#0#0#0#0#0#0#0#15#0#0#240 - +#15#0#0#15#0#0#0#0#0#0#0#0#15#0#0#240#15#0#0#15#0#0#0#0#0#0#0#0#0#240#15#0#15 - +#0#0#240#0#0#0#0#0#0#0#0#0#15#240#0#15#0#15#0#0#0#0#0#0#0#0#0#0#0#0#0#15#0 - +#240#0#0#0#0#0#0#0#0#0#0#0#0#0#15#15#0#0#0#0#0#0#0#0#0#0#0#0#0#0#15#240#0#0#0 - +#0#0#0#0#0#0#0#0#0#0#0#15#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 - +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 - +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 - +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 - +#0#0#0#0#0#0#0#0#0#255#255#255#255#255#255#255#255#255#255#255#255#255#255 - +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 - +#255#255#255#255#255#251#255#255#255#249#255#255#255#248#255#255#255#248'' - +#255#254'x?'#255#252'8'#31#255#248#24#15#255#248#24#15#255#252'8'#31#255#254 - +'x?'#255#255#248''#255#255#248#255#255#255#249#255#255#255#251#255#255#255 - +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 - +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 -]); -LazarusResources.Add('VT_MOVEEW','CUR',[ - #0#0#2#0#1#0' '#0#0#16#0#16#0#232#2#0#0#22#0#0#0'('#0#0#0' '#0#0#0'@'#0#0#0#1 - +#0#4#0#0#0#0#0#128#2#0#0#0#0#0#0#0#0#0#0#16#0#0#0#0#0#0#0#0#0#0#0#0#0#128#0#0 - +#128#0#0#0#128#128#0#128#0#0#0#128#0#128#0#128#128#0#0#192#192#192#0#128#128 - +#128#0#0#0#255#0#0#255#0#0#0#255#255#0#255#0#0#0#255#0#255#0#255#255#0#0#255 - +#255#255#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 - +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 - +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 - +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 - +#0#0#240#0#0#0#0#15#0#0#0#0#0#0#0#0#0#15#240#0#0#0#0#15#240#0#0#0#0#0#0#0#0 - +#240#240#0#0#0#0#15#15#0#0#0#0#0#0#0#15#0#240#0#0#0#0#15#0#240#0#0#0#0#0#0 - +#240#0#240#0#15#240#0#15#0#15#0#0#0#0#0#15#0#0#240#0#240#15#0#15#0#0#240#0#0 - +#0#0#240#0#0#240#15#0#0#240#15#0#0#15#0#0#0#0#240#0#0#240#15#0#0#240#15#0#0 - +#15#0#0#0#0#15#0#0#240#0#240#15#0#15#0#0#240#0#0#0#0#0#240#0#240#0#15#240#0 - +#15#0#15#0#0#0#0#0#0#15#0#240#0#0#0#0#15#0#240#0#0#0#0#0#0#0#240#240#0#0#0#0 - +#15#15#0#0#0#0#0#0#0#0#15#240#0#0#0#0#15#240#0#0#0#0#0#0#0#0#0#240#0#0#0#0#15 - +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 - +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 - +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 - +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#255 - +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 - +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#223#251 - +#255#255#159#249#255#255#31#248#255#254#31#248''#252#30'x?'#248#28'8'#31#240 - +#24#24#15#240#24#24#15#248#28'8'#31#252#30'x?'#254#31#248''#255#31#248#255 - +#255#159#249#255#255#223#251#255#255#255#255#255#255#255#255#255#255#255#255 - +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 - +#255#255#255#255#255#255 -]); -LazarusResources.Add('VT_MOVEN','CUR',[ - #0#0#2#0#1#0' '#0#0#16#0#16#0#232#2#0#0#22#0#0#0'('#0#0#0' '#0#0#0'@'#0#0#0#1 - +#0#4#0#0#0#0#0#128#2#0#0#0#0#0#0#0#0#0#0#16#0#0#0#0#0#0#0#0#0#0#0#0#0#128#0#0 - +#128#0#0#0#128#128#0#128#0#0#0#128#0#128#0#128#128#0#0#192#192#192#0#128#128 - +#128#0#0#0#255#0#0#255#0#0#0#255#255#0#255#0#0#0#255#0#255#0#255#255#0#0#255 - +#255#255#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 - +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 - +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 - +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 - +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 - +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#15#240#0#0#0#0#0 - +#0#0#0#0#0#0#0#0#0#240#15#0#0#0#0#0#0#0#0#0#0#0#0#0#15#0#0#240#0#0#0#0#0#0#0 - +#0#0#0#0#0#15#0#0#240#0#0#0#0#0#0#0#0#0#0#0#0#0#240#15#0#0#0#0#0#0#0#0#0#0#0 - +#0#0#0#15#240#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#255#255 - +#255#255#255#255#255#255#0#0#0#0#0#0#0#0#15#0#0#0#0#0#0#240#0#0#0#0#0#0#0#0#0 - +#240#0#0#0#0#15#0#0#0#0#0#0#0#0#0#0#15#0#0#0#0#240#0#0#0#0#0#0#0#0#0#0#0#240 - +#0#0#15#0#0#0#0#0#0#0#0#0#0#0#0#15#0#0#240#0#0#0#0#0#0#0#0#0#0#0#0#0#240#15#0 - +#0#0#0#0#0#0#0#0#0#0#0#0#0#15#240#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 - +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 - +#0#0#0#0#0#0#0#0#0#0#0#255#255#255#255#255#255#255#255#255#255#255#255#255 - +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 - +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 - +#255#255#254''#255#255#252'?'#255#255#248#31#255#255#248#31#255#255#252'?' - +#255#255#254''#255#255#255#255#255#255#0#0#255#255#128#1#255#255#192#3#255 - +#255#224#7#255#255#240#15#255#255#248#31#255#255#252'?'#255#255#254''#255 - +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 -]); -LazarusResources.Add('VT_MOVENE','CUR',[ - #0#0#2#0#1#0' '#0#0#16#0#16#0#232#2#0#0#22#0#0#0'('#0#0#0' '#0#0#0'@'#0#0#0#1 - +#0#4#0#0#0#0#0#128#2#0#0#0#0#0#0#0#0#0#0#16#0#0#0#0#0#0#0#0#0#0#0#0#0#128#0#0 - +#128#0#0#0#128#128#0#128#0#0#0#128#0#128#0#128#128#0#0#192#192#192#0#128#128 - +#128#0#0#0#255#0#0#255#0#0#0#255#255#0#255#0#0#0#255#0#255#0#255#255#0#0#255 - +#255#255#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 - +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 - +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 - +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 - +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 - +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#15#240#0#0#0#0#0 - +#0#0#0#0#0#0#0#0#0#240#15#0#0#0#240#0#0#0#0#0#0#0#0#0#15#0#0#240#0#15#240#0#0 - +#0#0#0#0#0#0#0#15#0#0#240#0#240#240#0#0#0#0#0#0#0#0#0#0#240#15#0#15#0#240#0#0 - +#0#0#0#0#0#0#0#0#15#240#0#240#0#240#0#0#0#0#0#0#0#0#0#0#0#0#15#0#0#240#0#0#0 - +#0#0#0#0#0#0#0#0#0#240#0#0#240#0#0#0#0#0#0#0#0#0#0#0#15#0#0#0#240#0#0#0#0#0#0 - +#0#0#0#0#0#240#0#0#0#240#0#0#0#0#0#0#0#0#0#0#15#0#0#0#0#240#0#0#0#0#0#0#0#0#0 - +#0#255#255#255#255#255#240#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 - +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 - +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 - +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#255#255#255#255#255#255#255#255#255#255#255#255 - +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 - +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 - +#255#255#255#254''#255#255#252'?'#255#248#30''#255#248#28''#255#252'8' - +#255#254'p'#255#255#224''#255#255#192''#255#255#128''#255#255#0''#255 - +#254#0''#255#252#0''#255#255#255#255#255#255#255#255#255#255#255#255#255 - +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 -]); -LazarusResources.Add('VT_MOVENS','CUR',[ - #0#0#2#0#1#0' '#0#0#16#0#16#0#232#2#0#0#22#0#0#0'('#0#0#0' '#0#0#0'@'#0#0#0#1 - +#0#4#0#0#0#0#0#128#2#0#0#0#0#0#0#0#0#0#0#16#0#0#0#0#0#0#0#0#0#0#0#0#0#128#0#0 - +#128#0#0#0#128#128#0#128#0#0#0#128#0#128#0#128#128#0#0#192#192#192#0#128#128 - +#128#0#0#0#255#0#0#255#0#0#0#255#255#0#255#0#0#0#255#0#255#0#255#255#0#0#255 - +#255#255#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 - +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 - +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 - +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 - +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 - +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#15#240#0#0#0#0#0 - +#0#0#0#0#0#0#0#0#0#240#15#0#0#0#240#0#0#0#0#0#0#0#0#0#15#0#0#240#0#15#240#0#0 - +#0#0#0#0#0#0#0#15#0#0#240#0#240#240#0#0#0#0#0#0#0#0#0#0#240#15#0#15#0#240#0#0 - +#0#0#0#0#0#0#0#0#15#240#0#240#0#240#0#0#0#0#0#0#0#0#0#0#0#0#15#0#0#240#0#0#0 - +#0#0#0#0#0#0#0#0#0#240#0#0#240#0#0#0#0#0#0#0#0#0#0#0#15#0#0#0#240#0#0#0#0#0#0 - +#0#0#0#0#0#240#0#0#0#240#0#0#0#0#0#0#0#0#0#0#15#0#0#0#0#240#0#0#0#0#0#0#0#0#0 - +#0#255#255#255#255#255#240#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 - +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 - +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 - +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#255#255#255#255#255#255#255#255#255#255#255#255 - +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 - +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 - +#255#255#255#254''#255#255#252'?'#255#248#30''#255#248#28''#255#252'8' - +#255#254'p'#255#255#224''#255#255#192''#255#255#128''#255#255#0''#255 - +#254#0''#255#252#0''#255#255#255#255#255#255#255#255#255#255#255#255#255 - +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 -]); -LazarusResources.Add('VT_MOVENW','CUR',[ - #0#0#2#0#1#0' '#0#0#16#0#16#0#232#2#0#0#22#0#0#0'('#0#0#0' '#0#0#0'@'#0#0#0#1 - +#0#4#0#0#0#0#0#128#2#0#0#0#0#0#0#0#0#0#0#16#0#0#0#0#0#0#0#0#0#0#0#0#0#128#0#0 - +#128#0#0#0#128#128#0#128#0#0#0#128#0#128#0#128#128#0#0#192#192#192#0#128#128 - +#128#0#0#0#255#0#0#255#0#0#0#255#255#0#255#0#0#0#255#0#255#0#255#255#0#0#255 - +#255#255#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 - +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 - +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 - +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 - +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 - +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#15#240#0#0#0#0#0 - +#0#0#0#0#0#15#0#0#0#240#15#0#0#0#0#0#0#0#0#0#0#15#240#0#15#0#0#240#0#0#0#0#0 - +#0#0#0#0#15#15#0#15#0#0#240#0#0#0#0#0#0#0#0#0#15#0#240#0#240#15#0#0#0#0#0#0#0 - +#0#0#0#15#0#15#0#15#240#0#0#0#0#0#0#0#0#0#0#15#0#0#240#0#0#0#0#0#0#0#0#0#0#0 - +#0#15#0#0#15#0#0#0#0#0#0#0#0#0#0#0#0#15#0#0#0#240#0#0#0#0#0#0#0#0#0#0#0#15#0 - +#0#0#15#0#0#0#0#0#0#0#0#0#0#0#15#0#0#0#0#240#0#0#0#0#0#0#0#0#0#0#15#255#255 - +#255#255#255#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 - +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 - +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 - +#0#0#0#0#0#0#0#0#0#0#0#255#255#255#255#255#255#255#255#255#255#255#255#255 - +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 - +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 - +#255#255#254''#255#254#252'?'#255#254'x'#31#255#254'8'#31#255#254#28'?'#255 - +#254#14''#255#254#7#255#255#254#3#255#255#254#1#255#255#254#0#255#255#254#0 - +''#255#254#0'?'#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 - +#255#255#255#255#255#255#255#255#255#255#255#255#255#255 -]); -LazarusResources.Add('VT_MOVES','CUR',[ - #0#0#2#0#1#0' '#0#0#16#0#16#0#232#2#0#0#22#0#0#0'('#0#0#0' '#0#0#0'@'#0#0#0#1 - +#0#4#0#0#0#0#0#128#2#0#0#0#0#0#0#0#0#0#0#16#0#0#0#0#0#0#0#0#0#0#0#0#0#128#0#0 - +#128#0#0#0#128#128#0#128#0#0#0#128#0#128#0#128#128#0#0#192#192#192#0#128#128 - +#128#0#0#0#255#0#0#255#0#0#0#255#255#0#255#0#0#0#255#0#255#0#255#255#0#0#255 - +#255#255#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 - +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 - +#15#240#0#0#0#0#0#0#0#0#0#0#0#0#0#0#240#15#0#0#0#0#0#0#0#0#0#0#0#0#0#15#0#0 - +#240#0#0#0#0#0#0#0#0#0#0#0#0#240#0#0#15#0#0#0#0#0#0#0#0#0#0#0#15#0#0#0#0#240 - +#0#0#0#0#0#0#0#0#0#0#240#0#0#0#0#15#0#0#0#0#0#0#0#0#0#15#0#0#0#0#0#0#240#0#0 - +#0#0#0#0#0#0#255#255#255#255#255#255#255#255#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 - +#0#0#0#0#0#0#0#0#0#0#0#15#240#0#0#0#0#0#0#0#0#0#0#0#0#0#0#240#15#0#0#0#0#0#0 - +#0#0#0#0#0#0#0#15#0#0#240#0#0#0#0#0#0#0#0#0#0#0#0#15#0#0#240#0#0#0#0#0#0#0#0 - +#0#0#0#0#0#240#15#0#0#0#0#0#0#0#0#0#0#0#0#0#0#15#240#0#0#0#0#0#0#0#0#0#0#0#0 - +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 - +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 - +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 - +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 - +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 - +#0#0#0#0#0#0#0#0#0#0#0#0#0#255#255#255#255#255#255#255#255#255#255#255#255 - +#255#255#255#255#255#254''#255#255#252'?'#255#255#248#31#255#255#240#15#255 - +#255#224#7#255#255#192#3#255#255#128#1#255#255#0#0#255#255#255#255#255#255 - +#254''#255#255#252'?'#255#255#248#31#255#255#248#31#255#255#252'?'#255#255 - +#254''#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 - +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 - +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 -]); -LazarusResources.Add('VT_MOVESE','CUR',[ - #0#0#2#0#1#0' '#0#0#16#0#16#0#232#2#0#0#22#0#0#0'('#0#0#0' '#0#0#0'@'#0#0#0#1 - +#0#4#0#0#0#0#0#128#2#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#128#0#0 - +#128#0#0#0#128#128#0#128#0#0#0#128#0#128#0#128#128#0#0#192#192#192#0#128#128 - +#128#0#0#0#255#0#0#255#0#0#0#255#255#0#255#0#0#0#255#0#255#0#255#255#0#0#255 - +#255#255#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 - +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 - +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 - +#0#0#0#0#0#0#0#0#0#0#255#255#255#255#255#240#0#0#0#0#0#0#0#0#0#0#15#0#0#0#0 - +#240#0#0#0#0#0#0#0#0#0#0#0#240#0#0#0#240#0#0#0#0#0#0#0#0#0#0#0#15#0#0#0#240#0 - +#0#0#0#0#0#0#0#0#0#0#0#240#0#0#240#0#0#0#0#0#0#0#0#0#0#0#0#15#0#0#240#0#0#0#0 - +#0#0#0#0#0#0#15#240#0#240#0#240#0#0#0#0#0#0#0#0#0#0#240#15#0#15#0#240#0#0#0#0 - +#0#0#0#0#0#15#0#0#240#0#240#240#0#0#0#0#0#0#0#0#0#15#0#0#240#0#15#240#0#0#0#0 - +#0#0#0#0#0#0#240#15#0#0#0#240#0#0#0#0#0#0#0#0#0#0#15#240#0#0#0#0#0#0#0#0#0#0 - +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 - +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 - +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 - +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 - +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 - +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#255#255#255#255#255#255#255#255#255#255#255 - +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#252 - +#0''#255#254#0''#255#255#0''#255#255#128''#255#255#192''#255#255#224'' - +#255#254'p'#255#252'8'#255#248#28''#255#248#30''#255#252'?'#255#254'' - +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 - +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 - +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 -]); -LazarusResources.Add('VT_MOVESW','CUR',[ - #0#0#2#0#1#0' '#0#0#16#0#16#0#232#2#0#0#22#0#0#0'('#0#0#0' '#0#0#0'@'#0#0#0#1 - +#0#4#0#0#0#0#0#128#2#0#0#0#0#0#0#0#0#0#0#16#0#0#0#0#0#0#0#0#0#0#0#0#0#128#0#0 - +#128#0#0#0#128#128#0#128#0#0#0#128#0#128#0#128#128#0#0#192#192#192#0#128#128 - +#128#0#0#0#255#0#0#255#0#0#0#255#255#0#255#0#0#0#255#0#255#0#255#255#0#0#255 - +#255#255#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 - +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 - +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 - +#0#0#0#0#0#0#15#255#255#255#255#255#0#0#0#0#0#0#0#0#0#0#15#0#0#0#0#240#0#0#0 - +#0#0#0#0#0#0#0#15#0#0#0#15#0#0#0#0#0#0#0#0#0#0#0#15#0#0#0#240#0#0#0#0#0#0#0#0 - +#0#0#0#15#0#0#15#0#0#0#0#0#0#0#0#0#0#0#0#15#0#0#240#0#0#0#0#0#0#0#0#0#0#0#0 - +#15#0#15#0#15#240#0#0#0#0#0#0#0#0#0#0#15#0#240#0#240#15#0#0#0#0#0#0#0#0#0#0 - +#15#15#0#15#0#0#240#0#0#0#0#0#0#0#0#0#15#240#0#15#0#0#240#0#0#0#0#0#0#0#0#0 - +#15#0#0#0#240#15#0#0#0#0#0#0#0#0#0#0#0#0#0#0#15#240#0#0#0#0#0#0#0#0#0#0#0#0#0 - +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 - +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 - +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 - +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 - +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 - +#0#0#0#0#0#0#0#0#0#0#0#0#255#255#255#255#255#255#255#255#255#255#255#255#255 - +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#254#0'?'#255#254 - +#0''#255#254#0#255#255#254#1#255#255#254#3#255#255#254#7#255#255#254#14'' - +#255#254#28'?'#255#254'8'#31#255#254'x'#31#255#254#252'?'#255#255#254''#255 - +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 - +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 - +#255#255#255#255#255#255#255#255#255#255#255#255#255#255 -]); -LazarusResources.Add('VT_MOVEW','CUR',[ - #0#0#2#0#1#0' '#0#0#16#0#16#0#232#2#0#0#22#0#0#0'('#0#0#0' '#0#0#0'@'#0#0#0#1 - +#0#4#0#0#0#0#0#128#2#0#0#0#0#0#0#0#0#0#0#16#0#0#0#0#0#0#0#0#0#0#0#0#0#128#0#0 - +#128#0#0#0#128#128#0#128#0#0#0#128#0#128#0#128#128#0#0#192#192#192#0#128#128 - +#128#0#0#0#255#0#0#255#0#0#0#255#255#0#255#0#0#0#255#0#255#0#255#255#0#0#255 - +#255#255#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 - +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 - +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 - +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 - +#0#0#240#0#0#0#0#0#0#0#0#0#0#0#0#0#0#15#240#0#0#0#0#0#0#0#0#0#0#0#0#0#0#240 - +#240#0#0#0#0#0#0#0#0#0#0#0#0#0#15#0#240#0#0#0#0#0#0#0#0#0#0#0#0#0#240#0#240#0 - +#15#240#0#0#0#0#0#0#0#0#0#15#0#0#240#0#240#15#0#0#0#0#0#0#0#0#0#240#0#0#240 - +#15#0#0#240#0#0#0#0#0#0#0#0#240#0#0#240#15#0#0#240#0#0#0#0#0#0#0#0#15#0#0#240 - +#0#240#15#0#0#0#0#0#0#0#0#0#0#240#0#240#0#15#240#0#0#0#0#0#0#0#0#0#0#15#0#240 - +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#240#240#0#0#0#0#0#0#0#0#0#0#0#0#0#0#15#240#0#0#0 - +#0#0#0#0#0#0#0#0#0#0#0#0#240#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 - +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 - +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 - +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 - +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#255#255#255#255#255#255#255#255#255#255#255 - +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 - +#255#255#255#255#255#255#255#223#255#255#255#159#255#255#255#31#255#255#254 - +#31#255#255#252#30''#255#248#28'?'#255#240#24#31#255#240#24#31#255#248#28'?' - +#255#252#30''#255#254#31#255#255#255#31#255#255#255#159#255#255#255#223#255 - +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 - +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 -]); -LazarusResources.Add('VT_XPBUTTONPLUS','BMP',[ - 'BM4'#1#0#0#0#0#0#0'6'#0#0#0'('#0#0#0#9#0#0#0#9#0#0#0#1#0#24#0#0#0#0#0#0#0#0#0 - +#18#11#0#0#18#11#0#0#0#0#0#0#0#0#0#0#211#194#176#181#152'x'#181#152'x'#181 - +#152'x'#181#152'x'#181#152'x'#181#152'x'#181#152'x'#211#194#176#0#181#152'x' - +#191#204#210#174#190#198#168#184#194#167#184#193#167#184#193#166#183#192#170 - +#186#195#181#152'x'#0#181#152'x'#217#225#228#207#216#220#201#211#216#0#0#0 - +#198#209#214#192#204#210#187#200#207#181#152'x'#0#181#152'x'#238#242#242#236 - +#240#240#231#237#237#0#0#0#227#233#234#217#224#227#204#214#219#181#152'x'#0 - +#181#152'x'#241#245#245#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#210#219#223#181#152'x' - +#0#181#152'x'#245#247#247#245#247#247#244#247#247#0#0#0#244#246#246#235#240 - +#241#218#225#229#181#152'x'#0#181#152'x'#251#252#252#251#253#253#251#253#253 - +#0#0#0#251#252#252#250#252#252#243#246#247#181#152'x'#0#181#152'x'#255#255 - +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 - +#181#152'x'#0#211#194#176#181#152'x'#181#152'x'#181#152'x'#181#152'x'#181#152 - +'x'#181#152'x'#181#152'x'#211#194#176#0#0#0 -]); -LazarusResources.Add('VT_XPBUTTONMINUS','BMP',[ - 'BM4'#1#0#0#0#0#0#0'6'#0#0#0'('#0#0#0#9#0#0#0#9#0#0#0#1#0#24#0#0#0#0#0#0#0#0#0 - +#18#11#0#0#18#11#0#0#0#0#0#0#0#0#0#0#211#194#176#181#152'x'#181#152'x'#181 - +#152'x'#181#152'x'#181#152'x'#181#152'x'#181#152'x'#211#194#176#0#181#152'x' - +#191#204#210#174#190#198#168#184#194#167#184#193#167#184#193#166#183#192#170 - +#186#195#181#152'x'#0#181#152'x'#217#225#228#207#216#220#201#211#216#199#210 - +#215#198#209#214#192#204#210#187#200#207#181#152'x'#0#181#152'x'#238#242#242 - +#236#240#240#231#237#237#230#235#236#227#233#234#217#224#227#204#214#219#181 - +#152'x'#0#181#152'x'#241#245#245#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#210#219#223 - +#181#152'x'#0#181#152'x'#245#247#247#245#247#247#244#247#247#244#247#247#244 - +#246#246#235#240#241#218#225#229#181#152'x'#0#181#152'x'#251#252#252#251#253 - +#253#251#253#253#251#253#253#251#252#252#250#252#252#243#246#247#181#152'x'#0 - +#181#152'x'#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 - +#255#255#255#255#255#181#152'x'#0#211#194#176#181#152'x'#181#152'x'#181#152 - +'x'#181#152'x'#181#152'x'#181#152'x'#181#152'x'#211#194#176#0#0#0 -]); -LazarusResources.Add('VT_CHECK_LIGHT','BMP',[ - 'BM'#246#12#0#0#0#0#0#0'v'#0#0#0'('#0#0#0#144#1#0#0#16#0#0#0#1#0#4#0#0#0#0#0 - +#128#12#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#255#255#255#0#255#0#255#0 - +#192#192#192#0#128#128#128#0#128#0#128#0#128#128#0#0#192#192#192#0#128#128 - +#128#0#0#0#255#0#0#255#0#0#0#255#255#0#255#0#0#0#255#0#255#0#255#255#0#0#255 - +#255#255#0'"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""' - +'"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""' - +'"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""' - +'"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""' - +'"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""' - +'""""""""""""""""""""""""""""""""""""""""""""""332"""""332"""""332"""""332""' - +'"""332"""""332"""""332"""""332"""#33332""#33332""#33332""#33332""#33332""#3' - +'3332""#33332""#33332""#33332""#33332""#33332""#33332"!DDDDDDB!DDDDDDB$'#17 - +#17#17#17#17#17#18'!DDDDDDB""""""""""3'#17#17#19'""""3'#17#17#19'""""3333"""' - +'"3333""""3'#17#17#19'""""3'#17#17#19'""""3333""""3333"""4'#17#17#17#17#19'"' - +'"4'#17#17#17#17#19'""433333""433333""4'#17#17#17#17#19'""4'#17#17#17#17#19 - +'""433333""433333""4'#17#17#17#17#19'""4'#17#17#17#17#19'""433333""433333"!3' - +'33333B!333333B$333333'#18'!333333B"""""""""#A'#17#17#17'2""#A'#17#17#17'2""' - +'#C3332""#C3332""#A'#19'3'#17'2""#A'#19'3'#17'2""#C3332""#C3332""4'#17#17#17 - +#17#19'""4'#17#17#17#17#19'""433333""433333""4'#20'A'#17'D'#19'""4'#20'A'#17 - +'D'#19'""44C3D3""44C3D3""4'#20'DDD'#19'""4'#20'DDD'#19'""44DDD3""44DDD3"!333' - +'333B!333333B$333333'#18'!333333B"""""""""$'#17#17#17#17#19'""$'#17#17#17#17 - +#19'""$33333""$33333""$'#17'DDA'#19'""$'#17'DDA'#19'""$3DDC3""$3DDC3""4'#17 - +#17#17#17#19'""4'#17#17#17#17#19'""433333""433333""4'#20'D'#20'D'#19'""4'#20 - +'D'#20'D'#19'""44D4D3""44D4D3""4'#20'DDD'#19'""4'#20'DDD'#19'""44DDD3""44DDD' - +'3"!333333B!333333B$333'#3'33'#18'!333333B"""""""""4'#17#17#17#17#19'""4'#17 - +#17#17#17#19'""433333""433333""4'#19'DDC'#19'""4'#19'DDC'#19'""43DDC3""43DDC' - +'3""4'#17#17#17#17#19'""4'#17#17#17#17#19'""433333""433333""4'#17'DDA'#19'""' - +'4'#17'DDA'#19'""43DDC3""43DDC3""4'#20'DDD'#19'""4'#20'DDD'#19'""44DDD3""44D' - +'DD3"!330333B!330333B$330'#0'33'#18'!334333B"""""""""4'#17#17#17#17#19'""4' - +#17#17#17#17#19'""433333""433333""4'#19'DDC'#19'""4'#19'DDC'#19'""43DDC3""43' - +'DDC3""4'#17#17#17#17#19'""4'#17#17#17#17#19'""433333""433333""4'#17#20'D'#17 - +#19'""4'#17#20'D'#17#19'""434D33""434D33""4'#20'DDD'#19'""4'#20'DDD'#19'""44' - +'DDD3""44DDD3"!33'#0#3'33B!33'#0#3'33B$33'#0#0#3'3'#18'!33DC33B"""""""""4'#17 - +#17#17#17#19'""4'#17#17#17#17#19'""433333""433333""4'#19'DDC'#19'""4'#19'DDC' - +#19'""43DDC3""43DDC3""4'#17#17#17#17#19'""4'#17#17#17#17#19'""433333""433333' - +'""4'#17'DDA'#19'""4'#17'DDA'#19'""43DDC3""43DDC3""4'#20'DDD'#19'""4'#20'DDD' - +#19'""44DDD3""44DDD3"!30'#0#0'33B!30'#0#0'33B$30'#0#0#0'3'#18'!34DD33B""""""' - +'"""4'#17#17#17#17#19'""4'#17#17#17#17#19'""433333""433333""4'#17'DDA'#19'""' - +'4'#17'DDA'#19'""43DDC3""43DDC3""4'#17#17#17#17#19'""4'#17#17#17#17#19'""433' - +'333""433333""4'#20'D'#20'D'#19'""4'#20'D'#20'D'#19'""44D4D3""44D4D3""4'#20 - +'DDD'#19'""4'#20'DDD'#19'""44DDD3""44DDD3"!3'#0#0#0#3'3B!3'#0#0#0#3'3B$33333' - +'3'#18'!3DDDC3B"""""""""$1'#17#17#17'2""$1'#17#17#17'2""$33332""$33332""$1' - +#19'3'#17'2""$1'#19'3'#17'2""$33332""$33332""4'#17#17#17#17#19'""4'#17#17#17 - +#17#19'""433333""433333""4'#20'A'#17'D'#19'""4'#20'A'#17'D'#19'""44C3D3""44C' - +'3D3""4'#20'DDD'#19'""4'#20'DDD'#19'""44DDD3""44DDD3"!333333B!333333B$333333' - +#18'!333333B"""""""""#C'#17#17#20'2""#C'#17#17#20'2""#C3342""#C3342""#C'#17 - +#17#20'2""#C'#17#17#20'2""#C3342""#C3342""4'#17#17#17#17#19'""4'#17#17#17#17 - +#19'""433333""433333""4'#17#17#17#17#19'""4'#17#17#17#17#19'""433333""433333' - +'""4'#17#17#17#17#19'""4'#17#17#17#17#19'""433333""433333"!333333B!333333B$3' - +'33333'#18'!333333B""""""""""4DDC""""4DDC""""4DDC""""4DDC""""4DDC""""4DDC"""' - +'"4DDC""""4DDC"""4DDDDC""4DDDDC""4DDDDC""4DDDDC""4DDDDC""4DDDDC""4DDDDC""4DD' - +'DDC""4DDDDC""4DDDDC""4DDDDC""4DDDDC"!333333B!333333B$333333'#18'!333333B"""' - +'""""""""33""""""33""""""33""""""33""""""33""""""33""""""33""""""33""""#3333' - +'2""#33332""#33332""#33332""#33332""#33332""#33332""#33332""#33332""#33332""' - +'#33332""#33332"!'#17#17#17#17#17#17#18'!'#17#17#17#17#17#17#18'$DDDDDDB!'#17 - +#17#17#17#17#17#18'"""""""""""""""""""""""""""""""""""""""""""""""""""""""""' - +'"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""' - +'"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""' - +'"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""' - +'"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""' - +'"""""""""""""""""""""""""""""""""""""""""""' -]); -LazarusResources.Add('VT_CHECK_DARK','BMP',[ - 'BM'#246#12#0#0#0#0#0#0'v'#0#0#0'('#0#0#0#144#1#0#0#16#0#0#0#1#0#4#0#0#0#0#0 - +#128#12#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#255#255#255#0#255#0#255#0 - +#192#192#192#0#128#128#128#0#128#0#128#0#128#128#0#0#192#192#192#0#128#128 - +#128#0#0#0#255#0#0#255#0#0#0#255#255#0#255#0#0#0#255#0#255#0#255#255#0#0#255 - +#255#255#0'"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""' - +'"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""' - +'"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""' - +'"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""' - +'"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""' - +'""""""""""""""""""""""""""""""""""""""""""""""DDB"""""DDB"""""DDB"""""DDB""' - +'"""DDB"""""DDB"""""DDB"""""DDB"""$DDDDB""$DDDDB""$DDDDB""$DDDDB""$DDDDB""$D' - +'DDDB""$DDDDB""$DDDDB""$DDDDB""$DDDDB""$DDDDB""$DDDDB"!DDDDDDB!DDDDDDB$'#17 - +#17#17#17#17#17#18'!DDDDDDB""""""""""D'#17#17#20'""""D'#17#17#20'""""D334"""' - +'"D334""""D'#17#17#20'""""D'#17#17#20'""""D334""""D334"""@'#17#17#17#17#20'"' - +'"@'#17#17#17#17#20'""@33334""@33334""@'#17#17#17#17#20'""@'#17#17#17#17#20 - +'""@33334""@33334""@'#17#17#17#17#20'""@'#17#17#17#17#20'""@33334""@33334"!3' - +'33333B!333333B$333333'#18'!333333B"""""""""$'#1#17#17#17'B""$'#1#17#17#17'B' - +'""$'#3'333B""$'#3'333B""$'#1#20'D'#17'B""$'#1#20'D'#17'B""$'#3'4D3B""$'#3'4' - +'D3B""@'#17#17#17#17#20'""@'#17#17#17#17#20'""@33334""@33334""@'#16#1#17#0#20 - +'""@'#16#1#17#0#20'""@0'#3'3'#0'4""@0'#3'3'#0'4""@'#16#0#0#0#20'""@'#16#0#0#0 - +#20'""@0'#0#0#0'4""@4DDD4"!333333B!333333B$333333'#18'!333333B""""""""" '#17 - +#17#17#17#20'"" '#17#17#17#17#20'"" 33334"" 33334"" '#17#0#0#1#20'"" '#17#0#0 - +#1#20'"" 3'#0#0#3'4"" 3'#0#0#3'4""@'#17#17#17#17#20'""@'#17#17#17#17#20'""@3' - +'3334""@33334""@'#16#0#16#0#20'""@'#16#0#16#0#20'""@0'#0'0'#0'4""@0'#0'0'#0 - +'4""@'#16#0#0#0#20'""@'#16#0#0#0#20'""@0'#0#0#0'4""@4DDD4"!333333B!333333B$3' - +'33'#3'33'#18'!333333B"""""""""@'#17#17#17#17#20'""@'#17#17#17#17#20'""@3333' - +'4""@33334""@'#20#0#0#4#20'""@'#20#0#0#4#20'""@4'#0#0#4'4""@4'#0#0#4'4""@'#17 - +#17#17#17#20'""@'#17#17#17#17#20'""@33334""@33334""@'#17#0#0#1#20'""@'#17#0#0 - +#1#20'""@3'#0#0#3'4""@3'#0#0#3'4""@'#16#0#0#0#20'""@'#16#0#0#0#20'""@0'#0#0#0 - +'4""@4DDD4"!330333B!330333B$330'#0'33'#18'!334333B"""""""""@'#17#17#17#17#20 - +'""@'#17#17#17#17#20'""@33334""@33334""@'#20#0#0#4#20'""@'#20#0#0#4#20'""@4' - +#0#0#4'4""@4'#0#0#4'4""@'#17#17#17#17#20'""@'#17#17#17#17#20'""@33334""@3333' - +'4""@'#17#16#0#17#20'""@'#17#16#0#17#20'""@30'#0'34""@30'#0'34""@'#16#0#0#0 - +#20'""@'#16#0#0#0#20'""@0'#0#0#0'4""@4DDD4"!33'#0#3'33B!33'#0#3'33B$33'#0#0#3 - +'3'#18'!33DC33B"""""""""@'#17#17#17#17#20'""@'#17#17#17#17#20'""@33334""@333' - +'34""@'#20#0#0#4#20'""@'#20#0#0#4#20'""@4'#0#0#4'4""@4'#0#0#4'4""@'#17#17#17 - +#17#20'""@'#17#17#17#17#20'""@33334""@33334""@'#17#0#0#1#20'""@'#17#0#0#1#20 - +'""@3'#0#0#3'4""@3'#0#0#3'4""@'#16#0#0#0#20'""@'#16#0#0#0#20'""@0'#0#0#0'4""' - +'@4DDD4"!30'#0#0'33B!30'#0#0'33B$30'#0#0#0'3'#18'!34DD33B"""""""""@'#17#17#17 - +#17#20'""@'#17#17#17#17#20'""@33334""@33334""@'#17#0#0#1#20'""@'#17#0#0#1#20 - +'""@3'#0#0#3'4""@3'#0#0#3'4""@'#17#17#17#17#20'""@'#17#17#17#17#20'""@33334"' - +'"@33334""@'#16#0#16#0#20'""@'#16#0#16#0#20'""@0'#0'0'#0'4""@0'#0'0'#0'4""@' - +#16#0#0#0#20'""@'#16#0#0#0#20'""@0'#0#0#0'4""@4DDD4"!3'#0#0#0#3'3B!3'#0#0#0#3 - +'3B$333333'#18'!3DDDC3B""""""""" A'#17#17#17'B"" A'#17#17#17'B"" C333B"" C33' - +'3B"" A'#20'D'#17'B"" A'#20'D'#17'B"" C4D3B"" C4D3B""@'#17#17#17#17#20'""@' - +#17#17#17#17#20'""@33334""@33334""@'#16#1#17#0#20'""@'#16#1#17#0#20'""@0'#3 - +'3'#0'4""@0'#3'3'#0'4""@'#16#0#0#0#20'""@'#16#0#0#0#20'""@0'#0#0#0'4""@4DDD4' - +'"!333333B!333333B$333333'#18'!333333B"""""""""$'#4#17#17#16'B""$'#4#17#17#16 - +'B""$'#4'330B""$'#4'330B""$'#4#17#17#16'B""$'#4#17#17#16'B""$'#4'330B""$'#4 - +'330B""@'#17#17#17#17#20'""@'#17#17#17#17#20'""@33334""@33334""@'#17#17#17#17 - +#20'""@'#17#17#17#17#20'""@33334""@33334""@'#17#17#17#17#20'""@'#17#17#17#17 - +#20'""@33334""@33334"!333333B!333333B$333333'#18'!333333B""""""""""@'#0#0#4 - +'""""@'#0#0#4'""""@'#0#0#4'""""@'#0#0#4'""""@'#0#0#4'""""@'#0#0#4'""""@'#0#0 - +#4'""""@'#0#0#4'"""@'#0#0#0#0#4'""@'#0#0#0#0#4'""@'#0#0#0#0#4'""@'#0#0#0#0#4 - +'""@'#0#0#0#0#4'""@'#0#0#0#0#4'""@'#0#0#0#0#4'""@'#0#0#0#0#4'""@'#0#0#0#0#4 - +'""@'#0#0#0#0#4'""@'#0#0#0#0#4'""@'#0#0#0#0#4'"!333333B!333333B$333333'#18'!' - +'333333B"""""""""""DD""""""DD""""""DD""""""DD""""""DD""""""DD""""""DD""""""D' - +'D""""$DDDDB""$DDDDB""$DDDDB""$DDDDB""$DDDDB""$DDDDB""$DDDDB""$DDDDB""$DDDDB' - +'""$DDDDB""$DDDDB""$DDDDB"!'#17#17#17#17#17#17#18'!'#17#17#17#17#17#17#18'$D' - +'DDDDDB!'#17#17#17#17#17#17#18'"""""""""""""""""""""""""""""""""""""""""""""' - +'"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""' - +'"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""' - +'"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""' - +'"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""' - ,'"""""""""""""""""""""""""""""""""""""""""""""""""""""""' -]); -LazarusResources.Add('VT_FLAT','BMP',[ - 'BM'#246#12#0#0#0#0#0#0'v'#0#0#0'('#0#0#0#144#1#0#0#16#0#0#0#1#0#4#0#0#0#0#0 - +#128#12#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#255#255#255#0#255#0#255#0 - +#192#192#192#0#128#128#128#0#128#0#128#0#128#128#0#0#192#192#192#0#128#128 - +#128#0#0#0#255#0#0#255#0#0#0#255#255#0#255#0#0#0#255#0#255#0#255#255#0#0#255 - +#255#255#0'"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""' - +'"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""' - +'"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""' - +'"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""' - +'"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""' - +'""""""""""""""""""""""""""""""""""""""""""""""'#0#0'""""""'#0#0'""""""'#0#0 - +'""""""'#0#0'""""""'#0#0'""""""'#0#0'""""""'#0#0'""""""'#0#0'""" '#0#0#0#0#0 - +#0'" '#0#0#0#0#0#0'" '#0#0#0#0#0#0'" '#0#0#0#0#0#0'" '#0#0#0#0#0#0'" '#0#0#0 - +#0#0#0'" '#0#0#0#0#0#0'" '#0#0#0#0#0#0'" '#0#0#0#0#0#0'" '#0#0#0#0#0#0'" '#0 - +#0#0#0#0#0'" '#0#0#0#0#0#0'""'#0#0#0#0#0#0#2'"'#0#0#0#0#0#0#2'"'#0#0#0#0#0#0 - +#2'"'#0#0#0#0#0#0#2'""""""""""'#0#0#0#0'""""'#0#0#0#0'""""'#0#0#0#0'""""'#0#0 - +#0#0'""""'#0#0#0#0'""""'#0#0#0#0'""""'#0#0#0#0'""""'#0#0#0#0'"" '#0#0#0#0#0#0 - +'" '#0#0#0#0#0#0'" '#0#0#0#0#0#0'" '#0#0#0#0#0#0'" '#0#0#0#0#0#0'" '#0#0#0#0 - +#0#0'" '#0#0#0#0#0#0'" '#0#0#0#0#0#0'" '#0#0#0#0#0#0'" '#0#0#0#0#0#0'" '#0#0 - +#0#0#0#0'" '#0#0#0#0#0#0'""'#0#0#0#0#0#0#2'"'#0#0#0#0#0#0#2'"'#0'33333'#2'"' - +#0#0#0#0#0#0#2'""""""""" '#0#17#17#0#2'"" '#0#17#17#0#2'"" '#0'33'#0#2'"" '#0 - +'33'#0#2'"" '#0#17#17#0#2'"" '#0#17#17#0#2'"" '#0'33'#0#2'"" '#0'33'#0#2'" ' - +#1#17#17#17#17#0'" '#1#17#17#17#17#0'" '#3'3333'#0'" '#3'3333'#0'" '#1#17#17 - +#17#17#0'" '#1#17#17#17#17#0'" '#3'3333'#0'" '#3'3333'#0'" '#1#17#17#17#17#0 - +'" '#1#17#17#17#17#0'" '#3'3333'#0'" '#3'3333'#0'""'#0#17#17#17#17#16#2'"'#0 - +#17#17#17#17#16#2'"'#0#17#17#17#17#19#2'"'#0'33330'#2'""""""""" '#1#17#17#16 - +#2'"" '#1#17#17#16#2'"" '#3'330'#2'"" '#3'330'#2'"" '#1#17#17#16#2'"" '#1#17 - +#17#16#2'"" '#3'330'#2'"" '#3'330'#2'" '#1#17#17#17#17#0'" '#1#17#17#17#17#0 - +'" '#3'3333'#0'" '#3'3333'#0'" '#1#17#1#17#17#0'" '#1#17#1#17#17#0'" '#3'3'#3 - +'33'#0'" '#3'3'#3'33'#0'" '#1#0#0#0#1#0'" '#1#0#0#0#1#0'" '#3#0#0#0#3#0'" '#3 - +'DDDC'#0'""'#0#17#17#17#17#16#2'"'#0#17#17#17#17#16#2'"'#0#17#17#17#17#19#2 - +'"'#0'33330'#2'"""""""""'#0#17#17#17#17#0'""'#0#17#17#17#17#0'""'#0'3333'#0 - +'""'#0'3333'#0'""'#0#17#16#1#17#0'""'#0#17#16#1#17#0'""'#0'30'#3'3'#0'""'#0 - +'30'#3'3'#0'" '#1#17#17#17#17#0'" '#1#17#17#17#17#0'" '#3'3333'#0'" '#3'3333' - +#0'" '#1#16#0#17#17#0'" '#1#16#0#17#17#0'" '#3'0'#0'33'#0'" '#3'0'#0'33'#0'"' - +' '#1#0#0#0#1#0'" '#1#0#0#0#1#0'" '#3#0#0#0#3#0'" '#3'DDDC'#0'""'#0#17#17#1 - +#17#16#2'"'#0#17#17#1#17#16#2'"'#0#17#17#1#17#19#2'"'#0'33'#3'30'#2'""""""""' - +'"'#0#17#17#17#17#0'""'#0#17#17#17#17#0'""'#0'3333'#0'""'#0'3333'#0'""'#0#17 - +#0#0#17#0'""'#0#17#0#0#17#0'""'#0'3'#0#0'3'#0'""'#0'3'#0#0'3'#0'" '#1#17#17 - +#17#17#0'" '#1#17#17#17#17#0'" '#3'3333'#0'" '#3'3333'#0'" '#1#0#0#1#17#0'" ' - +#1#0#0#1#17#0'" '#3#0#0#3'3'#0'" '#3#0#0#3'3'#0'" '#1#0#0#0#1#0'" '#1#0#0#0#1 - +#0'" '#3#0#0#0#3#0'" '#3'DDDC'#0'""'#0#17#16#0#17#16#2'"'#0#17#16#0#17#16#2 - +'"'#0#17#16#0#17#19#2'"'#0'30'#0'30'#2'"""""""""'#0#17#17#17#17#0'""'#0#17#17 - +#17#17#0'""'#0'3333'#0'""'#0'3333'#0'""'#0#17#0#0#17#0'""'#0#17#0#0#17#0'""' - +#0'3'#0#0'3'#0'""'#0'3'#0#0'3'#0'" '#1#17#17#17#17#0'" '#1#17#17#17#17#0'" ' - +#3'3333'#0'" '#3'3333'#0'" '#1#0#16#0#17#0'" '#1#0#16#0#17#0'" '#3#0'0'#0'3' - +#0'" '#3#0'0'#0'3'#0'" '#1#0#0#0#1#0'" '#1#0#0#0#1#0'" '#3#0#0#0#3#0'" '#3'D' - +'DDC'#0'""'#0#17#0#0#1#16#2'"'#0#17#0#0#1#16#2'"'#0#17#0#0#1#19#2'"'#0'3'#0#0 - +#3'0'#2'"""""""""'#0#17#17#17#17#0'""'#0#17#17#17#17#0'""'#0'3333'#0'""'#0'3' - +'333'#0'""'#0#17#16#1#17#0'""'#0#17#16#1#17#0'""'#0'30'#3'3'#0'""'#0'30'#3'3' - +#0'" '#1#17#17#17#17#0'" '#1#17#17#17#17#0'" '#3'3333'#0'" '#3'3333'#0'" '#1 - +#1#17#0#1#0'" '#1#1#17#0#1#0'" '#3#3'3'#0#3#0'" '#3#3'3'#0#3#0'" '#1#0#0#0#1 - +#0'" '#1#0#0#0#1#0'" '#3#0#0#0#3#0'" '#3'DDDC'#0'""'#0#16#0#0#0#16#2'"'#0#16 - +#0#0#0#16#2'"'#0#16#0#0#0#19#2'"'#0'0'#0#0#0'0'#2'""""""""" '#1#17#17#16#2'"' - +'" '#1#17#17#16#2'"" '#3'330'#2'"" '#3'330'#2'"" '#1#17#17#16#2'"" '#1#17#17 - +#16#2'"" '#3'330'#2'"" '#3'330'#2'" '#1#17#17#17#17#0'" '#1#17#17#17#17#0'" ' - +#3'3333'#0'" '#3'3333'#0'" '#1#17#17#16#1#0'" '#1#17#17#16#1#0'" '#3'330'#3#0 - +'" '#3'330'#3#0'" '#1#0#0#0#1#0'" '#1#0#0#0#1#0'" '#3#0#0#0#3#0'" '#3'DDDC'#0 - +'""'#0#17#17#17#17#16#2'"'#0#17#17#17#17#16#2'"'#0#17#17#17#17#19#2'"'#0'333' - +'30'#2'""""""""" '#0#17#17#0#2'"" '#0#17#17#0#2'"" '#0'33'#0#2'"" '#0'33'#0#2 - +'"" '#0#17#17#0#2'"" '#0#17#17#0#2'"" '#0'33'#0#2'"" '#0'33'#0#2'" '#1#17#17 - +#17#17#0'" '#1#17#17#17#17#0'" '#3'3333'#0'" '#3'3333'#0'" '#1#17#17#17#1#0 - +'" '#1#17#17#17#1#0'" '#3'333'#3#0'" '#3'333'#3#0'" '#1#0#0#0#1#0'" '#1#0#0#0 - +#1#0'" '#3#0#0#0#3#0'" '#3'DDDC'#0'""'#0#17#17#17#17#16#2'"'#0#17#17#17#17#16 - +#2'"'#0#17#17#17#17#19#2'"'#0'33330'#2'""""""""""'#0#0#0#0'""""'#0#0#0#0'"""' - ,'"'#0#0#0#0'""""'#0#0#0#0'""""'#0#0#0#0'""""'#0#0#0#0'""""'#0#0#0#0'""""'#0#0 - +#0#0'"" '#1#17#17#17#17#0'" '#1#17#17#17#17#0'" '#3'3333'#0'" '#3'3333'#0'" ' - +#1#17#17#17#17#0'" '#1#17#17#17#17#0'" '#3'3333'#0'" '#3'3333'#0'" '#1#17#17 - +#17#17#0'" '#1#17#17#17#17#0'" '#3'3333'#0'" '#3'3333'#0'""'#0#17#17#17#17#16 - +#2'"'#0#17#17#17#17#16#2'"'#0#17#17#17#17#19#2'"'#0'33330'#2'"""""""""""'#0#0 - +'""""""'#0#0'""""""'#0#0'""""""'#0#0'""""""'#0#0'""""""'#0#0'""""""'#0#0'"""' - +'"""'#0#0'""" '#0#0#0#0#0#0'" '#0#0#0#0#0#0'" '#0#0#0#0#0#0'" '#0#0#0#0#0#0 - +'" '#0#0#0#0#0#0'" '#0#0#0#0#0#0'" '#0#0#0#0#0#0'" '#0#0#0#0#0#0'" '#0#0#0#0 - +#0#0'" '#0#0#0#0#0#0'" '#0#0#0#0#0#0'" '#0#0#0#0#0#0'""'#0#0#0#0#0#0#2'"'#0#0 - +#0#0#0#0#2'"'#0#0#0#0#0#0#2'"'#0#0#0#0#0#0#2'"""""""""""""""""""""""""""""""' - +'""""""""""""""""""""""""""""""""""""""""" '#0#0#0#0#0#0'" '#0#0#0#0#0#0'" ' - +#0#0#0#0#0#0'" '#0#0#0#0#0#0'" '#0#0#0#0#0#0'" '#0#0#0#0#0#0'" '#0#0#0#0#0#0 - +'" '#0#0#0#0#0#0'" '#0#0#0#0#0#0'" '#0#0#0#0#0#0'" '#0#0#0#0#0#0'" '#0#0#0#0 - +#0#0'""'#0#0#0#0#0#0#2'"'#0#0#0#0#0#0#2'"'#0#0#0#0#0#0#2'"'#0#0#0#0#0#0#2'""' - +'"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""' - +'"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""' - +'""""""""""""""""""""""""""""""""""""""""""""""""' -]); -LazarusResources.Add('VT_TICK_DARK','BMP',[ - 'BM'#246#12#0#0#0#0#0#0'v'#0#0#0'('#0#0#0#144#1#0#0#16#0#0#0#1#0#4#0#0#0#0#0 - +#128#12#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#255#255#255#0#255#0#255#0 - +#192#192#192#0#128#128#128#0#128#0#128#0#128#128#0#0#192#192#192#0#128#128 - +#128#0#0#0#255#0#0#255#0#0#0#255#255#0#255#0#0#0#255#0#255#0#255#255#0#0#255 - +#255#255#0'"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""' - +'"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""' - +'"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""' - +'"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""' - +'"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""' - +'""""""""""""""""""""""""""""""""""""""""""""""DDB"""""DDB"""""DDB"""""DDB""' - +'"""DDB"""""DDB"""""DDB"""""DDB"""$DDDDB""$DDDDB""$DDDDB""$DDDDB""$DDDDB""$D' - +'DDDB""$DDDDB""$DDDDB""$DDDDB""$DDDDB""$DDDDB""$DDDDB"!DDDDDDB!DDDDDDB$'#17 - +#17#17#17#17#17#18'!DDDDDDB""""""""""D'#17#17#20'""""D'#17#17#20'""""D334"""' - +'"D334""""D'#17#17#20'""""D'#17#17#20'""""D334""""D334"""@'#17#17#17#17#20'"' - +'"@'#17#17#17#17#20'""@33334""@33334""@'#17#17#17#17#20'""@'#17#17#17#17#20 - +'""@33334""@33334""@'#17#17#17#17#20'""@'#17#17#17#17#20'""@33334""@33334"!3' - +'33333B!333333B$333333'#18'!333333B"""""""""$'#1#17#17#17'B""$'#1#17#17#17'B' - +'""$'#3'333B""$'#3'333B""$'#1#20'D'#17'B""$'#1#20'D'#17'B""$'#3'4D3B""$'#3'4' - +'D3B""@'#17#17#17#17#20'""@'#17#17#17#17#20'""@33334""@33334""@'#17#16#17#17 - +#20'""@'#17#16#17#17#20'""@30334""@30334""@'#16#0#0#0#20'""@'#16#0#0#0#20'""' - +'@0'#0#0#0'4""@4DDD4"!333333B!333333B$333333'#18'!333333B""""""""" '#17#17#17 - +#17#20'"" '#17#17#17#17#20'"" 33334"" 33334"" '#17#0#0#1#20'"" '#17#0#0#1#20 - +'"" 3'#0#0#3'4"" 3'#0#0#3'4""@'#17#17#17#17#20'""@'#17#17#17#17#20'""@33334"' - +'"@33334""@'#17#0#1#17#20'""@'#17#0#1#17#20'""@3'#0#3'34""@3'#0#3'34""@'#16#0 - +#0#0#20'""@'#16#0#0#0#20'""@0'#0#0#0'4""@4DDD4"!333333B!333333B$333'#3'33'#18 - +'!333333B"""""""""@'#17#17#17#17#20'""@'#17#17#17#17#20'""@33334""@33334""@' - +#20#0#0#4#20'""@'#20#0#0#4#20'""@4'#0#0#4'4""@4'#0#0#4'4""@'#17#17#17#17#20 - +'""@'#17#17#17#17#20'""@33334""@33334""@'#16#0#0#17#20'""@'#16#0#0#17#20'""@' - +'0'#0#0'34""@0'#0#0'34""@'#16#0#0#0#20'""@'#16#0#0#0#20'""@0'#0#0#0'4""@4DDD' - +'4"!330333B!330333B$330'#0'33'#18'!334333B"""""""""@'#17#17#17#17#20'""@'#17 - +#17#17#17#20'""@33334""@33334""@'#20#0#0#4#20'""@'#20#0#0#4#20'""@4'#0#0#4'4' - +'""@4'#0#0#4'4""@'#17#17#17#17#20'""@'#17#17#17#17#20'""@33334""@33334""@'#16 - +#1#0#1#20'""@'#16#1#0#1#20'""@0'#3#0#3'4""@0'#3#0#3'4""@'#16#0#0#0#20'""@'#16 - +#0#0#0#20'""@0'#0#0#0'4""@4DDD4"!33'#0#3'33B!33'#0#3'33B$33'#0#0#3'3'#18'!33' - +'DC33B"""""""""@'#17#17#17#17#20'""@'#17#17#17#17#20'""@33334""@33334""@'#20 - +#0#0#4#20'""@'#20#0#0#4#20'""@4'#0#0#4'4""@4'#0#0#4'4""@'#17#17#17#17#20'""@' - +#17#17#17#17#20'""@33334""@33334""@'#17#17#16#0#20'""@'#17#17#16#0#20'""@330' - +#0'4""@330'#0'4""@'#16#0#0#0#20'""@'#16#0#0#0#20'""@0'#0#0#0'4""@4DDD4"!30'#0 - +#0'33B!30'#0#0'33B$30'#0#0#0'3'#18'!34DD33B"""""""""@'#17#17#17#17#20'""@'#17 - +#17#17#17#20'""@33334""@33334""@'#17#0#0#1#20'""@'#17#0#0#1#20'""@3'#0#0#3'4' - +'""@3'#0#0#3'4""@'#17#17#17#17#20'""@'#17#17#17#17#20'""@33334""@33334""@'#17 - +#17#17#0#20'""@'#17#17#17#0#20'""@333'#0'4""@333'#0'4""@'#16#0#0#0#20'""@'#16 - +#0#0#0#20'""@0'#0#0#0'4""@4DDD4"!3'#0#0#0#3'3B!3'#0#0#0#3'3B$333333'#18'!3DD' - +'DC3B""""""""" A'#17#17#17'B"" A'#17#17#17'B"" C333B"" C333B"" A'#20'D'#17'B' - +'"" A'#20'D'#17'B"" C4D3B"" C4D3B""@'#17#17#17#17#20'""@'#17#17#17#17#20'""@' - +'33334""@33334""@'#17#17#17#16#20'""@'#17#17#17#16#20'""@33304""@33304""@'#16 - +#0#0#0#20'""@'#16#0#0#0#20'""@0'#0#0#0'4""@4DDD4"!333333B!333333B$333333'#18 - +'!333333B"""""""""$'#4#17#17#16'B""$'#4#17#17#16'B""$'#4'330B""$'#4'330B""$' - +#4#17#17#16'B""$'#4#17#17#16'B""$'#4'330B""$'#4'330B""@'#17#17#17#17#20'""@' - +#17#17#17#17#20'""@33334""@33334""@'#17#17#17#17#20'""@'#17#17#17#17#20'""@3' - +'3334""@33334""@'#17#17#17#17#20'""@'#17#17#17#17#20'""@33334""@33334"!33333' - +'3B!333333B$333333'#18'!333333B""""""""""@'#0#0#4'""""@'#0#0#4'""""@'#0#0#4 - +'""""@'#0#0#4'""""@'#0#0#4'""""@'#0#0#4'""""@'#0#0#4'""""@'#0#0#4'"""@'#0#0#0 - +#0#4'""@'#0#0#0#0#4'""@'#0#0#0#0#4'""@'#0#0#0#0#4'""@'#0#0#0#0#4'""@'#0#0#0#0 - +#4'""@'#0#0#0#0#4'""@'#0#0#0#0#4'""@'#0#0#0#0#4'""@'#0#0#0#0#4'""@'#0#0#0#0#4 - +'""@'#0#0#0#0#4'"!333333B!333333B$333333'#18'!333333B"""""""""""DD""""""DD""' - +'""""DD""""""DD""""""DD""""""DD""""""DD""""""DD""""$DDDDB""$DDDDB""$DDDDB""$' - +'DDDDB""$DDDDB""$DDDDB""$DDDDB""$DDDDB""$DDDDB""$DDDDB""$DDDDB""$DDDDB"!'#17 - +#17#17#17#17#17#18'!'#17#17#17#17#17#17#18'$DDDDDDB!'#17#17#17#17#17#17#18'"' - +'"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""' - +'"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""' - +'"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""' - +'"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""' - +'"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""' - ,'""""""""""""""""""""""""' -]); -LazarusResources.Add('VT_TICK_LIGHT','BMP',[ - 'BM'#246#12#0#0#0#0#0#0'v'#0#0#0'('#0#0#0#144#1#0#0#16#0#0#0#1#0#4#0#0#0#0#0 - +#128#12#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#255#255#255#0#255#0#255#0 - +#192#192#192#0#128#128#128#0#128#0#128#0#128#128#0#0#192#192#192#0#128#128 - +#128#0#0#0#255#0#0#255#0#0#0#255#255#0#255#0#0#0#255#0#255#0#255#255#0#0#255 - +#255#255#0'"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""' - +'"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""' - +'"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""' - +'"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""' - +'"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""' - +'""""""""""""""""""""""""""""""""""""""""""""""332"""""332"""""332"""""332""' - +'"""332"""""332"""""332"""""332"""#33332""#33332""#33332""#33332""#33332""#3' - +'3332""#33332""#33332""#33332""#33332""#33332""#33332"!DDDDDDB!DDDDDDB$'#17 - +#17#17#17#17#17#18'!DDDDDDB""""""""""3'#17#17#19'""""3'#17#17#19'""""3333"""' - +'"3333""""3'#17#17#19'""""3'#17#17#19'""""3333""""3333"""4'#17#17#17#17#19'"' - +'"4'#17#17#17#17#19'""433333""433333""4'#17#17#17#17#19'""4'#17#17#17#17#19 - +'""433333""433333""4'#17#17#17#17#19'""4'#17#17#17#17#19'""433333""433333"!3' - +'33333B!333333B$333333'#18'!333333B"""""""""#A'#17#17#17'2""#A'#17#17#17'2""' - +'#C3332""#C3332""#A'#19'3'#17'2""#A'#19'3'#17'2""#C3332""#C3332""4'#17#17#17 - +#17#19'""4'#17#17#17#17#19'""433333""433333""4'#17#20#17#17#19'""4'#17#20#17 - +#17#19'""434333""434333""4'#20'DDD'#19'""4'#20'DDD'#19'""44DDD3""44DDD3"!333' - +'333B!333333B$333333'#18'!333333B"""""""""$'#17#17#17#17#19'""$'#17#17#17#17 - +#19'""$33333""$33333""$'#17'DDA'#19'""$'#17'DDA'#19'""$3DDC3""$3DDC3""4'#17 - +#17#17#17#19'""4'#17#17#17#17#19'""433333""433333""4'#17'DA'#17#19'""4'#17'D' - +'A'#17#19'""43DC33""43DC33""4'#20'DDD'#19'""4'#20'DDD'#19'""44DDD3""44DDD3"!' - +'333333B!333333B$333'#3'33'#18'!333333B"""""""""4'#17#17#17#17#19'""4'#17#17 - +#17#17#19'""433333""433333""4'#19'DDC'#19'""4'#19'DDC'#19'""43DDC3""43DDC3""' - +'4'#17#17#17#17#19'""4'#17#17#17#17#19'""433333""433333""4'#20'DD'#17#19'""4' - +#20'DD'#17#19'""44DD33""44DD33""4'#20'DDD'#19'""4'#20'DDD'#19'""44DDD3""44DD' - +'D3"!330333B!330333B$330'#0'33'#18'!334333B"""""""""4'#17#17#17#17#19'""4'#17 - +#17#17#17#19'""433333""433333""4'#19'DDC'#19'""4'#19'DDC'#19'""43DDC3""43DDC' - +'3""4'#17#17#17#17#19'""4'#17#17#17#17#19'""433333""433333""4'#20'ADA'#19'""' - +'4'#20'ADA'#19'""44CDC3""44CDC3""4'#20'DDD'#19'""4'#20'DDD'#19'""44DDD3""44D' - +'DD3"!33'#0#3'33B!33'#0#3'33B$33'#0#0#3'3'#18'!33DC33B"""""""""4'#17#17#17#17 - +#19'""4'#17#17#17#17#19'""433333""433333""4'#19'DDC'#19'""4'#19'DDC'#19'""43' - +'DDC3""43DDC3""4'#17#17#17#17#19'""4'#17#17#17#17#19'""433333""433333""4'#17 - +#17#20'D'#19'""4'#17#17#20'D'#19'""4334D3""4334D3""4'#20'DDD'#19'""4'#20'DDD' - +#19'""44DDD3""44DDD3"!30'#0#0'33B!30'#0#0'33B$30'#0#0#0'3'#18'!34DD33B""""""' - +'"""4'#17#17#17#17#19'""4'#17#17#17#17#19'""433333""433333""4'#17'DDA'#19'""' - +'4'#17'DDA'#19'""43DDC3""43DDC3""4'#17#17#17#17#19'""4'#17#17#17#17#19'""433' - +'333""433333""4'#17#17#17'D'#19'""4'#17#17#17'D'#19'""4333D3""4333D3""4'#20 - +'DDD'#19'""4'#20'DDD'#19'""44DDD3""44DDD3"!3'#0#0#0#3'3B!3'#0#0#0#3'3B$33333' - +'3'#18'!3DDDC3B"""""""""$1'#17#17#17'2""$1'#17#17#17'2""$33332""$33332""$1' - +#19'3'#17'2""$1'#19'3'#17'2""$33332""$33332""4'#17#17#17#17#19'""4'#17#17#17 - +#17#19'""433333""433333""4'#17#17#17#20#19'""4'#17#17#17#20#19'""433343""433' - +'343""4'#20'DDD'#19'""4'#20'DDD'#19'""44DDD3""44DDD3"!333333B!333333B$333333' - +#18'!333333B"""""""""#C'#17#17#20'2""#C'#17#17#20'2""#C3342""#C3342""#C'#17 - +#17#20'2""#C'#17#17#20'2""#C3342""#C3342""4'#17#17#17#17#19'""4'#17#17#17#17 - +#19'""433333""433333""4'#17#17#17#17#19'""4'#17#17#17#17#19'""433333""433333' - +'""4'#17#17#17#17#19'""4'#17#17#17#17#19'""433333""433333"!333333B!333333B$3' - +'33333'#18'!333333B""""""""""4DDC""""4DDC""""4DDC""""4DDC""""4DDC""""4DDC"""' - +'"4DDC""""4DDC"""4DDDDC""4DDDDC""4DDDDC""4DDDDC""4DDDDC""4DDDDC""4DDDDC""4DD' - +'DDC""4DDDDC""4DDDDC""4DDDDC""4DDDDC"!333333B!333333B$333333'#18'!333333B"""' - +'""""""""33""""""33""""""33""""""33""""""33""""""33""""""33""""""33""""#3333' - +'2""#33332""#33332""#33332""#33332""#33332""#33332""#33332""#33332""#33332""' - +'#33332""#33332"!'#17#17#17#17#17#17#18'!'#17#17#17#17#17#17#18'$DDDDDDB!'#17 - +#17#17#17#17#17#18'"""""""""""""""""""""""""""""""""""""""""""""""""""""""""' - +'"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""' - +'"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""' - +'"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""' - +'"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""' - +'"""""""""""""""""""""""""""""""""""""""""""' -]); -LazarusResources.Add('VT_UTILITIES','BMP',[ - 'BM6'#13#0#0#0#0#0#0'6'#4#0#0'('#0#0#0#144#0#0#0#16#0#0#0#1#0#8#0#0#0#0#0#0#9 - +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#255#255#255#0#255#0#255#0#216 - +#233#236#0#240#251#255#0'%r'#207#0'O'#145#227#0'X'#150#227#0#218#218#218#0 - +#204#204#204#0#197#197#197#0#192#192#192#0#190#190#190#0#154#154#154#0#147 - +#147#147#0#140#140#140#0#128#128#128#0'www'#0'UUU'#0'MMM'#0'BBB'#0'999'#0#128 - +'|'#255#0'PP'#255#0#147#0#214#0#255#236#204#0#198#214#239#0#214#231#231#0#144 - +#169#173#0#0#0'3'#0#0#0'f'#0#0#0#153#0#0#0#204#0#0'3'#0#0#0'33'#0#0'3f'#0#0 - +'3'#153#0#0'3'#204#0#0'3'#255#0#0'f'#0#0#0'f3'#0#0'ff'#0#0'f'#153#0#0'f'#204 - +#0#0'f'#255#0#0#153#0#0#0#153'3'#0#0#153'f'#0#0#153#153#0#0#153#204#0#0#153 - +#255#0#0#204#0#0#0#204'3'#0#0#204'f'#0#0#204#153#0#0#204#204#0#0#204#255#0#0 - +#255'f'#0#0#255#153#0#0#255#204#0'3'#0#0#0'3'#0'3'#0'3'#0'f'#0'3'#0#153#0'3' - +#0#204#0'3'#0#255#0'33'#0#0'333'#0'33f'#0'33'#153#0'33'#204#0'33'#255#0'3f'#0 - +#0'3f3'#0'3ff'#0'3f'#153#0'3f'#204#0'3f'#255#0'3'#153#0#0'3'#153'3'#0'3'#153 - +'f'#0'3'#153#153#0'3'#153#204#0'3'#153#255#0'3'#204#0#0'3'#204'3'#0'3'#204'f' - +#0'3'#204#153#0'3'#204#204#0'3'#204#255#0'3'#255'3'#0'3'#255'f'#0'3'#255#153 - +#0'3'#255#204#0'3'#255#255#0'f'#0#0#0'f'#0'3'#0'f'#0'f'#0'f'#0#153#0'f'#0#204 - +#0'f'#0#255#0'f3'#0#0'f33'#0'f3f'#0'f3'#153#0'f3'#204#0'f3'#255#0'ff'#0#0'ff' - +'3'#0'fff'#0'ff'#153#0'ff'#204#0'f'#153#0#0'f'#153'3'#0'f'#153'f'#0'f'#153 - +#153#0'f'#153#204#0'f'#153#255#0'f'#204#0#0'f'#204'3'#0'f'#204#153#0'f'#204 - +#204#0'f'#204#255#0'f'#255#0#0'f'#255'3'#0'f'#255#153#0'f'#255#204#0#204#0 - +#255#0#255#0#204#0#153#153#0#0#153'3'#153#0#153#0#153#0#153#0#204#0#153#0#0#0 - +#153'33'#0#153#0'f'#0#153'3'#204#0#153#0#255#0#153'f'#0#0#153'f3'#0#153'3f'#0 - +#153'f'#153#0#153'f'#204#0#153'3'#255#0#153#153'3'#0#153#153'f'#0#153#153#153 - +#0#153#153#204#0#153#153#255#0#153#204#0#0#153#204'3'#0'f'#204'f'#0#153#204 - +#153#0#153#204#204#0#153#204#255#0#153#255#0#0#153#255'3'#0#153#204'f'#0#153 - +#255#153#0#153#255#204#0#153#255#255#0#204#0#0#0#153#0'3'#0#204#0'f'#0#204#0 - +#153#0#204#0#204#0#153'3'#0#0#204'33'#0#204'3f'#0#204'3'#153#0#204'3'#204#0 - +#204'3'#255#0#204'f'#0#0#204'f3'#0#153'ff'#0#204'f'#153#0#204'f'#204#0#153'f' - +#255#0#204#153#0#0#204#153'3'#0#204#153'f'#0#204#153#153#0#204#153#204#0#204 - +#153#255#0#204#204#0#0#204#204'3'#0#204#204'f'#0#204#204#153#0#204#204#204#0 - +#204#204#255#0#204#255#0#0#204#255'3'#0#153#255'f'#0#204#255#153#0#204#255 - +#204#0#204#255#255#0#204#0'3'#0#255#0'f'#0#255#0#153#0#204'3'#0#0#255'33'#0 - +#255'3f'#0#255'3'#153#0#255'3'#204#0#255'3'#255#0#255'f'#0#0#255'f3'#0#204'f' - +'f'#0#255'f'#153#0#255'f'#204#0#204'f'#255#0#255#153#0#0#255#153'3'#0#255#153 - +'f'#0#255#153#153#0#255#153#204#0#255#153#255#0#255#204#0#0#255#204'3'#0#255 - +#204'f'#0#255#204#153#0#255#204#204#0#255#204#255#0#255#255'3'#0#204#255'f'#0 - +#255#255#153#0#255#255#204#0'ff'#255#0'f'#255'f'#0'f'#255#255#0#255'ff'#0#255 - +'f'#255#0#255#255'f'#0'!'#0#165#0'___'#0'www'#0#134#134#134#0#150#150#150#0 - +#203#203#203#0#178#178#178#0#215#215#215#0#221#221#221#0#227#227#227#0#234 - +#234#234#0#241#241#241#0#248#248#248#0#240#251#255#0#164#160#160#0#128#128 - +#128#0#0#0#255#0#0#255#0#0#0#255#255#0#255#0#0#0#255#0#255#0#255#255#0#0#255 - +#255#255#0#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2 - +#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2 - +#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2 - +#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2 - +#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2 - +#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2 - +#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2 - +#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#241#9#10#10 - +#10#9#241#2#2#2#2#2#2#2#2#2#241#9#10#10#10#9#241#2#2#2#2#2#2#2#2#2#2#2#2#2#2 - +#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2 - +#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2 - +#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#241#12#13#15#15 - +#15#13#12#241#2#2#2#2#2#2#2#241#12#13#15#15#15#13#12#241#2#2#2#2#2#2#2#2#2#2 - +#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2 - +#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2 - +#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#241#12#4#4#4 - +#4#4#17#14#12#241#2#2#2#2#2#241#12#4#4#4#4#4#17#14#12#241#2#2#2#2#2#2#2#2#2#2 - +#1#2#2#2#2#2#2#2#2#2#2#2#1#1#1#1#1#1#1#1#1#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2 - +#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2 - +#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#9#4#4#4#4#236 - +#4#4#17#13#9#2#2#2#2#2#9#4#4#236#4#4#4#4#17#13#9#2#2#2#2#2#2#2#2#2#236#10#1#2 - +#2#2#2#2#2#2#2#2#2#2#236#10#10#10#10#10#1#2#2#2#2#2#2#2#2#2#2#2#2#13#2#2#2#2 - +#2#2#2#2#2#2#2#13#13#13#13#13#13#13#13#13#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2 - ,#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#4#4 - +#4#4#236#236#4#4#4#15#10#2#2#2#2#2#4#4#4#236#236#4#4#4#4#15#10#2#2#2#2#2#2#2 - +#2#2#236#10#1#2#2#2#2#2#2#2#2#2#2#2#236#10#10#10#10#10#1#2#2#2#2#2#2#2#2#2#2 - +#2#13#13#13#2#2#2#2#2#2#2#2#2#2#2#13#13#13#13#13#13#13#2#2#2#2#2#2#2#2#2#2#2 - +#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2 - +#2#2#2#2#2#2#4#4#4#236#236#236#4#4#4#15#10#2#2#2#2#2#4#4#4#236#236#236#4#4#4 - +#15#10#2#2#2#2#2#2#2#2#236#10#10#10#1#2#2#2#2#2#2#2#2#2#2#2#236#10#10#10#1#2 - +#2#2#2#2#2#2#2#2#2#2#13#13#13#13#13#2#2#2#2#2#2#2#2#2#2#2#13#13#13#13#13#2#2 - +#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2 - +#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#4#4#236#236#236#236#4#4#4#15#10#2#2#2#2#2#4 - +#4#4#236#236#236#236#4#4#15#10#2#2#2#2#2#2#2#2#236#10#10#10#1#2#2#2#2#2#2#2#2 - +#2#2#2#236#10#10#10#1#2#2#2#2#2#2#2#2#2#2#13#13#13#13#13#13#13#2#2#2#2#2#2#2 - +#2#2#2#2#13#13#13#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2 - +#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#4#4#4#236#236#236#4#4 - +#4#13#9#2#2#2#2#2#4#4#4#236#236#236#4#4#4#13#9#2#2#2#2#2#2#2#236#10#10#10#10 - +#10#1#2#2#2#2#2#2#2#2#2#2#2#236#10#1#2#2#2#2#2#2#2#2#2#2#13#13#13#13#13#13#13 - +#13#13#2#2#2#2#2#2#2#2#2#2#2#13#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2 - +#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#4#4#4 - +#4#236#236#4#4#4#12#241#2#2#2#2#2#4#4#4#236#236#4#4#4#4#12#241#2#2#2#2#2#2#2 - +#236#10#10#10#10#10#1#2#2#2#2#2#2#2#2#2#2#2#236#10#1#2#2#2#2#2#2#2#2#2#2#2#2 - +#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2 - +#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2 - +#2#2#4#4#4#4#236#4#4#12#241#2#2#2#2#2#2#2#4#4#236#4#4#4#4#12#241#2#2#2#2#2#2 - +#2#236#236#236#236#236#236#236#236#1#2#2#2#2#2#2#2#2#2#2#2#1#2#2#2#2#2#2#2#2 - +#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2 - +#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2 - +#2#2#2#2#2#2#2#2#4#4#4#4#4#9#241#2#2#2#2#2#2#2#2#2#4#4#4#4#4#9#241#2#2#2#2#2 - +#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2 - +#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2 - +#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2 - +#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2 - +#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2 - +#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#3#3#5#5#5#5#5#5#5#5#5#5#5#5#5#5#5#5#5#5 - +#5#5#5#5#5#5#5#5#5#5#5#5#5#5#5#5#5#5#5#5#5#5#5#5#5#3#3#2#2#2#2#2#2#2#2#2#2#2 - +#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2 - +#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2 - +#2#2#2#2#2#2#2#2#2#2#3#5#6#6#6#6#6#6#6#6#6#6#6#6#6#6#6#6#6#6#6#6#6#6#6#6#6#6 - +#6#6#6#6#6#6#6#6#6#6#6#6#6#6#6#6#6#5#3#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2 - +#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2 - +#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2#2 - +#2#2#5#6#7#7#7#7#7#7#7#7#7#7#7#7#7#7#7#7#7#7#7#7#7#7#7#7#7#7#7#7#7#7#7#7#7#7 - +#7#7#7#7#7#7#7#7#7#6#5 -]); -LazarusResources.Add('VT_XP','BMP',[ - 'BM8K'#0#0#0#0#0#0'6'#0#0#0'('#0#0#0#144#1#0#0#16#0#0#0#1#0#24#0#0#0#0#0#0#0#0 - +#0#18#11#0#0#18#11#0#0#0#0#0#0#0#0#0#0#255#0#255#255#0#255#255#0#255#255#0 - +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 - +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 - +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 - +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 - +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 - +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 - +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 - +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 - +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 - +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 - +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 - +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 - +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 - +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 - +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 - +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 - +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 - +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 - +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 - +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 - +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 - +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 - +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 - +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 - +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 - +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 - +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 - +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 - +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 - +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 - +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 - +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 - +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 - +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 - +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 - +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 - +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 - +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 - +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 - +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 - +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 - +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 - +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 - +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 - +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 - +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 - +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 - +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 - +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 - +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 - +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 - +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 - +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 - +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 - +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 - +#255#0#255#255#0#255#255#0#255#255#0#255#238#231#223#233#224#214#231#221#211 - +#233#224#214#238#231#223#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 - +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#238#231#223#233 - +#224#214#231#221#211#233#224#214#238#231#223#255#0#255#255#0#255#255#0#255 - +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 - +#255#238#231#223#233#224#214#231#221#211#233#224#214#238#231#223#255#0#255 - +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 - ,#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 - +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 - +#255#255#0#255#255#0#255#255#0#255#238#231#223#233#224#214#231#221#211#233 - +#224#214#238#231#223#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 - +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#238#231#223#233#224 - +#214#231#221#211#233#224#214#238#231#223#255#0#255#255#0#255#255#0#255#255#0 - +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 - +#238#231#223#233#224#214#231#221#211#233#224#214#238#231#223#255#0#255#255#0 - +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 - +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 - +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 - +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 - +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 - +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 - +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 - +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 - +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 - +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 - +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 - +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 - +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 - +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 - +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 - +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 - +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 - +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 - +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 - +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 - +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 - +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 - +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 - +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 - +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 - +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 - +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 - +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 - +#255#255#0#255#255#0#255#255#0#255#255#0#255#225#217#237'_'#140'y#oL'#6'b7'#6 - +'b7'#6'b7'#6'b7'#6'b7'#6'b7'#6'b7'#6'b7'#6'b7'#24'iDX'#138't'#238#244#250#255 - +#0#255#236#216#223'_'#140'y#oL'#6'b7'#6'b7'#6'b7'#6'b7'#6'b7'#6'b7'#6'b7'#6 - +'b7'#6'b7'#24'iDX'#138't'#248#241#243#255#0#255#225#217#237'_'#140'y#oL'#6'b' - +'7'#6'b7'#6'b7'#6'b7'#6'b7'#6'b7'#6'b7'#6'b7'#6'b7'#24'iDX'#138't'#238#244 - +#250#255#0#255#255#255#255#184#196#202#184#196#202#184#196#202#184#196#202 - +#184#196#202#184#196#202#184#196#202#184#196#202#184#196#202#184#196#202#184 - +#196#202#184#196#202#184#196#202#255#255#255#255#0#255#255#0#255#255#0#255 - +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 - +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 - +#255#0#255#226#214#201#220#206#191#217#202#186#216#201#184#217#202#186#220 - +#206#191#226#214#201#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 - +#255#255#0#255#255#0#255#255#0#255#224#212#198#217#201#185#213#196#178#211 - +#194#175#213#196#178#217#201#185#224#212#198#255#0#255#255#0#255#255#0#255 - +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#226#214#201#220 - +#206#191#217#202#186#216#201#184#217#202#186#220#206#191#226#214#201#255#0 - +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 - +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 - +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 - +#255#0#255#255#0#255#226#214#201#220#206#191#217#202#186#216#201#184#217#202 - +#186#220#206#191#226#214#201#255#0#255#255#0#255#255#0#255#255#0#255#255#0 - +#255#255#0#255#255#0#255#255#0#255#255#0#255#226#214#201#220#206#191#217#202 - +#186#216#201#184#217#202#186#220#206#191#226#214#201#255#0#255#255#0#255#255 - +#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#226#214 - +#201#220#206#191#217#202#186#216#201#184#217#202#186#220#206#191#226#214#201 - +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 - +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 - +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 - ,#255'V'#17#0'V'#17#0'U'#19#0'U'#16#0'V'#17#0'R'#14#1'W'#16#2'T'#18#0'U'#15#2 - +'U'#16#0'W'#18#0'T'#18#0'V'#17#0#255#0#255#255#0#255#255#0#255'W'#19#0'W'#18 - +#1'Y'#19#2'^'#18#0'W'#20#0'V'#18#0'W'#18#1'V'#17#0'W'#19#0'X'#17#3'U'#21#0'Z' - +#21#2'X'#18#1#255#0#255#255#0#255#255#0#255'V'#19#0'T'#19#4'W'#18#1'W'#18#1 - +'Z'#18#0'X'#19#0'W'#17#0'W'#18#0'Z'#18#1'X'#19#0'V'#22#0'W'#18#0'X'#20#1#255 - +#0#255#255#0#255#255#0#255#168#183#185#170#183#185#171#184#186#169#184#186 - +#168#183#185#170#183#185#169#182#184#168#183#185#169#184#187#170#183#185#171 - +#184#186#168#183#185#168#183#185#255#0#255#255#0#255#255#0#255'W'#18#0'U'#18 - +#3'R'#19#0'V'#18#0'U'#19#0'U'#15#0'U'#19#0'T'#18#0'S'#17#0'Y'#17#0'T'#18#0'U' - +#16#1'V'#19#0#255#0#255#255#0#255#255#0#255'U'#17#4'Y'#20#0'W'#20#0'Y'#16#2 - +'U'#17#0'Z'#17#3'V'#15#1'Z'#19#0'U'#19#1'U'#17#0'X'#18#1'X'#20#1'Y'#17#0#255 - +#0#255#255#0#255#255#0#255'X'#19#0'U'#19#0'X'#18#1'W'#20#0'U'#16#1'X'#19#0'X' - +#18#1'U'#19#0'Y'#17#0'X'#21#0'V'#18#0'U'#19#0'Y'#20#1#255#0#255#255#0#255#255 - +#0#255#168#183#185#170#183#185#171#183#183#170#183#185#171#184#186#169#182 - +#184#170#183#185#169#185#184#169#182#184#170#183#185#168#183#185#167#182#184 - +#170#183#185#255#0#255#255#0#255#255#0#255'W'#18#0'U'#18#3'R'#19#0'V'#18#0'U' - +#19#0'U'#15#0'U'#19#0'T'#18#0'S'#17#0'Y'#17#0'T'#18#0'U'#16#1'V'#19#0#255#0 - +#255#255#0#255#255#0#255'U'#17#4'Y'#20#0'W'#20#0'Y'#16#2'U'#17#0'Z'#17#3'V' - +#15#1'Z'#19#0'U'#19#1'U'#17#0'X'#18#1'X'#20#1'Y'#17#0#255#0#255#255#0#255#255 - +#0#255'X'#19#0'U'#19#0'X'#18#1'W'#20#0'U'#16#1'X'#19#0'X'#18#1'U'#19#0'Y'#17 - +#0'X'#21#0'V'#18#0'U'#19#0'Y'#20#1#255#0#255#255#0#255#255#0#255#168#183#185 - +#170#183#185#171#183#183#170#183#185#171#184#186#169#182#184#170#183#185#169 - +#185#184#169#182#184#170#183#185#168#183#185#167#182#184#170#183#185#255#0 - +#255#255#0#255#255#0#255'N'#131'lD}c'#152#178#199#184#209#227#184#209#227#184 - +#209#227#184#209#227#184#209#227#184#209#227#184#209#227#183#209#226#182#208 - +#226#164#177#201'B|aU'#136'r'#255#0#255'N'#131'ludu%r'#207'%r'#207'%r'#207'%' - +'r'#207'%r'#207'%r'#207'%r'#207'%r'#207'%r'#207'%r'#207'%r'#207'rbsU'#136'r' - +#255#0#255'N'#131'lG'#130'f'#166#203#216#226#243#246#228#244#248#228#244#248 - +#228#244#248#228#244#248#228#244#248#228#244#248#228#245#248#229#245#248#190 - +#218#228'H'#132'iU'#136'r'#255#0#255#184#196#202#201#211#217#221#231#235#233 - +#242#246#233#242#246#233#242#246#233#242#246#233#242#246#233#242#246#233#242 - +#246#233#242#246#233#242#246#225#235#239#201#211#217#184#196#202#255#0#255 - +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 - +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 - +#255#0#255#255#0#255#223#210#196#185#153#131#154'jN'#129'D#q,'#8#129'D#'#154 - +'jN'#185#153#131#223#210#196#255#0#255#255#0#255#255#0#255#255#0#255#255#0 - +#255#255#0#255#255#0#255#220#205#190#181#147'{'#151'eHA'#31'q,'#7'A'#31#151 - +'eH'#181#147'{'#220#205#190#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 - +#255#0#255#255#0#255#223#210#196#185#153#131#154'jN'#129'D#q,'#8#129'D#'#154 - +'jN'#185#153#131#223#210#196#255#0#255#255#0#255#255#0#255#255#0#255#255#0 - +#255#255#0#255#255#0#255#255#0#255#255#0#255#213#221#222#197#208#210#188#200 - +#203#197#208#210#213#221#222#233#237#238#255#0#255#255#0#255#255#0#255#255#0 - +#255#255#0#255#255#0#255#255#0#255#255#0#255#223#210#196#185#153#131#154'jN' - +#129'D#q,'#8#129'D#'#154'jN'#185#153#131#223#210#196#255#0#255#255#0#255#255 - +#0#255#255#0#255#255#0#255#255#0#255#255#0#255#223#210#196#185#153#131#154'j' - +'N'#129'D#q,'#8#129'D#'#154'jN'#185#153#131#223#210#196#255#0#255#255#0#255 - +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#223#210#196#185#153#131 - +#154'jN'#129'D#q,'#8#129'D#'#154'jN'#185#153#131#223#210#196#255#0#255#255#0 - +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 - +#208#216#215#190#201#199#180#192#190#190#201#199#208#216#215#230#234#234#255 - +#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255'V'#17#0 - +#244#249#247#248#247#251#248#248#248#248#248#248#251#249#249#247#248#246#248 - +#248#248#247#249#249#248#248#248#245#247#248#248#247#249'V'#17#0#255#0#255 - +#255#0#255#255#0#255'U'#20#0#136#195#251#132#193#249#130#194#248#135#195#249 - +#135#195#249#132#199#244#138#195#250#132#196#244#136#191#252#130#195#246#132 - +#197#248'X'#20#0#255#0#255#255#0#255#255#0#255'Z'#18#0#201#210#213#197#211 - +#210#198#210#210#198#210#214#196#208#208#198#212#211#198#209#213#199#211#213 - +#198#209#213#197#211#210#200#213#211'V'#20#2#255#0#255#255#0#255#255#0#255 - +#167#182#184#226#239#241#227#239#241#225#238#240#225#238#240#225#237#239#226 - +#239#241#225#238#240#225#238#240#226#238#240#226#238#240#227#240#242#169#182 - +#184#255#0#255#255#0#255#255#0#255'V'#17#0#251#249#248#250#248#247#245#247 - +#247#244#250#245#248#249#247#250#248#248#248#247#249#247#249#250#247#246#248 - +#250#248#247#249#247#246'V'#17#2#255#0#255#255#0#255#255#0#255'X'#18#1#133 - +#196#246#130#194#249#132#195#245#137#196#246#138#196#248#135#198#248#132#197 - ,#248#136#196#250#133#192#248#136#196#250#132#195#246'Z'#20#0#255#0#255#255#0 - +#255#255#0#255'W'#18#1#197#213#212#198#210#216#197#210#208#199#210#214#199 - +#211#213#196#208#212#200#210#210#192#210#209#197#209#211#200#211#215#199#211 - +#213'X'#18#1#255#0#255#255#0#255#255#0#255#170#183#185#227#239#239#227#237 - +#237#226#238#238#226#238#240#227#239#241#225#237#239#226#240#239#227#239#241 - +#227#239#241#225#238#240#226#239#241#171#184#186#255#0#255#255#0#255#255#0 - +#255'V'#17#0#251#249#248#250#248#247#245#247#247#244#250#245#248#249#247#250 - +#248#248#248#247#249#247#249#250#247#246#248#250#248#247#249#247#246'V'#17#2 - +#255#0#255#255#0#255#255#0#255'X'#18#1#133#196#246#130#194#249#132#195#245 - +#137#196#246#138#196#248#135#198#248#132#197#248#136#196#250#133#192#248#136 - +#196#250#132#195#246'Z'#20#0#255#0#255#255#0#255#255#0#255'W'#18#1#197#213 - +#212#198#210#216#197#210#208#199#210#214#199#211#213#196#208#212#200#210#210 - +#192#210#209#197#209#211#200#211#215#199#211#213'X'#18#1#255#0#255#255#0#255 - +#255#0#255#170#183#185#227#239#239#227#237#237#226#238#238#226#238#240#227 - +#239#241#225#237#239#226#240#239#227#239#241#227#239#241#225#238#240#226#239 - +#241#171#184#186#255#0#255#255#0#255#255#0#255#24'iD'#179#200#215#201#225#236 - +#200#224#234#200#224#235#201#225#236#201#225#236#201#225#236#201#225#236#201 - +#225#236#200#224#235#198#221#234#193#216#230#170#185#205#24'iD'#255#0#255#24 - +'iDc'#153#221'O'#145#227'O'#145#227'N'#144#227'O'#145#227'O'#145#227'O'#145 - +#227'O'#145#227'O'#145#227'O'#145#227'O'#145#227'O'#145#227'a'#152#219#24'iD' - +#255#0#255#24'iD'#176#196#212#211#233#238#216#236#242#217#237#242#217#237#242 - +#216#236#242#216#236#242#216#236#242#217#237#242#217#237#242#219#238#243#221 - +#238#244#183#208#222#24'iD'#255#0#255#184#196#202#225#235#239#233#242#246#233 - +#242#246#233#242#246#233#242#246#233#242#246#233#242#246#233#242#246#233#242 - +#246#233#242#246#233#242#246#233#242#246#225#235#239#184#196#202#255#0#255 - +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 - +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 - +#255#0#255#213#195#179#162'v['#150'dH'#192#162#143#228#215#207#249#247#245 - +#228#215#207#192#162#143#150'dH'#162'v['#213#195#179#255#0#255#255#0#255#255 - +#0#255#255#0#255#255#0#255#210#190#173#158'pT'#129'g`~'#147#176'q'#167#223'c' - +#171#243'q'#167#223'~'#147#176#129'g`'#158'pT'#210#190#173#255#0#255#255#0 - +#255#255#0#255#255#0#255#255#0#255#213#195#179#162'v['#150'kR'#180#161#147 - +#196#192#187#200#203#203#196#192#187#180#161#147#150'kR'#162'v['#213#195#179 - +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#217#224#226#208 - +#217#219#228#233#234#244#246#247#254#254#254#244#246#247#228#233#234#208#217 - +#219#217#224#226#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 - +#213#195#179#162'v['#150'dH'#192#162#143#228#215#207#249#247#245#228#215#207 - +#192#162#143#150'dH'#162'v['#213#195#179#255#0#255#255#0#255#255#0#255#255#0 - +#255#255#0#255#213#195#179#162'v['#150'dH'#192#162#143#228#215#207#249#247 - +#245#228#215#207#192#162#143#150'dH'#162'v['#213#195#179#255#0#255#255#0#255 - +#255#0#255#255#0#255#255#0#255#213#195#179#162'v['#150'dH'#192#162#143#228 - +#215#207#249#247#245#228#215#207#192#162#143#150'dH'#162'v['#213#195#179#255 - +#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#213#220#219#203#212 - +#210#225#230#229#243#245#245#253#254#254#243#245#245#225#230#229#203#212#210 - +#213#220#219#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255'V' - +#17#0#246#248#249#248#248#248#246#249#247#248#248#248#249#247#247#249#248#250 - +#246#248#249#250#248#248#246#248#248#248#249#247#249#249#249'V'#17#0#255#0 - +#255#255#0#255#255#0#255'Y'#20#1#129#195#246#248#248#248#244#249#247#245#247 - +#247#249#248#252#249#246#248#250#249#245#244#249#248#248#247#249#250#248#248 - +#133#196#246'W'#18#3#255#0#255#255#0#255#255#0#255'W'#18#1#197#209#213#195 - +#208#210#196#205#209#194#204#211#194#205#209#196#205#209#193#207#206#194#206 - +#208#195#208#210#195#207#209#199#210#214'W'#18#1#255#0#255#255#0#255#255#0 - +#255#170#183#185#224#237#239#225#237#239#225#237#239#224#236#238#225#237#239 - +#224#236#238#223#236#238#225#237#239#224#236#238#224#236#236#226#238#238#170 - +#183#185#255#0#255#255#0#255#255#0#255'T'#18#0#245#247#247#248#248#248#248 - +#248#248#245#248#252#251#247#252#248#247#249#250#248#247#246#248#248#248#249 - +#245#246#248#248#243#248#246'V'#17#0#255#0#255#255#0#255#255#0#255'X'#19#0 - +#134#197#248#250#249#245#245#247#247#244#249#248#244#249#247#251#247#252#246 - +#248#248#246#250#245#246#248#248#249#247#247#132#196#250'W'#19#0#255#0#255 - +#255#0#255#255#0#255'X'#21#0#199#210#214#195#205#212#197#209#211#202#208#207 - +#196#209#211#203#208#211#196#205#209#194#207#209#202#205#213#194#206#210#200 - +#213#215'Z'#18#0#255#0#255#255#0#255#255#0#255#168#183#186#224#237#239#225 - +#237#237#225#237#237#225#237#239#227#239#241#227#239#241#225#238#240#224#236 - +#238#224#236#238#227#239#241#226#239#241#169#182#184#255#0#255#255#0#255#255 - ,#0#255'T'#18#0#245#247#247#248#248#248#248#248#248#245#248#252#251#247#252 - +#248#247#249#250#248#247#246#248#248#248#249#245#246#248#248#243#248#246'V' - +#17#0#255#0#255#255#0#255#255#0#255'X'#19#0#134#197#248#250#249#245#245#247 - +#247#244#249#248#244#249#247#251#247#252#246#248#248#246#250#245#246#248#248 - +#249#247#247#132#196#250'W'#19#0#255#0#255#255#0#255#255#0#255'X'#21#0#199 - +#210#214#195#205#212#197#209#211#202#208#207#196#209#211#203#208#211#196#205 - +#209#194#207#209#202#205#213#194#206#210#200#213#215'Z'#18#0#255#0#255#255#0 - +#255#255#0#255#168#183#186#224#237#239#225#237#237#225#237#237#225#237#239 - +#227#239#241#227#239#241#225#238#240#224#236#238#224#236#238#227#239#241#226 - +#239#241#169#182#184#255#0#255#255#0#255#255#0#255#6'b7'#225#243#246#224#243 - +#246#224#243#246#224#243#246#224#243#246#224#243#246#224#243#246#224#243#246 - +#224#243#246#224#243#246#222#241#246#214#235#242#204#228#238#6'b7'#255#0#255 - +#6'b7X'#150#227'X'#150#227#224#242#245#224#242#245#224#242#245#224#242#245 - +#224#242#245#224#242#245#224#242#245#224#242#245#222#240#245'X'#150#227'V' - +#149#227#6'b7'#255#0#255#6'b7'#190#213#227#197#220#231#201#225#234#202#226 - +#234#202#226#234#202#226#234#202#226#234#202#226#234#202#226#234#202#226#234 - +#203#227#235#206#228#236#207#229#237#6'b7'#255#0#255#184#196#202#233#242#246 - +#233#242#246#233#242#246#233#242#246#233#242#246#233#242#246#233#242#246#233 - +#242#246#233#242#246#233#242#246#233#242#246#233#242#246#233#242#246#184#196 - +#202#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 - +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 - +#255#255#0#255#226#214#201#161'tY'#178#141'v'#249#248#245#255#255#255#255#255 - +#255#255#255#255#255#255#255#255#255#255#249#248#245#178#141'v'#161'tY'#226 - +#214#201#255#0#255#255#0#255#255#0#255#224#212#198#158'pT'#136#135#143'~'#180 - +#234#179#210#240#223#235#247#250#250#251#223#235#247#179#210#240'~'#180#234 - +#136#135#143#158'pT'#224#212#198#255#0#255#255#0#255#255#0#255#226#214#201 - +#161'tY'#173#144'}'#207#210#209#202#206#207#202#206#207#202#206#207#202#206 - +#207#202#206#207#207#210#209#173#144'}'#161'tY'#226#214#201#255#0#255#255#0 - +#255#255#0#255#255#0#255#217#224#226#224#229#231#254#254#254#255#255#255#255 - +#255#255#255#255#255#255#255#255#255#255#255#254#254#254#224#229#231#217#224 - +#226#255#0#255#255#0#255#255#0#255#255#0#255#226#214#201#161'tY'#178#141'v' - +#248#245#242#247#243#240#237#230#223#233#225#215#237#230#223#247#243#240#248 - +#245#242#178#141'v'#161'tY'#226#214#201#255#0#255#255#0#255#255#0#255#226#214 - +#201#161'tY'#178#141'v'#248#245#242#247#243#240#237#230#223#233#225#215#237 - +#230#223#247#243#240#248#245#242#178#141'v'#161'tY'#226#214#201#255#0#255#255 - +#0#255#255#0#255#226#214#201#161'tY'#178#141'v'#248#245#242#247#243#240#237 - +#230#223#233#225#215#237#230#223#247#243#240#248#245#242#178#141'v'#161'tY' - +#226#214#201#255#0#255#255#0#255#255#0#255#255#0#255#213#220#219#220#226#225 - +#254#254#254#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#254 - +#254#254#220#226#225#213#220#219#255#0#255#255#0#255#255#0#255#255#0#255#255 - +#0#255'V'#17#0#246#248#249#248#249#247#250#247#249#249#248#250#250#246#245 - +#246#248#249#250#248#247#246#248#248#250#247#249#249#249#249#249#248#250'V' - +#17#0#255#0#255#255#0#255#255#0#255'X'#19#2#133#193#247#249#249#249#252#247 - +#248#250#248#247#247#248#246#252#247#249#243#248#247#248#249#247#248#248#248 - +#249#250#246#130#194#249'['#19#1#255#0#255#255#0#255#255#0#255'V'#17#0#195 - +#210#213#195#207#207#194#204#204#193#206#204#195#206#203#197#205#204#193#204 - +#208#194#205#209#192#204#208#196#208#208#198#209#213'Z'#19#0#255#0#255#255#0 - +#255#255#0#255#168#183#185#224#237#239#226#238#240#224#236#238#224#236#238 - +#224#236#238#225#237#239#223#236#238#224#236#238#225#237#239#225#237#237#225 - +#237#239#171#184#186#255#0#255#255#0#255#255#0#255'U'#15#2#245#251#246#250 - +#246#251#249#249#249#247#247#247#2#134#0#248#247#249#244#249#247#247#249#250 - +#246#245#247#252#248#247#250#246#251'V'#18#0#255#0#255#255#0#255#255#0#255'X' - +#20#1#135#191#250#248#247#249#250#246#251#246#248#248#0#135#0#247#247#247#249 - +#246#248#247#250#248#248#247#249#247#248#246#129#195#248'X'#19#0#255#0#255 - +#255#0#255#255#0#255'W'#18#3#196#210#209#200#208#208#203#210#207#200#208#215 - +#0'e'#3#205#208#216#198#207#211#198#204#209#193#206#204#194#207#215#197#211 - +#210'Y'#20#0#255#0#255#255#0#255#255#0#255#169#184#187#227#239#241#225#237 - +#237#226#238#238#228#240#242#161#173#175#226#238#240#227#239#241#225#238#240 - +#225#237#239#224#237#239#224#237#239#171#184#186#255#0#255#255#0#255#255#0 - +#255'U'#15#2#245#251#246#250#246#251#0#139#0#0#139#0#0#139#0#0#139#0#0#139#0 - +#0#139#0#0#139#0#252#248#247#250#246#251'V'#18#0#255#0#255#255#0#255#255#0 - +#255'X'#20#1#135#191#250#248#247#249#0#139#0#0#139#0#0#139#0#0#139#0#0#139#0 - +#0#139#0#0#139#0#247#248#246#129#195#248'X'#19#0#255#0#255#255#0#255#255#0 - +#255'W'#18#3#196#210#209#200#208#208#0#139#0#0#139#0#0#139#0#0#139#0#0#139#0 - ,#0#139#0#0#139#0#194#207#215#197#211#210'Y'#20#0#255#0#255#255#0#255#255#0 - +#255#169#184#187#227#239#241#225#237#237#163#176#178#163#176#178#163#176#178 - +#163#176#178#163#176#178#163#176#178#163#176#178#224#237#239#224#237#239#171 - +#184#186#255#0#255#255#0#255#255#0#255#6'b7'#226#244#247#226#244#247#225#243 - +#246#225#243#246#225#243#246#225#243#246#154#154#154#225#243#246#225#243#246 - +#225#243#246#223#242#246#216#237#242#207#228#238#6'b7'#255#0#255#6'b7\'#153 - +#228']'#154#229#225#242#245#225#242#245#225#242#245#225#242#245#154#154#154 - +#225#242#245#225#242#245#225#242#245#223#241#245'\'#153#228'\'#153#228#6'b7' - +#255#0#255#6'b7'#189#212#226#196#219#230#201#225#234#202#226#234#202#226#234 - +#202#226#234#154#154#154#202#226#234#202#226#234#202#226#234#203#226#234#204 - +#228#236#206#228#236#6'b7'#255#0#255#184#196#202#233#242#246#233#242#246#233 - +#242#246#233#242#246#233#242#246#233#242#246#154#154#154#233#242#246#233#242 - +#246#233#242#246#233#242#246#233#242#246#233#242#246#184#196#202#255#0#255 - +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 - +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 - +#185#153#131#147'_A'#241#236#229#255#255#255#255#255#255#255#255#255#255#255 - +#255#255#255#255#255#255#255#255#255#255#241#236#229#147'_A'#185#153#131#255 - +#0#255#255#0#255#255#0#255#183#150''#128'f^{'#176#228#220#228#236#254#254 - +#253#255#255#255#255#255#255#255#255#255#254#254#253#220#228#236'{'#176#228 - +#128'f^'#183#150''#255#0#255#255#0#255#255#0#255#185#153#131#147'fL'#202#203 - +#199#202#206#207#202#206#207#202#206#207#202#206#207#202#206#207#202#206#207 - +#202#206#207#202#203#199#147'fL'#185#153#131#255#0#255#255#0#255#255#0#255 - +#233#237#238#208#217#219#254#254#254#255#255#255#255#255#255#255#255#255#255 - +#255#255#255#255#255#255#255#255#255#255#255#254#254#254#208#217#219#255#0 - +#255#255#0#255#255#0#255#255#0#255#185#153#131#147'_A'#241#236#229#247#243 - +#240#227#216#204#214#198#181#211#194#175#214#198#181#227#216#204#247#243#240 - +#241#236#229#147'_A'#185#153#131#255#0#255#255#0#255#255#0#255#185#153#131 - +#147'_A'#241#236#229#247#243#240#227#216#204#214#198#181#211#194#175#214#198 - +#181#227#216#204#247#243#240#241#236#229#147'_A'#185#153#131#255#0#255#255#0 - +#255#255#0#255#185#153#131#147'_A'#241#236#229#247#243#240#227#216#204#214 - +#198#181#211#194#175#214#198#181#227#216#204#247#243#240#241#236#229#147'_A' - +#185#153#131#255#0#255#255#0#255#255#0#255#230#234#234#203#212#210#254#254 - +#254#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 - +#255#255#255#254#254#254#203#212#210#230#234#234#255#0#255#255#0#255#255#0 - +#255#255#0#255'V'#17#0#246#248#248#248#249#247#246#248#248#250#248#247#249 - +#250#246#246#248#249#250#248#248#245#248#246#248#249#247#248#249#247#249#247 - +#247'V'#17#0#255#0#255#255#0#255#255#0#255'S'#16#1#130#196#245#244#246#246 - +#252#249#245#248#248#248#244#249#247#250#248#248#248#247#249#248#248#248#250 - +#248#247#246#248#248#131#197#246'X'#19#0#255#0#255#255#0#255#255#0#255'W'#18 - +#0#198#209#213#195#208#210#201#206#207#199#204#205#195#204#207#197#205#204 - +#193#205#205#196#204#204#197#204#207#197#206#209#197#209#213'X'#20#1#255#0 - +#255#255#0#255#255#0#255#167#182#184#224#237#239#224#236#238#224#236#238#224 - +#237#239#223#235#237#226#238#240#223#236#238#225#237#239#224#236#238#224#237 - +#239#228#240#242#170#183#185#255#0#255#255#0#255#255#0#255'V'#15#1#245#250 - +#248#248#248#248#249#247#246#1#137#1#0#141#2#0#135#0#246#248#249#251#248#243 - +#249#249#249#250#247#249#246#247#251'W'#17#0#255#0#255#255#0#255#255#0#255'Y' - +#17#0#130#194#248#252#247#248#251#250#246#0#135#0#1#135#0#3#134#0#248#249#247 - +#245#247#247#245#247#248#247#249#249#134#193#249'Z'#18#0#255#0#255#255#0#255 - +#255#0#255'Z'#19#0#198#211#213#198#208#215#202#209#212#2'e'#1#1'j'#3#2'f'#0 - +#204#209#212#196#209#211#195#204#208#195#207#209#196#210#208'X'#18#1#255#0 - +#255#255#0#255#255#0#255#169#184#186#224#237#239#226#238#238#227#239#239#163 - +#175#177#165#177#179#164#176#178#227#239#241#225#238#240#226#238#240#224#236 - +#238#227#239#241#170#183#185#255#0#255#255#0#255#255#0#255'V'#15#1#245#250 - +#248#248#248#248#0#139#0#0#139#0#0#139#0#0#139#0#0#139#0#0#139#0#0#139#0#250 - +#247#249#246#247#251'W'#17#0#255#0#255#255#0#255#255#0#255'Y'#17#0#130#194 - +#248#252#247#248#0#139#0#0#139#0#0#139#0#0#139#0#0#139#0#0#139#0#0#139#0#247 - +#249#249#134#193#249'Z'#18#0#255#0#255#255#0#255#255#0#255'Z'#19#0#198#211 - +#213#198#208#215#0#139#0#0#139#0#0#139#0#0#139#0#0#139#0#0#139#0#0#139#0#195 - +#207#209#196#210#208'X'#18#1#255#0#255#255#0#255#255#0#255#169#184#186#224 - +#237#239#226#238#238#163#176#178#163#176#178#163#176#178#163#176#178#163#176 - +#178#163#176#178#163#176#178#224#236#238#227#239#241#170#183#185#255#0#255 - +#255#0#255#255#0#255#6'b7'#227#245#248#227#245#248#226#244#247#226#244#247 - +#226#244#247#154#154#154#154#154#154#154#154#154#226#244#247#226#244#247#225 - +#243#246#217#238#243#208#229#238#6'b7'#255#0#255#6'b7c'#158#229'c'#158#229 - ,#226#243#246#226#243#246#226#243#246#154#154#154#154#154#154#154#154#154#226 - +#243#246#226#243#246#225#242#245'c'#158#229'b'#157#229#6'b7'#255#0#255#6'b7' - +#189#211#227#197#219#231#202#225#234#203#226#235#203#226#235#154#154#154#154 - +#154#154#154#154#154#203#226#235#203#226#235#204#226#235#206#227#236#206#228 - +#237#6'b7'#255#0#255#184#196#202#233#242#246#233#242#246#233#242#246#233#242 - +#246#233#242#246#154#154#154#154#154#154#154#154#154#233#242#246#233#242#246 - +#233#242#246#233#242#246#233#242#246#184#196#202#255#0#255#255#0#255#255#0 - +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 - +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#152'hK'#181#147 - +'}'#250#247#245#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 - +#255#255#255#255#255#255#250#247#245#181#147'}'#152'hK'#255#0#255#255#0#255 - +#255#0#255#151'eHz'#143#170#170#196#223#250#248#246#255#255#255#255#255#255 - +#255#255#255#255#255#255#255#255#255#250#248#246#170#196#223'z'#143#170#151 - +'eH'#255#0#255#255#0#255#255#0#255#152'hK'#172#150#134#199#202#202#202#206 - +#207#202#206#207#202#206#207#202#206#207#202#206#207#202#206#207#202#206#207 - +#199#202#202#172#150#134#152'hK'#255#0#255#255#0#255#255#0#255#213#221#222 - +#228#233#234#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 - +#255#255#255#255#255#255#255#255#255#255#255#228#233#234#213#221#222#255#0 - +#255#255#0#255#255#0#255#152'hK'#181#147'}'#250#247#245#237#230#223#170#187 - +#145'V'#162'K'#24#148#28'V'#162'K'#170#187#145#237#230#223#250#247#245#181 - +#147'}'#152'hK'#255#0#255#255#0#255#255#0#255#152'hK'#181#147'}'#250#247#245 - +#237#230#223#170#187#145'V'#162'K'#24#148#28'V'#162'K'#170#187#145#237#230 - +#223#250#247#245#181#147'}'#152'hK'#255#0#255#255#0#255#255#0#255#152'hK'#181 - +#147'}'#250#247#245#237#230#223#170#187#145'V'#162'K'#24#148#28'V'#162'K'#170 - +#187#145#237#230#223#250#247#245#181#147'}'#152'hK'#255#0#255#255#0#255#255#0 - +#255#208#216#215#225#230#229#255#255#255#255#255#255#238#241#241#207#215#214 - +#183#195#193#207#215#214#238#241#241#255#255#255#255#255#255#225#230#229#208 - +#216#215#255#0#255#255#0#255#255#0#255#255#0#255'V'#17#0#245#244#246#244#243 - +#245#246#244#244#241#245#246#251#246#247#248#248#248#248#247#249#248#248#248 - +#247#246#248#250#248#248#246#249#247'V'#17#0#255#0#255#255#0#255#255#0#255'Z' - +#18#0#129#193#248#247#246#248#244#246#246#246#245#249#249#249#249#243#248#247 - +#253#248#250#246#248#249#252#247#248#247#249#249#133#194#250'V'#19#0#255#0 - +#255#255#0#255#255#0#255'X'#18#1#195#209#208#193#205#205#194#203#206#193#205 - +#205#194#204#204#193#206#204#196#203#206#193#206#204#195#204#208#195#206#210 - +#198#210#212'X'#19#0#255#0#255#255#0#255#255#0#255#168#183#185#225#238#240 - +#225#237#239#224#237#239#222#235#237#224#236#238#224#236#238#224#236#238#224 - +#236#238#224#236#238#223#236#238#226#238#240#171#184#186#255#0#255#255#0#255 - +#255#0#255'T'#17#2#246#248#249#254#246#246#3#136#2#0#139#0#0#137#0#0#140#0#4 - +#136#0#247#248#246#249#248#250#251#249#249#245#249#244'W'#18#0#255#0#255#255 - +#0#255#255#0#255'W'#18#1#132#194#248#246#250#245#0#136#1#3#138#0#0#137#0#0 - +#141#0#0#135#0#249#247#247#251#251#245#249#246#248#134#197#248'['#20#0#255#0 - +#255#255#0#255#255#0#255'W'#17#0#195#208#216#200#206#211#0'g'#0#0'i'#2#0'j'#0 - +#3'k'#0#1'g'#2#203#208#217#200#206#211#197#207#207#198#207#216'X'#19#0#255#0 - +#255#255#0#255#255#0#255#168#183#185#226#239#241#225#237#237#161#173#173#163 - +#176#178#163#176#178#163#176#178#163#177#176#227#240#242#226#238#240#226#238 - +#240#226#238#240#170#183#185#255#0#255#255#0#255#255#0#255'T'#17#2#246#248 - +#249#254#246#246#0#139#0#0#139#0#0#139#0#0#139#0#0#139#0#0#139#0#0#139#0#251 - +#249#249#245#249#244'W'#18#0#255#0#255#255#0#255#255#0#255'W'#18#1#132#194 - +#248#246#250#245#0#139#0#0#139#0#0#139#0#0#139#0#0#139#0#0#139#0#0#139#0#249 - +#246#248#134#197#248'['#20#0#255#0#255#255#0#255#255#0#255'W'#17#0#195#208 - +#216#200#206#211#0#139#0#0#139#0#0#139#0#0#139#0#0#139#0#0#139#0#0#139#0#197 - +#207#207#198#207#216'X'#19#0#255#0#255#255#0#255#255#0#255#168#183#185#226 - +#239#241#225#237#237#163#176#178#163#176#178#163#176#178#163#176#178#163#176 - +#178#163#176#178#163#176#178#226#238#240#226#238#240#170#183#185#255#0#255 - +#255#0#255#255#0#255#6'b7'#228#245#248#228#245#248#227#244#247#227#244#247 - +#154#154#154#154#154#154#154#154#154#154#154#154#154#154#154#227#244#247#226 - +#243#246#218#238#243#210#229#238#6'b7'#255#0#255#6'b7j'#162#230'j'#162#230 - +#227#243#246#227#243#246#154#154#154#154#154#154#154#154#154#154#154#154#154 - +#154#154#227#243#246#226#242#245'j'#162#230'j'#162#230#6'b7'#255#0#255#6'b7' - +#190#211#227#198#219#231#203#225#234#204#226#235#154#154#154#154#154#154#154 - +#154#154#154#154#154#154#154#154#204#226#235#207#226#235#208#227#236#207#228 - +#237#6'b7'#255#0#255#184#196#202#233#242#246#233#242#246#233#242#246#233#242 - +#246#154#154#154#154#154#154#154#154#154#154#154#154#154#154#154#233#242#246 - +#233#242#246#233#242#246#233#242#246#184#196#202#255#0#255#255#0#255#255#0 - ,#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 - +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255'B '#210#189#173 - +#252#251#250#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 - +#255#255#255#255#255#252#251#250#210#189#173'B '#255#0#255#255#0#255#255#0 - +#255'A'#31'k'#159#213#207#213#218#253#252#251#255#255#255#255#255#255#255 - +#255#255#255#255#255#255#255#255#253#252#251#207#213#218'k'#159#213'A'#31 - +#255#0#255#255#0#255#255#0#255'B '#185#176#167#200#204#204#202#206#207#202 - +#206#207#202#206#207#202#206#207#202#206#207#202#206#207#202#206#207#200#204 - +#204#185#176#167'B '#255#0#255#255#0#255#255#0#255#197#208#210#244#246#247 - +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 - +#255#255#255#255#255#255#255#255#244#246#247#197#208#210#255#0#255#255#0#255 - +#255#0#255'B '#210#189#173#252#251#250#233#225#215'W'#164'M'#13#146#19#13 - +#146#19#13#146#19'W'#164'M'#233#225#215#252#251#250#210#189#173'B '#255#0 - +#255#255#0#255#255#0#255'B '#210#189#173#252#251#250#233#225#215'W'#164'M' - +#13#146#19#13#146#19#13#146#19'W'#164'M'#233#225#215#252#251#250#210#189#173 - +'B '#255#0#255#255#0#255#255#0#255'B '#210#189#173#252#251#250#233#225#215 - +'W'#164'M'#13#146#19#13#146#19#13#146#19'W'#164'M'#233#225#215#252#251#250 - +#210#189#173'B '#255#0#255#255#0#255#255#0#255#190#201#199#243#245#245#255 - +#255#255#255#255#255#207#215#214#178#191#189#178#191#189#178#191#189#207#215 - +#214#255#255#255#255#255#255#243#245#245#190#201#199#255#0#255#255#0#255#255 - +#0#255#255#0#255'V'#17#0#242#242#242#239#241#241#241#240#244#238#244#243#244 - +#244#244#245#246#244#245#244#246#247#246#248#248#247#249#245#248#246#248#247 - +#249'V'#17#0#255#0#255#255#0#255#255#0#255'Z'#18#1#132#189#250#236#240#241 - +#239#241#241#244#242#242#244#244#244#245#244#246#239#246#243#251#248#250#252 - +#247#246#242#249#244#135#197#251'W'#19#0#255#0#255#255#0#255#255#0#255'W'#19 - +#0#191#206#209#191#204#206#193#204#202#194#205#203#196#203#206#191#205#203 - +#197#204#207#193#205#207#193#205#207#196#206#206#202#208#213'W'#18#0#255#0 - +#255#255#0#255#255#0#255#169#182#184#225#239#238#225#237#239#224#236#238#225 - +#237#239#226#237#241#225#237#239#224#236#238#225#237#239#226#238#238#224#236 - +#238#227#239#241#167#183#182#255#0#255#255#0#255#255#0#255'W'#18#0#240#243 - +#247#240#243#248#1#135#0#2#135#1#254#249#248#0#137#0#0#137#0#0#137#0#247#248 - +#246#246#247#251#247#249#249'V'#16#0#255#0#255#255#0#255#255#0#255'W'#18#0 - +#129#188#250#246#245#249#0#137#0#2#136#0#248#249#247#1#133#3#1#137#1#0#137#0 - +#244#247#251#246#249#247#137#199#247'U'#19#0#255#0#255#255#0#255#255#0#255'W' - +#18#1#192#205#213#203#208#209#2'e'#1#0'g'#0#208#210#218#4'g'#0#0'i'#2#2'e'#1 - +#204#211#214#196#209#207#200#209#212'W'#20#0#255#0#255#255#0#255#255#0#255 - +#171#183#187#226#238#240#229#239#239#161#173#175#163#175#177#229#241#243#163 - +#175#177#163#175#177#162#175#177#227#239#241#226#238#240#225#238#240#170#183 - +#185#255#0#255#255#0#255#255#0#255'W'#18#0#240#243#247#240#243#248#0#139#0#0 - +#139#0#0#139#0#0#139#0#0#139#0#0#139#0#0#139#0#246#247#251#247#249#249'V'#16 - +#0#255#0#255#255#0#255#255#0#255'W'#18#0#129#188#250#246#245#249#0#139#0#0 - +#139#0#0#139#0#0#139#0#0#139#0#0#139#0#0#139#0#246#249#247#137#199#247'U'#19 - +#0#255#0#255#255#0#255#255#0#255'W'#18#1#192#205#213#203#208#209#0#139#0#0 - +#139#0#0#139#0#0#139#0#0#139#0#0#139#0#0#139#0#196#209#207#200#209#212'W'#20 - +#0#255#0#255#255#0#255#255#0#255#171#183#187#226#238#240#229#239#239#163#176 - +#178#163#176#178#163#176#178#163#176#178#163#176#178#163#176#178#163#176#178 - +#226#238#240#225#238#240#170#183#185#255#0#255#255#0#255#255#0#255#6'b7'#233 - +#249#250#233#249#250#232#250#251#154#154#154#154#154#154#154#154#154#154#154 - +#154#154#154#154#154#154#154#154#154#154#231#249#251#224#243#247#214#235#242 - +#6'b7'#255#0#255#6'b7'#146#187#236#139#184#235#232#249#250#154#154#154#154 - +#154#154#154#154#154#154#154#154#154#154#154#154#154#154#154#154#154#231#248 - +#250#139#184#235#145#186#235#6'b7'#255#0#255#6'b7'#193#215#228#200#222#234 - +#207#228#237#154#154#154#154#154#154#154#154#154#154#154#154#154#154#154#154 - +#154#154#154#154#154#210#229#238#211#230#238#211#231#238#6'b7'#255#0#255#184 - +#196#202#233#242#246#233#242#246#233#242#246#154#154#154#154#154#154#154#154 - +#154#154#154#154#154#154#154#154#154#154#154#154#154#233#242#246#233#242#246 - +#233#242#246#184#196#202#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 - +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 - +#255#255#0#255#255#0#255#255#0#255'q,'#8#224#211#197#250#247#245#255#255#255 - +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#250 - +#247#245#224#211#197'q,'#8#255#0#255#255#0#255#255#0#255'q,'#7'^'#164#234#226 - +#217#208#250#248#246#255#255#255#255#255#255#255#255#255#255#255#255#255#255 - +#255#250#248#246#226#217#208'^'#164#234'q,'#7#255#0#255#255#0#255#255#0#255 - +'q,'#8#187#185#178#199#202#202#202#206#207#202#206#207#202#206#207#202#206 - ,#207#202#206#207#202#206#207#202#206#207#199#202#202#187#185#178'q,'#8#255#0 - +#255#255#0#255#255#0#255#188#200#203#254#254#254#255#255#255#255#255#255#255 - +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 - +#255#254#254#254#188#200#203#255#0#255#255#0#255#255#0#255'q,'#8#224#211#197 - +#250#247#245#237#230#223#25#149#29#13#146#19#13#146#19#13#146#19#25#149#29 - +#237#230#223#250#247#245#224#211#197'q,'#8#255#0#255#255#0#255#255#0#255'q,' - +#8#224#211#197#250#247#245#237#230#223#25#149#29#13#146#19#13#146#19#13#146 - +#19#25#149#29#237#230#223#250#247#245#224#211#197'q,'#8#255#0#255#255#0#255 - +#255#0#255'q,'#8#224#211#197#250#247#245#237#230#223#25#149#29#13#146#19#13 - +#146#19#13#146#19#25#149#29#237#230#223#250#247#245#224#211#197'q,'#8#255#0 - +#255#255#0#255#255#0#255#180#192#190#253#254#254#255#255#255#255#255#255#183 - +#195#193#178#191#189#178#191#189#178#191#189#183#195#193#255#255#255#255#255 - +#255#253#254#254#180#192#190#255#0#255#255#0#255#255#0#255#255#0#255'V'#17#0 - +#233#235#236#230#235#234#231#236#235#235#238#236#237#239#240#237#239#240#242 - +#242#242#246#244#243#240#246#245#247#247#247#250#248#248'V'#17#0#255#0#255 - +#255#0#255#255#0#255'U'#19#1'w'#190#240#234#233#235#235#233#233#231#236#235 - +#233#239#238#239#238#240#237#241#242#238#245#242#243#246#244#250#246#251#134 - +#193#249'W'#20#0#255#0#255#255#0#255#255#0#255'X'#18#1#192#204#206#192#201 - +#204#194#202#202#189#202#200#190#202#202#193#203#203#195#202#205#196#204#203 - +#196#203#206#192#204#208#197#208#212'Y'#20#1#255#0#255#255#0#255#255#0#255 - +#170#183#185#224#238#237#225#237#239#224#236#238#225#237#239#223#235#237#227 - +#239#239#224#236#238#224#236#238#224#235#239#225#237#239#225#237#237#170#183 - +#185#255#0#255#255#0#255#255#0#255'P'#19#0#229#235#242#238#237#239#3#135#0 - +#241#240#244#246#240#245#250#243#250#1#137#1#0#137#0#0#136#0#244#249#247#251 - +#249#249'V'#16#0#255#0#255#255#0#255#255#0#255'W'#19#0#129#188#244#234#237 - +#241#0#133#0#243#239#244#240#243#248#245#245#245#4#134#3#0#140#1#2#136#0#247 - +#247#247#136#196#248'X'#19#0#255#0#255#255#0#255#255#0#255'Y'#20#0#192#205 - +#207#193#205#205#0'f'#1#195#205#212#200#205#208#197#203#214#0'g'#0#1'h'#0#2 - +'f'#0#201#208#211#197#208#212'Z'#19#0#255#0#255#255#0#255#255#0#255#168#183 - +#185#225#238#240#226#238#240#161#173#175#227#239#241#226#239#241#227#238#242 - +#163#174#178#163#175#177#160#173#175#225#238#240#227#239#241#170#183#185#255 - +#0#255#255#0#255#255#0#255'P'#19#0#229#235#242#238#237#239#0#139#0#0#139#0#0 - +#139#0#0#139#0#0#139#0#0#139#0#0#139#0#244#249#247#251#249#249'V'#16#0#255#0 - +#255#255#0#255#255#0#255'W'#19#0#129#188#244#234#237#241#0#139#0#0#139#0#0 - +#139#0#0#139#0#0#139#0#0#139#0#0#139#0#247#247#247#136#196#248'X'#19#0#255#0 - +#255#255#0#255#255#0#255'Y'#20#0#192#205#207#193#205#205#0#139#0#0#139#0#0 - +#139#0#0#139#0#0#139#0#0#139#0#0#139#0#201#208#211#197#208#212'Z'#19#0#255#0 - +#255#255#0#255#255#0#255#168#183#185#225#238#240#226#238#240#163#176#178#163 - +#176#178#163#176#178#163#176#178#163#176#178#163#176#178#163#176#178#225#238 - +#240#227#239#241#170#183#185#255#0#255#255#0#255#255#0#255#6'b7'#235#249#250 - +#235#249#250#154#154#154#154#154#154#154#154#154#154#154#154#154#154#154#154 - +#154#154#154#154#154#154#154#154#154#154#154#225#243#247#215#235#242#6'b7' - +#255#0#255#6'b7'#150#190#237#139#184#235#154#154#154#154#154#154#154#154#154 - +#154#154#154#154#154#154#154#154#154#154#154#154#154#154#154#154#154#154#139 - +#184#235#150#190#237#6'b7'#255#0#255#6'b7'#193#215#228#200#222#234#154#154 - +#154#154#154#154#154#154#154#154#154#154#154#154#154#154#154#154#154#154#154 - +#154#154#154#154#154#154#211#230#238#211#231#238#6'b7'#255#0#255#184#196#202 - +#233#242#246#233#242#246#154#154#154#154#154#154#154#154#154#154#154#154#154 - +#154#154#154#154#154#154#154#154#154#154#154#154#154#154#233#242#246#233#242 - +#246#184#196#202#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 - +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 - +#255#255#0#255#255#0#255#128'C!'#205#183#165#243#238#232#255#255#255#255#255 - +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#243#238#232 - +#205#183#165#128'C!'#255#0#255#255#0#255#255#0#255#128'B l'#160#214#199#201 - +#203#243#238#233#254#254#253#255#255#255#255#255#255#255#255#255#254#254#253 - +#243#238#233#199#201#203'l'#160#214#128'B '#255#0#255#255#0#255#255#0#255#128 - +'C!'#182#173#163#196#198#195#202#206#207#202#206#207#202#206#207#202#206#207 - +#202#206#207#202#206#207#202#206#207#196#198#195#182#173#163#128'C!'#255#0 - +#255#255#0#255#255#0#255#197#208#210#244#246#247#255#255#255#255#255#255#255 - +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 - +#255#244#246#247#197#208#210#255#0#255#255#0#255#255#0#255#128'C!'#205#183 - +#165#243#238#232#247#243#240']'#172'X'#13#146#19#13#146#19#13#146#19']'#172 - +'X'#247#243#240#243#238#232#205#183#165#128'C!'#255#0#255#255#0#255#255#0#255 - +#128'C!'#205#183#165#243#238#232#247#243#240']'#172'X'#13#146#19#13#146#19#13 - ,#146#19']'#172'X'#247#243#240#243#238#232#205#183#165#128'C!'#255#0#255#255#0 - +#255#255#0#255#128'C!'#205#183#165#243#238#232#247#243#240']'#172'X'#13#146 - +#19#13#146#19#13#146#19']'#172'X'#247#243#240#243#238#232#205#183#165#128'C!' - +#255#0#255#255#0#255#255#0#255#190#201#199#243#245#245#255#255#255#255#255 - +#255#207#215#214#178#191#189#178#191#189#178#191#189#207#215#214#255#255#255 - +#255#255#255#243#245#245#190#201#199#255#0#255#255#0#255#255#0#255#255#0#255 - +'V'#17#0#227#230#234#226#230#231#225#229#230#229#234#233#234#235#233#231#236 - +#235#235#237#237#235#240#239#241#242#240#243#242#244#247#249#249'V'#17#0#255 - +#0#255#255#0#255#255#0#255'W'#18#0'|'#181#243#225#227#228#227#226#228#222#230 - +#230#230#232#232#229#231#231#233#235#236#233#237#238#242#237#238#241#243#243 - +#131#194#245'W'#18#1#255#0#255#255#0#255#255#0#255'W'#18#0#189#203#202#188 - +#200#200#185#199#198#188#202#201#188#200#202#192#201#204#191#204#202#191#204 - +#202#190#202#204#192#204#206#196#210#209'W'#19#0#255#0#255#255#0#255#255#0 - +#255#170#183#185#225#238#240#224#236#238#223#235#237#223#235#237#225#237#239 - +#225#237#237#224#236#238#223#236#238#223#235#239#224#236#238#225#237#237#171 - +#184#186#255#0#255#255#0#255#255#0#255'Z'#18#1#224#227#231#224#228#229#226 - +#229#233#228#233#232#233#233#233#238#236#236#245#239#244#5#137#0#0#137#2#250 - +#247#249#246#246#246'V'#17#2#255#0#255#255#0#255#255#0#255'Y'#20#1'y'#181#241 - +#229#230#228#231#229#229#231#230#232#229#234#232#234#235#239#245#239#244#1 - +#134#0#0#138#0#246#248#248#133#192#248'['#20#0#255#0#255#255#0#255#255#0#255 - +'V'#17#2#188#200#206#190#202#204#195#198#206#191#203#205#192#201#204#196#203 - +#206#201#203#213#0'f'#1#0'f'#1#195#206#210#196#209#211'W'#19#0#255#0#255#255 - +#0#255#255#0#255#168#183#185#225#239#238#225#237#237#226#238#238#227#239#239 - +#223#237#236#226#238#240#227#239#241#163#175#177#162#174#176#228#240#242#228 - +#237#240#171#183#185#255#0#255#255#0#255#255#0#255'Z'#18#1#224#227#231#224 - +#228#229#0#139#0#0#139#0#0#139#0#0#139#0#0#139#0#0#139#0#0#139#0#250#247#249 - +#246#246#246'V'#17#2#255#0#255#255#0#255#255#0#255'Y'#20#1'y'#181#241#229#230 - +#228#0#139#0#0#139#0#0#139#0#0#139#0#0#139#0#0#139#0#0#139#0#246#248#248#133 - +#192#248'['#20#0#255#0#255#255#0#255#255#0#255'V'#17#2#188#200#206#190#202 - +#204#0#139#0#0#139#0#0#139#0#0#139#0#0#139#0#0#139#0#0#139#0#195#206#210#196 - +#209#211'W'#19#0#255#0#255#255#0#255#255#0#255#168#183#185#225#239#238#225 - +#237#237#163#176#178#163#176#178#163#176#178#163#176#178#163#176#178#163#176 - +#178#163#176#178#228#240#242#228#237#240#171#183#185#255#0#255#255#0#255#255 - +#0#255#6'b7'#237#251#252#236#251#252#236#251#252#236#251#252#236#251#252#236 - +#251#252#236#251#252#236#251#252#236#251#252#236#251#252#236#250#251#228#244 - +#249#219#237#244#6'b7'#255#0#255#6'b7'#156#196#238#139#184#235#237#251#252 - +#237#251#252#237#251#252#237#251#252#237#251#252#237#251#252#237#251#252#237 - +#251#252#236#250#251#139#184#235#156#196#238#6'b7'#255#0#255#6'b7'#195#216 - +#229#202#224#234#208#229#238#211#230#238#211#230#238#211#230#238#211#230#238 - +#211#230#238#211#230#238#211#230#238#211#230#238#212#231#238#213#231#238#6'b' - +'7'#255#0#255#184#196#202#233#242#246#233#242#246#233#242#246#233#242#246#233 - +#242#246#233#242#246#233#242#246#233#242#246#233#242#246#233#242#246#233#242 - +#246#233#242#246#233#242#246#184#196#202#255#0#255#255#0#255#255#0#255#255#0 - +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 - +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#156'lP'#178#142'v'#233#224 - +#214#251#250#248#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 - +#251#250#248#233#224#214#178#142'v'#156'lP'#255#0#255#255#0#255#255#0#255#155 - +'kO{'#143#171#161#185#208#229#218#207#243#238#233#250#248#246#253#252#251#250 - +#248#246#243#238#233#229#218#207#161#185#208'{'#143#171#155'kO'#255#0#255#255 - +#0#255#255#0#255#156'lP'#170#146#129#191#191#186#200#204#203#202#206#207#202 - +#206#207#202#206#207#202#206#207#202#206#207#200#204#203#191#191#186#170#146 - +#129#156'lP'#255#0#255#255#0#255#255#0#255#213#221#222#228#233#234#255#255 - +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 - +#255#255#255#255#255#255#228#233#234#213#221#222#255#0#255#255#0#255#255#0 - +#255#156'lP'#178#142'v'#233#224#214#250#247#245#196#222#191'`'#177'_'#26#151 - +#31'`'#177'_'#196#222#191#250#247#245#233#224#214#178#142'v'#156'lP'#255#0 - +#255#255#0#255#255#0#255#156'lP'#178#142'v'#233#224#214#250#247#245#196#222 - +#191'`'#177'_'#26#151#31'`'#177'_'#196#222#191#250#247#245#233#224#214#178 - +#142'v'#156'lP'#255#0#255#255#0#255#255#0#255#156'lP'#178#142'v'#233#224#214 - +#250#247#245#196#222#191'`'#177'_'#26#151#31'`'#177'_'#196#222#191#250#247 - +#245#233#224#214#178#142'v'#156'lP'#255#0#255#255#0#255#255#0#255#208#216#215 - +#225#230#229#255#255#255#255#255#255#238#241#241#207#215#214#183#195#193#207 - +#215#214#238#241#241#255#255#255#255#255#255#225#230#229#208#216#215#255#0 - +#255#255#0#255#255#0#255#255#0#255'V'#17#0#217#226#230#221#225#226#221#227 - ,#226#225#227#227#226#232#227#230#232#232#228#231#235#236#233#235#234#236#236 - +#234#239#242#238#241#245'V'#17#0#255#0#255#255#0#255#255#0#255'['#19#1't'#177 - +#241#217#225#218#216#222#221#220#223#221#217#225#224#226#228#228#224#229#227 - +#233#233#227#235#234#236#234#240#239'}'#189#247'X'#18#1#255#0#255#255#0#255 - +#255#0#255'V'#16#3#183#201#200#189#200#198#186#198#198#186#200#199#186#200 - +#196#188#201#199#189#201#201#191#201#201#191#200#203#191#204#202#194#206#208 - +'W'#18#0#255#0#255#255#0#255#255#0#255#170#182#186#224#237#239#226#237#241 - +#225#237#239#224#236#238#224#235#239#224#236#238#225#237#239#224#236#238#223 - +#237#236#225#238#240#225#238#240#168#184#183#255#0#255#255#0#255#255#0#255'Y' - +#17#0#212#221#224#216#220#221#215#220#221#219#224#223#218#226#225#224#229#228 - +#227#230#234#233#234#238#1#133#2#236#240#241#240#242#242'W'#17#0#255#0#255 - +#255#0#255#255#0#255'V'#21#0't'#178#242#217#222#221#216#221#222#217#222#223 - +#220#225#223#224#231#228#227#231#232#236#235#239#0#133#3#237#238#242'~'#189 - +#249'Z'#19#0#255#0#255#255#0#255#255#0#255'T'#18#0#184#203#200#189#198#201 - +#189#198#202#186#199#201#190#198#197#189#201#201#189#201#203#200#205#208#2'f' - +#0#190#205#207#194#206#210'W'#18#0#255#0#255#255#0#255#255#0#255#168#181#183 - +#225#238#240#225#237#239#223#235#237#225#237#239#225#237#239#224#236#238#226 - +#238#240#228#240#242#159#172#174#226#238#238#225#237#239#171#184#186#255#0 - +#255#255#0#255#255#0#255'Y'#17#0#212#221#224#216#220#221#0#139#0#0#139#0#0 - +#139#0#0#139#0#0#139#0#0#139#0#0#139#0#236#240#241#240#242#242'W'#17#0#255#0 - +#255#255#0#255#255#0#255'V'#21#0't'#178#242#217#222#221#0#139#0#0#139#0#0#139 - +#0#0#139#0#0#139#0#0#139#0#0#139#0#237#238#242'~'#189#249'Z'#19#0#255#0#255 - +#255#0#255#255#0#255'T'#18#0#184#203#200#189#198#201#0#139#0#0#139#0#0#139#0 - +#0#139#0#0#139#0#0#139#0#0#139#0#190#205#207#194#206#210'W'#18#0#255#0#255 - +#255#0#255#255#0#255#168#181#183#225#238#240#225#237#239#163#176#178#163#176 - +#178#163#176#178#163#176#178#163#176#178#163#176#178#163#176#178#226#238#238 - +#225#237#239#171#184#186#255#0#255#255#0#255#255#0#255#6'b7'#240#253#254#239 - +#253#254#239#253#254#239#253#254#239#253#254#239#253#254#239#253#254#239#253 - +#254#239#253#254#239#253#254#238#253#254#232#247#251#224#241#246#6'b7'#255#0 - +#255#6'b7'#161#198#238#139#184#235#240#253#254#240#253#254#240#253#254#240 - +#253#254#240#253#254#240#253#254#240#253#254#240#253#254#239#253#254#139#184 - +#235#161#198#238#6'b7'#255#0#255#6'b7'#195#217#229#202#224#234#210#230#238 - +#212#233#238#213#233#238#213#233#238#213#233#238#213#233#238#213#233#238#213 - +#233#238#213#233#238#213#233#238#214#233#238#6'b7'#255#0#255#184#196#202#233 - +#242#246#233#242#246#233#242#246#233#242#246#233#242#246#233#242#246#233#242 - +#246#233#242#246#233#242#246#233#242#246#233#242#246#233#242#246#233#242#246 - +#184#196#202#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255 - +#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 - +#255#0#255#255#0#255#196#169#152#147'_B'#222#208#194#233#224#214#243#238#232 - +#250#247#245#252#251#250#250#247#245#243#238#232#233#224#214#222#208#194#147 - +'_B'#196#169#152#255#0#255#255#0#255#255#0#255#196#169#151#130'ibx'#171#222 - +#197#195#192#222#209#195#229#218#207#232#222#212#229#218#207#222#209#195#197 - +#195#192'x'#171#222#130'ib'#196#169#151#255#0#255#255#0#255#255#0#255#196#169 - +#152#147'fM'#191#187#179#191#191#186#196#198#195#199#202#202#200#204#204#199 - +#202#202#196#198#195#191#191#186#191#187#179#147'fM'#196#169#152#255#0#255 - +#255#0#255#255#0#255#255#0#255#208#217#219#254#254#254#255#255#255#255#255 - +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#254#254#254 - +#208#217#219#255#0#255#255#0#255#255#0#255#255#0#255#196#169#152#147'_B'#222 - +#208#194#233#224#214#243#238#232#250#247#245#252#251#250#250#247#245#243#238 - +#232#233#224#214#222#208#194#147'_B'#196#169#152#255#0#255#255#0#255#255#0 - +#255#196#169#152#147'_B'#222#208#194#233#224#214#243#238#232#250#247#245#252 - +#251#250#250#247#245#243#238#232#233#224#214#222#208#194#147'_B'#196#169#152 - +#255#0#255#255#0#255#255#0#255#196#169#152#147'_B'#222#208#194#233#224#214 - +#243#238#232#250#247#245#252#251#250#250#247#245#243#238#232#233#224#214#222 - +#208#194#147'_B'#196#169#152#255#0#255#255#0#255#255#0#255#255#0#255#203#212 - +#210#254#254#254#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 - +#255#255#255#255#255#255#254#254#254#203#212#210#255#0#255#255#0#255#255#0 - +#255#255#0#255#255#0#255'V'#17#0#219#223#224#214#225#223#222#224#224#221#224 - +#228#222#225#229#223#227#228#225#230#228#229#231#232#227#231#232#236#236#236 - +#236#241#242'V'#17#0#255#0#255#255#0#255#255#0#255'Y'#20#1'p'#173#235#214#217 - +#215#213#218#217#217#219#220#219#221#221#218#223#222#223#226#224#221#224#228 - +#224#229#227#234#232#231'}'#185#244'['#20#0#255#0#255#255#0#255#255#0#255'Y' - +#20#0#187#199#199#185#198#200#185#197#197#185#197#201#184#199#202#189#198#202 - +#188#200#200#188#200#202#183#200#203#192#204#206#189#204#207'Y'#19#2#255#0 - ,#255#255#0#255#255#0#255#173#185#187#226#238#240#226#237#241#225#237#239#224 - +#236#238#225#237#239#225#237#237#224#236#238#225#237#239#224#236#236#225#237 - +#239#226#238#240#170#184#183#255#0#255#255#0#255#255#0#255'Y'#19#2#211#216 - +#219#204#218#217#214#216#216#213#218#221#215#221#220#215#221#226#219#224#222 - +#225#227#228#226#229#234#228#233#231#231#236#237'V'#14#2#255#0#255#255#0#255 - +#255#0#255'W'#19#0'p'#175#235#207#218#216#213#218#217#220#220#220#221#221#221 - +#224#221#223#221#226#225#226#228#229#230#230#230#235#236#234#128#185#246'[' - +#19#2#255#0#255#255#0#255#255#0#255'Y'#20#1#188#200#200#185#199#198#185#198 - +#200#186#199#201#187#197#197#184#196#200#188#200#204#193#201#201#190#199#208 - +#194#203#206#195#204#207'T'#20#2#255#0#255#255#0#255#255#0#255#173#185#189 - +#225#237#239#227#239#241#226#238#240#225#237#239#224#236#238#224#236#238#225 - +#237#239#226#238#238#226#240#239#225#237#237#226#238#238#170#184#183#255#0 - +#255#255#0#255#255#0#255'Y'#19#2#211#216#219#204#218#217#214#216#216#213#218 - +#221#215#221#220#215#221#226#219#224#222#225#227#228#226#229#234#228#233#231 - +#231#236#237'V'#14#2#255#0#255#255#0#255#255#0#255'W'#19#0'p'#175#235#207#218 - +#216#213#218#217#220#220#220#221#221#221#224#221#223#221#226#225#226#228#229 - +#230#230#230#235#236#234#128#185#246'['#19#2#255#0#255#255#0#255#255#0#255'Y' - +#20#1#188#200#200#185#199#198#185#198#200#186#199#201#187#197#197#184#196#200 - +#188#200#204#193#201#201#190#199#208#194#203#206#195#204#207'T'#20#2#255#0 - +#255#255#0#255#255#0#255#173#185#189#225#237#239#227#239#241#226#238#240#225 - +#237#239#224#236#238#224#236#238#225#237#239#226#238#238#226#240#239#225#237 - +#237#226#238#238#170#184#183#255#0#255#255#0#255#255#0#255'#oL'#180#221#228 - +#245#255#255#245#255#255#245#255#255#245#255#255#245#255#255#245#255#255#245 - +#255#255#245#255#255#245#255#255#245#255#255#244#255#255#180#221#228'#oL'#255 - +#0#255'#oL'#149#197#252#139#184#235#150#190#237#150#190#237#150#190#237#150 - +#190#237#150#190#237#150#190#237#150#190#237#150#190#237#150#190#237#139#184 - +#235#149#197#252'#oL'#255#0#255'#oL'#149#175#196#185#208#227#191#212#228#194 - +#216#230#195#217#231#195#217#231#195#217#231#195#217#231#195#217#231#195#217 - +#231#194#216#230#196#218#231#158#189#206'#oL'#255#0#255#184#196#202#221#231 - +#235#233#242#246#233#242#246#233#242#246#233#242#246#233#242#246#233#242#246 - +#233#242#246#233#242#246#233#242#246#233#242#246#233#242#246#221#231#235#184 - +#196#202#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 - +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 - +#255#0#255#255#0#255#255#0#255#167'}e'#172#133'm'#219#204#189#222#209#195#226 - +#214#201#228#217#205#226#214#201#222#209#195#219#204#189#172#133'm'#167'}e' - +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#166'}d'#138#136#145'x'#171 - +#222#159#182#204#191#190#189#209#194#178#191#190#189#159#182#204'x'#171#222 - +#138#136#145#166'}d'#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#167'}' - +'e'#168#138'v'#189#185#176#185#183#177#187#186#180#188#187#182#187#186#180 - +#185#183#177#189#185#176#168#138'v'#167'}e'#255#0#255#255#0#255#255#0#255#255 - +#0#255#255#0#255#217#224#226#224#229#231#254#254#254#255#255#255#255#255#255 - +#255#255#255#255#255#255#255#255#255#254#254#254#224#229#231#217#224#226#255 - +#0#255#255#0#255#255#0#255#255#0#255#255#0#255#167'}e'#172#133'm'#219#204#189 - +#222#209#195#226#214#201#228#217#205#226#214#201#222#209#195#219#204#189#172 - +#133'm'#167'}e'#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#167'}e'#172 - +#133'm'#219#204#189#222#209#195#226#214#201#228#217#205#226#214#201#222#209 - +#195#219#204#189#172#133'm'#167'}e'#255#0#255#255#0#255#255#0#255#255#0#255 - +#255#0#255#167'}e'#172#133'm'#219#204#189#222#209#195#226#214#201#228#217#205 - +#226#214#201#222#209#195#219#204#189#172#133'm'#167'}e'#255#0#255#255#0#255 - +#255#0#255#255#0#255#255#0#255#213#220#219#220#226#225#254#254#254#255#255 - +#255#255#255#255#255#255#255#255#255#255#255#255#255#254#254#254#220#226#225 - +#213#220#219#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255'V'#17#0#214 - +#226#226#218#222#227#220#223#227#221#226#229#221#227#226#223#229#228#224#230 - +#229#222#231#228#229#232#237#230#233#237#232#238#237'V'#17#0#255#0#255#255#0 - +#255#255#0#255'X'#19#0'l'#177#240'o'#172#236'm'#174#235'q'#176#236'r'#177#237 - +'t'#177#239's'#182#239't'#181#236'u'#178#240'v'#181#241'y'#184#245'T'#18#0 - +#255#0#255#255#0#255#255#0#255'V'#18#0#187#201#199#185#199#205#184#197#199 - +#184#199#201#187#199#201#186#199#201#188#200#202#188#199#203#188#202#201#193 - +#202#206#193#205#205'W'#19#0#255#0#255#255#0#255#255#0#255#170#182#184#227 - +#239#239#225#237#239#227#239#239#226#238#238#225#237#239#226#238#238#226#238 - +#240#226#238#238#225#237#239#225#237#239#227#239#239#170#182#186#255#0#255 - +#255#0#255#255#0#255'T'#18#0#206#215#219#209#214#217#209#214#215#210#215#218 - +#212#215#219#209#218#221#216#223#220#217#222#221#220#226#225#214#228#227#224 - +#230#235'T'#18#0#255#0#255#255#0#255#255#0#255'X'#19#0'n'#176#241'n'#171#235 - ,'p'#173#235'm'#179#232's'#179#237'r'#180#239'r'#180#239's'#181#240'v'#179#243 - +'t'#183#240'u'#184#247'Y'#20#1#255#0#255#255#0#255#255#0#255'W'#19#0#188#201 - +#203#187#199#205#183#198#200#184#198#197#186#199#201#188#201#203#189#199#199 - +#189#200#204#189#198#208#183#201#202#192#203#211'X'#20#1#255#0#255#255#0#255 - +#255#0#255#169#182#184#227#239#239#226#238#238#225#237#237#226#238#238#226 - +#238#238#226#238#238#224#236#236#229#238#241#225#237#239#225#237#237#227#239 - +#239#169#182#184#255#0#255#255#0#255#255#0#255'T'#18#0#206#215#219#209#214 - +#217#209#214#215#210#215#218#212#215#219#209#218#221#216#223#220#217#222#221 - +#220#226#225#214#228#227#224#230#235'T'#18#0#255#0#255#255#0#255#255#0#255'X' - +#19#0'n'#176#241'n'#171#235'p'#173#235'm'#179#232's'#179#237'r'#180#239'r' - +#180#239's'#181#240'v'#179#243't'#183#240'u'#184#247'Y'#20#1#255#0#255#255#0 - +#255#255#0#255'W'#19#0#188#201#203#187#199#205#183#198#200#184#198#197#186 - +#199#201#188#201#203#189#199#199#189#200#204#189#198#208#183#201#202#192#203 - +#211'X'#20#1#255#0#255#255#0#255#255#0#255#169#182#184#227#239#239#226#238 - +#238#225#237#237#226#238#238#226#238#238#226#238#238#224#236#236#229#238#241 - +#225#237#239#225#237#237#227#239#239#169#182#184#255#0#255#255#0#255#255#0 - +#255'['#137'uM'#138'm'#180#222#229#246#255#255#246#255#255#246#255#255#246 - +#255#255#246#255#255#246#255#255#246#255#255#246#255#255#246#255#255#201#235 - +#238'M'#138'm['#138'v'#255#0#255'['#137'u|'#140#137#149#197#252#149#197#252 - +#149#197#252#149#197#252#149#197#252#149#197#252#149#197#252#149#197#252#149 - +#197#252#149#197#252#149#197#252'|'#140#137'['#138'v'#255#0#255'['#137'u@z`' - +#145#167#192#178#204#222#179#205#223#180#205#223#180#205#223#180#205#223#180 - +#205#223#180#205#223#180#205#223#180#205#223#164#178#201'C|b['#138'v'#255#0 - +#255#184#196#202#201#211#217#221#231#235#233#242#246#233#242#246#233#242#246 - +#233#242#246#233#242#246#233#242#246#233#242#246#233#242#246#233#242#246#225 - +#235#239#201#211#217#184#196#202#255#0#255#255#0#255#255#0#255#255#0#255#255 - +#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 - +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#168'g'#148'aC' - +#178#142'v'#200#177#157#214#198#180#200#177#157#178#142'v'#148'aC'#168'g' - +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#168'' - +'g'#131'jd|'#144#173'l'#160#214']'#164#233'l'#160#214'|'#144#173#131'jd'#168 - +'g'#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 - +#168'g'#148'hN'#170#146#129#179#169#158#182#178#170#179#169#158#170#146#129 - +#148'hN'#168'g'#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 - +#255#0#255#217#224#226#208#217#219#228#233#234#244#246#247#254#254#254#244 - +#246#247#228#233#234#208#217#219#217#224#226#255#0#255#255#0#255#255#0#255 - +#255#0#255#255#0#255#255#0#255#255#0#255#168'g'#148'aC'#178#142'v'#200#177 - +#157#214#198#180#200#177#157#178#142'v'#148'aC'#168'g'#255#0#255#255#0#255 - +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#168'g'#148'aC'#178#142'v' - +#200#177#157#214#198#180#200#177#157#178#142'v'#148'aC'#168'g'#255#0#255#255 - +#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#168'g'#148'aC'#178 - +#142'v'#200#177#157#214#198#180#200#177#157#178#142'v'#148'aC'#168'g'#255#0 - +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#213#220#219 - +#203#212#210#225#230#229#243#245#245#253#254#254#243#245#245#225#230#229#203 - +#212#210#213#220#219#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 - +#255'V'#17#0'V'#17#0'V'#17#0'V'#17#0'V'#17#0'V'#17#0'V'#17#0'V'#17#0'V'#17#0 - +'V'#17#0'V'#17#0'V'#17#0'V'#17#0#255#0#255#255#0#255#255#0#255'^'#17#1'W'#19 - +#0'X'#20#1'Z'#19#0'X'#19#0'['#19#1'Y'#18#0'['#20#0'V'#21#0'X'#19#0'X'#21#0'V' - +#17#0'X'#21#0#255#0#255#255#0#255#255#0#255'W'#18#1'X'#20#1'V'#19#0'Y'#21#2 - +'Z'#18#1'W'#19#0'X'#19#0'X'#19#0'Y'#17#0'V'#17#0'W'#16#2'W'#19#0'U'#19#0#255 - +#0#255#255#0#255#255#0#255#168#183#185#170#184#183#170#183#185#170#183#185 - +#168#183#185#169#184#186#169#185#184#170#183#185#171#184#186#168#183#186#169 - +#184#186#169#182#184#171#183#187#255#0#255#255#0#255#255#0#255'T'#18#0'X'#19 - +#2'S'#17#0'U'#19#1'W'#19#0'X'#19#0'Q'#19#1'T'#15#0'W'#19#0'V'#18#0'S'#17#0'W' - +#18#0'W'#18#1#255#0#255#255#0#255#255#0#255'_'#19#1'X'#19#0'Z'#21#2'Z'#20#0 - +'X'#19#0'X'#17#3'U'#19#0'Z'#18#1'X'#19#0'['#20#0'Q'#20#0'Y'#20#1'W'#18#0#255 - +#0#255#255#0#255#255#0#255'X'#19#2'W'#19#0'X'#20#1'Z'#18#0']'#18#4'X'#18#1'T' - +#21#0'Z'#18#0'S'#19#1'X'#19#0'U'#23#0'X'#18#1'W'#18#0#255#0#255#255#0#255#255 - +#0#255#171#184#186#171#184#186#170#183#185#171#184#186#168#181#183#170#183 - +#185#169#182#184#172#185#187#169#181#185#171#184#186#171#184#186#170#183#185 - +#170#185#188#255#0#255#255#0#255#255#0#255'T'#18#0'X'#19#2'S'#17#0'U'#19#1'W' - +#19#0'X'#19#0'Q'#19#1'T'#15#0'W'#19#0'V'#18#0'S'#17#0'W'#18#0'W'#18#1#255#0 - +#255#255#0#255#255#0#255'_'#19#1'X'#19#0'Z'#21#2'Z'#20#0'X'#19#0'X'#17#3'U' - +#19#0'Z'#18#1'X'#19#0'['#20#0'Q'#20#0'Y'#20#1'W'#18#0#255#0#255#255#0#255#255 - ,#0#255'X'#19#2'W'#19#0'X'#20#1'Z'#18#0']'#18#4'X'#18#1'T'#21#0'Z'#18#0'S'#19 - +#1'X'#19#0'U'#23#0'X'#18#1'W'#18#0#255#0#255#255#0#255#255#0#255#171#184#186 - +#171#184#186#170#183#185#171#184#186#168#181#183#170#183#185#169#182#184#172 - +#185#187#169#181#185#171#184#186#171#184#186#170#183#185#170#185#188#255#0 - +#255#255#0#255#255#0#255#209#196#219'['#137'u#oL'#6'b7'#6'b7'#6'b7'#6'b7'#6 - +'b7'#6'b7'#6'b7'#6'b7'#6'b7'#24'iDO'#131'm'#213#201#223#255#0#255#222#196#200 - +'['#137'u#oL'#6'b7'#6'b7'#6'b7'#6'b7'#6'b7'#6'b7'#6'b7'#6'b7'#6'b7'#24'iDO' - +#131'm'#226#201#205#255#0#255#209#196#219'['#137'u#oL'#6'b7'#6'b7'#6'b7'#6'b' - +'7'#6'b7'#6'b7'#6'b7'#6'b7'#6'b7'#24'iDO'#131'm'#213#201#223#255#0#255#255 - +#255#255#184#196#202#184#196#202#184#196#202#184#196#202#184#196#202#184#196 - +#202#184#196#202#184#196#202#184#196#202#184#196#202#184#196#202#184#196#202 - +#184#196#202#255#255#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 - +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 - +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#202#177#162 - +#160'sY'#130'F%q-'#8#130'F%'#160'sY'#202#177#162#255#0#255#255#0#255#255#0 - +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#202#177#162 - +#160'sY'#130'F%q-'#8#130'F%'#160'sY'#202#177#162#255#0#255#255#0#255#255#0 - +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#202#177#162 - +#160'sY'#130'F%q-'#8#130'F%'#160'sY'#202#177#162#255#0#255#255#0#255#255#0 - +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#233#237#238 - +#213#221#222#197#208#210#188#200#203#197#208#210#213#221#222#233#237#238#255 - +#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 - +#255#0#255#202#177#162#160'sY'#130'F%q-'#8#130'F%'#160'sY'#202#177#162#255#0 - +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 - +#255#0#255#202#177#162#160'sY'#130'F%q-'#8#130'F%'#160'sY'#202#177#162#255#0 - +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 - +#255#0#255#202#177#162#160'sY'#130'F%q-'#8#130'F%'#160'sY'#202#177#162#255#0 - +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 - +#255#0#255#255#0#255#208#216#215#190#201#199#180#192#190#190#201#199#208#216 - +#215#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 - +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 - +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 - +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 - +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 - +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 - +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 - +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 - +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 - +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 - +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 - +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 - +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 - +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 - +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 - +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 - +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 - +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 - +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 - +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 - +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 - +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 - +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 - +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 - +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 - +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 - +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 - +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 - +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 - +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 - +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 - +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 - +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 - +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 - +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 - ,#255#0#255#0#0 -]); diff --git a/components/virtualtreeview/virtualtreeview_package.lpk b/components/virtualtreeview/virtualtreeview_package.lpk deleted file mode 100644 index a707d4ad9..000000000 --- a/components/virtualtreeview/virtualtreeview_package.lpk +++ /dev/null @@ -1,50 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff --git a/components/virtualtreeview/virtualtreeview_package.pas b/components/virtualtreeview/virtualtreeview_package.pas deleted file mode 100644 index 19e961443..000000000 --- a/components/virtualtreeview/virtualtreeview_package.pas +++ /dev/null @@ -1,21 +0,0 @@ -{ This file was automatically created by Lazarus. Do not edit! -This source is only used to compile and install the package. - } - -unit virtualtreeview_package; - -interface - -uses - VirtualTrees, LazarusPackageIntf; - -implementation - -procedure Register; -begin - RegisterUnit('VirtualTrees', @VirtualTrees.Register); -end; - -initialization - RegisterPackage('virtualtreeview_package', @Register); -end. diff --git a/components/virtualtreeview/vtlogger.pas b/components/virtualtreeview/vtlogger.pas deleted file mode 100644 index aaadf5943..000000000 --- a/components/virtualtreeview/vtlogger.pas +++ /dev/null @@ -1,74 +0,0 @@ -unit vtlogger; - -{$mode objfpc}{$H+} - -interface - -uses - multiloglcl, multilog; - -const - //lc stands for LogClass - //it's possible to define the constants to suit any need - lcAll = [0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31]; - lcDebug = 0; - lcError = 1; - lcInfo = 2; - lcWarning = 3; - - lcEvents = 4; - lcPaint = 5; - lcPaintHeader = 6; - lcDummyFunctions = 7; - lcMessages = 8; - lcPaintSelection = 9; - lcSetCursor = 10;//it generates a lot of messages. so it will be debugged alone - lcPaintBitmap = 11; - lcScroll = 12; - lcPaintDetails = 13; - lcCheck = 14; - lcEditLink = 15; - -var - Logger: TLCLLogger; - - - function GetSelectedNodes(Sender: TLogger; Data: Pointer; var DoSend: Boolean): String; - -implementation - -uses - VirtualTrees, sysutils; - -type - TNodeData = record - Title: String; - end; - PNodeData = ^TNodeData; - - function GetSelectedNodes(Sender: TLogger; Data: Pointer; var DoSend: Boolean): String; - var - i: Integer; - TempNode: PVirtualNode; - begin - with TBaseVirtualTree(Data) do - begin - Result:='SelectedCount: '+IntToStr(SelectedCount)+LineEnding; - TempNode:=GetFirstSelected; - if TempNode = nil then exit; - Result:=Result+PNodeData(GetNodeData(TempNode))^.Title+LineEnding; - for i:= 1 to SelectedCount -1 do - begin - TempNode:=GetNextSelected(TempNode); - Result:=Result+PNodeData(GetNodeData(TempNode))^.Title+LineEnding; - end; - end; - end; - - -initialization - Logger:=TLCLLogger.Create; -finalization - Logger.Free; -end. -