-
Notifications
You must be signed in to change notification settings - Fork 261
/
Copy pathVirtualTrees.Header.pas
5926 lines (4991 loc) · 211 KB
/
VirtualTrees.Header.pas
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
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
unit VirtualTrees.Header;
interface
uses
WinApi.Windows,
WinApi.Messages,
System.Classes,
System.Types,
System.Generics.Collections,
Vcl.Graphics,
Vcl.Menus,
Vcl.ImgList,
Vcl.Controls,
Vcl.Themes,
Vcl.GraphUtil,
System.UITypes, // some types moved from Vcl.* to System.UITypes
VirtualTrees.StyleHooks,
VirtualTrees.Utils,
VirtualTrees.Types,
VirtualTrees.DragImage;
{$MINENUMSIZE 1, make enumerations as small as possible}
const
DefaultColumnOptions = [coAllowClick, coDraggable, coEnabled, coParentColor, coParentBidiMode, coResizable,
coShowDropMark, coVisible, coAllowFocus, coEditable, coStyleColor];
type
TVTHeader = class;
TVirtualTreeColumn = class;
// This structure carries all important information about header painting and is used in the advanced header painting.
THeaderPaintInfo = record
TargetCanvas : TCanvas;
Column : TVirtualTreeColumn;
PaintRectangle : TRect;
TextRectangle : TRect;
IsHoverIndex,
IsDownIndex,
IsEnabled,
ShowHeaderGlyph,
ShowSortGlyph,
ShowRightBorder : Boolean;
DropMark : TVTDropMarkMode;
GlyphPos,
SortGlyphPos : TPoint;
SortGlyphSize : TSize;
procedure DrawSortArrow(pDirection : TSortDirection);
procedure DrawDropMark();
end;
TVirtualTreeColumns = class;
TVirtualTreeColumn = class(TCollectionItem)
private
const
cDefaultColumnSpacing = 3;
private
FText,
FHint : string;
FWidth : TDimension;
FPosition : TColumnPosition;
FMinWidth : TDimension;
FMaxWidth : TDimension;
FStyle : TVirtualTreeColumnStyle;
FImageIndex : TImageIndex;
FBiDiMode : TBiDiMode;
FLayout : TVTHeaderColumnLayout;
FMargin,
FSpacing : TDimension;
FOptions : TVTColumnOptions;
FEditOptions : TVTEditOptions;
FEditNextColumn : TDimension;
FTag : NativeInt;
FAlignment : TAlignment;
FCaptionAlignment : TAlignment; // Alignment of the caption.
FLastWidth : TDimension;
FColor : TColor;
FBonusPixel : Boolean;
FSpringRest : Single; // Accumulator for width adjustment when auto spring option is enabled.
FCaptionText : string;
FCheckBox : Boolean;
FCheckType : TCheckType;
FCheckState : TCheckState;
FImageRect : TRect;
FHasImage : Boolean;
FDefaultSortDirection : TSortDirection;
function GetCaptionAlignment : TAlignment;
function GetCaptionWidth : TDimension;
function GetLeft : TDimension;
function IsBiDiModeStored : Boolean;
function IsCaptionAlignmentStored : Boolean;
function IsColorStored : Boolean;
procedure SetAlignment(const Value : TAlignment);
procedure SetBiDiMode(Value : TBiDiMode);
procedure SetCaptionAlignment(const Value : TAlignment);
procedure SetCheckBox(Value : Boolean);
procedure SetCheckState(Value : TCheckState);
procedure SetCheckType(Value : TCheckType);
procedure SetColor(const Value : TColor);
procedure SetImageIndex(Value : TImageIndex);
procedure SetLayout(Value : TVTHeaderColumnLayout);
procedure SetMargin(Value : TDimension);
procedure SetMaxWidth(Value : TDimension);
procedure SetMinWidth(Value : TDimension);
procedure SetOptions(Value : TVTColumnOptions);
procedure SetPosition(Value : TColumnPosition);
procedure SetSpacing(Value : TDimension);
procedure SetStyle(Value : TVirtualTreeColumnStyle);
protected
FLeft : TDimension;
procedure ChangeScale(M, D : TDimension); virtual;
procedure ComputeHeaderLayout(var PaintInfo : THeaderPaintInfo; DrawFormat : Cardinal; CalculateTextRect : Boolean = False);
procedure DefineProperties(Filer : TFiler); override;
procedure GetAbsoluteBounds(var Left, Right : TDimension);
function GetDisplayName : string; override;
function GetText : string; virtual; // [IPK]
procedure SetText(const Value : string); virtual; // [IPK] private to protected & virtual
function GetOwner : TVirtualTreeColumns; reintroduce;
procedure InternalSetWidth(const Value : TDimension); //bypass side effects in SetWidth
procedure ReadHint(Reader : TReader);
procedure ReadText(Reader : TReader);
procedure SetCollection(Value : TCollection); override;
procedure SetWidth(Value : TDimension);
public
constructor Create(Collection : TCollection); override;
destructor Destroy; override;
procedure Assign(Source : TPersistent); override;
function Equals(OtherColumnObj : TObject) : Boolean; override;
function GetRect : TRect; virtual;
property HasImage : Boolean read FHasImage;
property ImageRect : TRect read FImageRect;
procedure LoadFromStream(const Stream : TStream; Version : Integer);
procedure ParentBiDiModeChanged;
procedure ParentColorChanged;
procedure RestoreLastWidth;
function GetEffectiveColor() : TColor;
procedure SaveToStream(const Stream : TStream);
function UseRightToLeftReading : Boolean;
property BonusPixel : Boolean read FBonusPixel write FBonusPixel;
property CaptionText : string read FCaptionText;
property LastWidth : TDimension read FLastWidth;
property Left : TDimension read GetLeft;
property Owner : TVirtualTreeColumns read GetOwner;
property SpringRest : Single read FSpringRest write FSpringRest;
published
property Alignment : TAlignment read FAlignment write SetAlignment default taLeftJustify;
property BiDiMode : TBiDiMode read FBiDiMode write SetBiDiMode stored IsBiDiModeStored;
property CaptionAlignment : TAlignment read GetCaptionAlignment write SetCaptionAlignment
stored IsCaptionAlignmentStored default taLeftJustify;
property CaptionWidth : TDimension read GetCaptionWidth;
property CheckType : TCheckType read FCheckType write SetCheckType default ctCheckBox;
property CheckState : TCheckState read FCheckState write SetCheckState default csUncheckedNormal;
property CheckBox : Boolean read FCheckBox write SetCheckBox default False;
property Color : TColor read FColor write SetColor stored IsColorStored;
property DefaultSortDirection : TSortDirection read FDefaultSortDirection write FDefaultSortDirection default sdAscending;
property Hint : string read FHint write FHint;
property ImageIndex : TImageIndex read FImageIndex write SetImageIndex default - 1;
property Layout : TVTHeaderColumnLayout read FLayout write SetLayout default blGlyphLeft;
property Margin : TDimension read FMargin write SetMargin default 4;
property MaxWidth : TDimension read FMaxWidth write SetMaxWidth default 10000;
property MinWidth : TDimension read FMinWidth write SetMinWidth default 10;
property Options : TVTColumnOptions read FOptions write SetOptions default DefaultColumnOptions;
property EditOptions : TVTEditOptions read FEditOptions write FEditOptions default toDefaultEdit;
property EditNextColumn : TDimension read FEditNextColumn write FEditNextColumn default - 1;
property Position : TColumnPosition read FPosition write SetPosition;
property Spacing : TDimension read FSpacing write SetSpacing default cDefaultColumnSpacing;
property Style : TVirtualTreeColumnStyle read FStyle write SetStyle default vsText;
property Tag : NativeInt read FTag write FTag default 0;
property Text : string read GetText write SetText;
property Width : TDimension read FWidth write SetWidth default 50;
end;
TVirtualTreeColumnClass = class of TVirtualTreeColumn;
TColumnsArray = array of TVirtualTreeColumn;
TCardinalArray = array of Cardinal;
TIndexArray = array of TColumnIndex;
TVirtualTreeColumns = class(TCollection)
private
FHeader : TVTHeader;
FHeaderBitmap : TBitmap; // backbuffer for drawing
FHoverIndex, // currently "hot" column
FDownIndex, // Column on which a mouse button is held down.
FTrackIndex : TColumnIndex; // Index of column which is currently being resized.
FClickIndex : TColumnIndex; // Index of the last clicked column.
FCheckBoxHit : Boolean; // True if the last click was on a header checkbox.
FPositionToIndex : TIndexArray;
FDefaultWidth : TDimension; // the width columns are created with
FNeedPositionsFix : Boolean; // True if FixPositions must still be called after DFM loading or Bidi mode change.
FClearing : Boolean; // True if columns are being deleted entirely.
FColumnPopupMenu : TPopupMenu; // Member for storing the TVTHeaderPopupMenu
function GetCount : Integer;
function GetItem(Index : TColumnIndex) : TVirtualTreeColumn;
function GetNewIndex(P : TPoint; var OldIndex : TColumnIndex) : Boolean;
procedure SetDefaultWidth(Value : TDimension);
procedure SetItem(Index : TColumnIndex; Value : TVirtualTreeColumn);
function GetTreeView: TCustomControl;
protected
// drag support
FDragIndex : TColumnIndex; // index of column currently being dragged
FDropTarget : TColumnIndex; // current target column (index) while dragging
FDropBefore : Boolean; // True if drop position is in the left half of a column, False for the right
// side to drop the dragged column to
procedure AdjustAutoSize(CurrentIndex : TColumnIndex; Force : Boolean = False);
function AdjustDownColumn(P : TPoint) : TColumnIndex;
function AdjustHoverColumn(P : TPoint) : Boolean;
procedure AdjustPosition(Column : TVirtualTreeColumn; Position : Cardinal);
function CanSplitterResize(P : TPoint; Column : TColumnIndex) : Boolean;
procedure DoCanSplitterResize(P : TPoint; Column : TColumnIndex; var Allowed : Boolean); virtual;
procedure DrawButtonText(DC : HDC; Caption : string; Bounds : TRect; Enabled, Hot : Boolean; DrawFormat : Cardinal;
WrapCaption : Boolean);
procedure FixPositions;
function GetColumnAndBounds(P : TPoint; var ColumnLeft, ColumnRight : TDimension; Relative : Boolean = True) : Integer;
function GetOwner : TPersistent; override;
function HandleClick(P : TPoint; Button : TMouseButton; Force, DblClick : Boolean) : Boolean; virtual;
procedure HeaderPopupMenuAddHeaderPopupItem(const Sender : TObject; const Column : TColumnIndex; var Cmd : TAddPopupItemType);
procedure IndexChanged(OldIndex, NewIndex : Integer);
procedure InitializePositionArray;
procedure Notify(Item : TCollectionItem; Action : System.Classes.TCollectionNotification); override;
procedure ReorderColumns(RTL : Boolean);
procedure SetHoverIndex(Index : TColumnIndex);
procedure Update(Item : TCollectionItem); override;
procedure UpdatePositions(Force : Boolean = False);
property HeaderBitmap : TBitmap read FHeaderBitmap;
property PositionToIndex : TIndexArray read FPositionToIndex;
property HoverIndex : TColumnIndex read FHoverIndex write FHoverIndex;
property DownIndex : TColumnIndex read FDownIndex write FDownIndex;
property CheckBoxHit : Boolean read FCheckBoxHit write FCheckBoxHit;
// Mitigator function to use the correct style service for this context (either the style assigned to the control for Delphi > 10.4 or the application style)
function StyleServices(AControl : TControl = nil) : TCustomStyleServices;
public
constructor Create(AOwner : TVTHeader); virtual;
destructor Destroy; override;
function Add : TVirtualTreeColumn; virtual;
procedure AnimatedResize(Column : TColumnIndex; NewWidth : TDimension);
procedure Assign(Source : TPersistent); override;
procedure Clear; virtual;
function ColumnFromPosition(P : TPoint; Relative : Boolean = True) : TColumnIndex; overload; virtual;
function ColumnFromPosition(PositionIndex : TColumnPosition) : TColumnIndex; overload; virtual;
function Equals(OtherColumnsObj : TObject) : Boolean; override;
procedure GetColumnBounds(Column : TColumnIndex; var Left, Right : TDimension);
function GetFirstVisibleColumn(ConsiderAllowFocus : Boolean = False) : TColumnIndex;
function GetLastVisibleColumn(ConsiderAllowFocus : Boolean = False) : TColumnIndex;
function GetFirstColumn : TColumnIndex;
function GetNextColumn(Column : TColumnIndex) : TColumnIndex;
function GetNextVisibleColumn(Column : TColumnIndex; ConsiderAllowFocus : Boolean = False) : TColumnIndex;
function GetPreviousColumn(Column : TColumnIndex) : TColumnIndex;
function GetPreviousVisibleColumn(Column : TColumnIndex; ConsiderAllowFocus : Boolean = False) : TColumnIndex;
function GetScrollWidth : TDimension;
function GetVisibleColumns : TColumnsArray;
function GetVisibleFixedWidth : TDimension;
function IsValidColumn(Column : TColumnIndex) : Boolean;
procedure LoadFromStream(const Stream : TStream; Version : Integer);
procedure PaintHeader(DC : HDC; R : TRect; HOffset : TDimension); overload; virtual;
procedure PaintHeader(TargetCanvas : TCanvas; R : TRect; const Target : TPoint;
RTLOffset : TDimension = 0); overload; virtual;
procedure SaveToStream(const Stream : TStream);
procedure EndUpdate(); override;
function TotalWidth : TDimension;
property Count : Integer read GetCount;
property ClickIndex : TColumnIndex read FClickIndex write FClickIndex;
property DefaultWidth : TDimension read FDefaultWidth write SetDefaultWidth;
property DragIndex : TColumnIndex read FDragIndex write FDragIndex;
property DropBefore : Boolean read FDropBefore write FDropBefore;
property DropTarget : TColumnIndex read FDropTarget write FDropTarget;
property Items[Index : TColumnIndex] : TVirtualTreeColumn read GetItem write SetItem; default;
property Header: TVTHeader read FHeader;
property TrackIndex : TColumnIndex read FTrackIndex write FTrackIndex;
property TreeView : TCustomControl read GetTreeView;
property UpdateCount;
end;
TVirtualTreeColumnsClass = class of TVirtualTreeColumns;
TVTConstraintPercent = 0 .. 100;
TVTFixedAreaConstraints = class(TPersistent)
private
FHeader : TVTHeader;
FMaxHeightPercent, FMaxWidthPercent, FMinHeightPercent, FMinWidthPercent : TVTConstraintPercent;
FOnChange : TNotifyEvent;
procedure SetConstraints(Index : Integer; Value : TVTConstraintPercent);
protected
procedure Change;
property Header : TVTHeader read FHeader;
public
constructor Create(AOwner : TVTHeader);
procedure Assign(Source : TPersistent); override;
property OnChange : TNotifyEvent read FOnChange write FOnChange;
published
property MaxHeightPercent : TVTConstraintPercent index 0 read FMaxHeightPercent write SetConstraints default 0;
property MaxWidthPercent : TVTConstraintPercent index 1 read FMaxWidthPercent write SetConstraints default 95;
property MinHeightPercent : TVTConstraintPercent index 2 read FMinHeightPercent write SetConstraints default 0;
property MinWidthPercent : TVTConstraintPercent index 3 read FMinWidthPercent write SetConstraints default 0;
end;
TVTHeader = class(TPersistent)
private
FOwner : TCustomControl;
FColumns : TVirtualTreeColumns;
FHeight : TDimension;
FFont : TFont;
FParentFont : Boolean;
FOptions : TVTHeaderOptions;
FStyle : TVTHeaderStyle; //button style
FBackgroundColor : TColor;
FAutoSizeIndex : TColumnIndex;
FPopupMenu : TPopupMenu;
FMainColumn : TColumnIndex; //the column which holds the tree
FMaxHeight : TDimension;
FMinHeight : TDimension;
FDefaultHeight : TDimension;
FFixedAreaConstraints : TVTFixedAreaConstraints; //Percentages for the fixed area (header, fixed columns).
FImages : TCustomImageList;
FImageChangeLink : TChangeLink; //connections to the image list to get notified about changes
fSplitterHitTolerance : TDimension; //For property SplitterHitTolerance
FSortColumn : TColumnIndex;
FSortDirection : TSortDirection;
FDragImage : TVTDragImage; //drag image management during header drag
FLastWidth : TDimension; //Used to adjust spring columns. This is the width of all visible columns, not the header rectangle.
FRestoreSelectionColumnIndex : Integer; //The column that is used to implement the coRestoreSelection option
FWasDoubleClick : Boolean; // The previous mouse message was for a double click, that allows us to process mouse-up-messages differently
function GetMainColumn : TColumnIndex;
function GetUseColumns : Boolean;
function IsFontStored : Boolean;
procedure SetAutoSizeIndex(Value : TColumnIndex);
procedure SetBackground(Value : TColor);
procedure SetColumns(Value : TVirtualTreeColumns);
procedure SetDefaultHeight(Value : TDimension);
procedure SetFont(const Value : TFont);
procedure SetHeight(Value : TDimension);
procedure SetImages(const Value : TCustomImageList);
procedure SetMainColumn(Value : TColumnIndex);
procedure SetMaxHeight(Value : TDimension);
procedure SetMinHeight(Value : TDimension);
procedure SetOptions(Value : TVTHeaderOptions);
procedure SetParentFont(Value : Boolean);
procedure SetSortColumn(Value : TColumnIndex);
procedure SetSortDirection(const Value : TSortDirection);
procedure SetStyle(Value : TVTHeaderStyle);
function GetRestoreSelectionColumnIndex : Integer;
function AreColumnsStored: Boolean;
protected
FStates : THeaderStates; //Used to keep track of internal states the header can enter.
FDragStart : TPoint; //initial mouse drag position
FTrackStart : TPoint; //client coordinates of the tracking start point
FTrackPoint : TPoint; //Client coordinate where the tracking started.
FDoingAutoFitColumns : Boolean; //Flag to avoid using the stored width for Main column
procedure FontChanged(Sender : TObject); virtual;
procedure AutoScale(); virtual;
function CanSplitterResize(P : TPoint) : Boolean;
function CanWriteColumns : Boolean; virtual;
procedure ChangeScale(M, D : TDimension); virtual;
function DetermineSplitterIndex(P : TPoint) : Boolean; virtual;
procedure DoAfterAutoFitColumn(Column : TColumnIndex); virtual;
procedure DoAfterColumnWidthTracking(Column : TColumnIndex); virtual;
procedure DoAfterHeightTracking; virtual;
function DoBeforeAutoFitColumn(Column : TColumnIndex; SmartAutoFitType : TSmartAutoFitType) : Boolean; virtual;
procedure DoBeforeColumnWidthTracking(Column : TColumnIndex; Shift : TShiftState); virtual;
procedure DoBeforeHeightTracking(Shift : TShiftState); virtual;
procedure DoCanSplitterResize(P : TPoint; var Allowed : Boolean); virtual;
function DoColumnWidthDblClickResize(Column : TColumnIndex; P : TPoint; Shift : TShiftState) : Boolean; virtual;
function DoColumnWidthTracking(Column : TColumnIndex; Shift : TShiftState; var TrackPoint : TPoint; P : TPoint) : Boolean; virtual;
function DoGetPopupMenu(Column : TColumnIndex; Position : TPoint) : TPopupMenu; virtual;
function DoHeightTracking(var P : TPoint; Shift : TShiftState) : Boolean; virtual;
function DoHeightDblClickResize(var P : TPoint; Shift : TShiftState) : Boolean; virtual;
procedure DoSetSortColumn(Value : TColumnIndex; pSortDirection : TSortDirection); virtual;
procedure FixedAreaConstraintsChanged(Sender : TObject);
function GetColumnsClass : TVirtualTreeColumnsClass; virtual;
function GetOwner : TPersistent; override;
function GetShiftState : TShiftState;
function HandleHeaderMouseMove(var Message : TWMMouseMove) : Boolean;
function HandleMessage(var Message : TMessage) : Boolean; virtual;
procedure ImageListChange(Sender : TObject);
procedure PrepareDrag(P, Start : TPoint);
procedure ReadColumns(Reader : TReader);
procedure RecalculateHeader; virtual;
procedure RescaleHeader;
procedure UpdateMainColumn;
procedure UpdateSpringColumns;
procedure WriteColumns(Writer : TWriter);
procedure InternalSetMainColumn(const Index : TColumnIndex);
procedure InternalSetAutoSizeIndex(const Index : TColumnIndex);
procedure InternalSetSortColumn(const Index : TColumnIndex);
public
constructor Create(AOwner : TCustomControl); virtual;
destructor Destroy; override;
function AllowFocus(ColumnIndex : TColumnIndex) : Boolean;
procedure Assign(Source : TPersistent); override;
procedure AutoFitColumns(); overload;
procedure AutoFitColumns(Animated : Boolean; SmartAutoFitType : TSmartAutoFitType = smaUseColumnOption; RangeStartCol : Integer = NoColumn; RangeEndCol : Integer = NoColumn); overload; virtual;
procedure ColumnDropped(const P: TPoint);
procedure DragTo(P : TPoint);
function InHeader(P : TPoint) : Boolean; virtual;
function InHeaderSplitterArea(P : TPoint) : Boolean; virtual;
procedure Invalidate(Column : TVirtualTreeColumn; ExpandToBorder : Boolean = False; UpdateNowFlag : Boolean = False);
procedure LoadFromStream(const Stream : TStream); virtual;
function ResizeColumns(ChangeBy : TDimension; RangeStartCol : TColumnIndex; RangeEndCol : TColumnIndex; Options : TVTColumnOptions = [coVisible]) : TDimension;
procedure RestoreColumns;
procedure SaveToStream(const Stream : TStream); virtual;
procedure StyleChanged(); virtual;
procedure ToggleSortDirection();
property DragImage : TVTDragImage read FDragImage;
property RestoreSelectionColumnIndex : Integer read GetRestoreSelectionColumnIndex write FRestoreSelectionColumnIndex default NoColumn;
property States : THeaderStates read FStates;
property Treeview : TCustomControl read FOwner;
property UseColumns : Boolean read GetUseColumns;
property doingAutoFitColumns : Boolean read FDoingAutoFitColumns;
published
property AutoSizeIndex : TColumnIndex read FAutoSizeIndex write SetAutoSizeIndex;
property Background : TColor read FBackgroundColor write SetBackground default clBtnFace;
property Columns : TVirtualTreeColumns read FColumns write SetColumns stored AreColumnsStored;
property DefaultHeight : TDimension read FDefaultHeight write SetDefaultHeight default 19;
property Font : TFont read FFont write SetFont stored IsFontStored;
property FixedAreaConstraints : TVTFixedAreaConstraints read FFixedAreaConstraints write FFixedAreaConstraints;
property Height : TDimension read FHeight write SetHeight default 19;
property Images : TCustomImageList read FImages write SetImages;
property MainColumn : TColumnIndex read GetMainColumn write SetMainColumn default 0;
property MaxHeight : TDimension read FMaxHeight write SetMaxHeight default 10000;
property MinHeight : TDimension read FMinHeight write SetMinHeight default 10;
property Options : TVTHeaderOptions read FOptions write SetOptions default [hoColumnResize, hoDrag, hoShowSortGlyphs];
property ParentFont : Boolean read FParentFont write SetParentFont default True;
property PopupMenu : TPopupMenu read FPopupMenu write FPopupMenu;
property SortColumn : TColumnIndex read FSortColumn write SetSortColumn default NoColumn;
property SortDirection : TSortDirection read FSortDirection write SetSortDirection default sdAscending;
property SplitterHitTolerance : TDimension read fSplitterHitTolerance write fSplitterHitTolerance default 8;
//The area in pixels around a spliter which is sensitive for resizing
property Style : TVTHeaderStyle read FStyle write SetStyle default hsThickButtons;
end;
TVTHeaderClass = class of TVTHeader;
implementation
uses
WinApi.ShlObj,
WinApi.ActiveX,
WinApi.UxTheme,
System.Math,
System.SysUtils,
System.Generics.Defaults,
Vcl.Forms,
VirtualTrees.HeaderPopup,
VirtualTrees.BaseTree,
VirtualTrees.BaseAncestorVcl, // to eliminate H2443 about inline expanding
VirtualTrees.DataObject;
type
TVirtualTreeColumnsCracker = class(TVirtualTreeColumns);
TVirtualTreeColumnCracker = class(TVirtualTreeColumn);
TBaseVirtualTreeCracker = class(TBaseVirtualTree);
TVTHeaderHelper = class helper for TVTHeader
public
function Tree : TBaseVirtualTreeCracker;
end;
TVirtualTreeColumnHelper = class helper for TVirtualTreeColumn
function TreeViewControl : TBaseVirtualTreeCracker;
function Header : TVTHeader;
end;
TVirtualTreeColumnsHelper = class helper for TVirtualTreeColumns
function TreeViewControl : TBaseVirtualTreeCracker;
end;
const
cMargin = 2; // the margin between text and the header rectangle
cDownOffset = 1; // the offset of the column header text whit mouse button down
//----------------- TVTFixedAreaConstraints ----------------------------------------------------------------------------
constructor TVTFixedAreaConstraints.Create(AOwner : TVTHeader);
begin
inherited Create;
FMaxWidthPercent := 95;
FHeader := AOwner;
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TVTFixedAreaConstraints.SetConstraints(Index : Integer; Value : TVTConstraintPercent);
begin
case Index of
0 :
if Value <> FMaxHeightPercent then
begin
FMaxHeightPercent := Value;
if (Value > 0) and (Value < FMinHeightPercent) then
FMinHeightPercent := Value;
Change;
end;
1 :
if Value <> FMaxWidthPercent then
begin
FMaxWidthPercent := Value;
if (Value > 0) and (Value < FMinWidthPercent) then
FMinWidthPercent := Value;
Change;
end;
2 :
if Value <> FMinHeightPercent then
begin
FMinHeightPercent := Value;
if (FMaxHeightPercent > 0) and (Value > FMaxHeightPercent) then
FMaxHeightPercent := Value;
Change;
end;
3 :
if Value <> FMinWidthPercent then
begin
FMinWidthPercent := Value;
if (FMaxWidthPercent > 0) and (Value > FMaxWidthPercent) then
FMaxWidthPercent := Value;
Change;
end;
end;
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TVTFixedAreaConstraints.Change;
begin
if Assigned(FOnChange) then
FOnChange(Self);
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TVTFixedAreaConstraints.Assign(Source : TPersistent);
begin
if Source is TVTFixedAreaConstraints then
begin
FMaxHeightPercent := TVTFixedAreaConstraints(Source).FMaxHeightPercent;
FMaxWidthPercent := TVTFixedAreaConstraints(Source).FMaxWidthPercent;
FMinHeightPercent := TVTFixedAreaConstraints(Source).FMinHeightPercent;
FMinWidthPercent := TVTFixedAreaConstraints(Source).FMinWidthPercent;
Change;
end
else
inherited;
end;
//----------------- TVTHeader -----------------------------------------------------------------------------------------
constructor TVTHeader.Create(AOwner : TCustomControl);
begin
inherited Create;
FOwner := AOwner;
FColumns := GetColumnsClass.Create(Self);
FHeight := 19;
FDefaultHeight := FHeight;
FMinHeight := 10;
FMaxHeight := 10000;
FFont := TFont.Create;
FFont.OnChange := FontChanged;
FParentFont := True;
FBackgroundColor := clBtnFace;
FOptions := [hoColumnResize, hoDrag, hoShowSortGlyphs];
FImageChangeLink := TChangeLink.Create;
FImageChangeLink.OnChange := ImageListChange;
FSortColumn := NoColumn;
FSortDirection := sdAscending;
FMainColumn := NoColumn;
FDragImage := TVTDragImage.Create(AOwner);
fSplitterHitTolerance := 8;
FFixedAreaConstraints := TVTFixedAreaConstraints.Create(Self);
FFixedAreaConstraints.OnChange := FixedAreaConstraintsChanged;
FDoingAutoFitColumns := False;
end;
//----------------------------------------------------------------------------------------------------------------------
destructor TVTHeader.Destroy;
begin
FDragImage.Free;
FFixedAreaConstraints.Free;
FImageChangeLink.Free;
FFont.Free;
FColumns.Clear; //TCollection's Clear method is not virtual, so we have to call our own Clear method manually.
FColumns.Free;
inherited;
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TVTHeader.FontChanged(Sender : TObject);
begin
inherited;
AutoScale();
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TVTHeader.AutoScale();
var
I : Integer;
lMaxHeight : TDimension;
begin
if (toAutoChangeScale in TBaseVirtualTreeCracker(Tree).TreeOptions.AutoOptions) then
begin
//Ensure a minimum header size based on the font, so that all text is visible.
//First find the largest Columns[].Spacing
lMaxHeight := 0;
for I := 0 to Self.Columns.Count - 1 do
lMaxHeight := Max(lMaxHeight, Columns[I].Spacing);
//Calculate the required height based on the font, this is important as the user might just have increased the size of the system icon font.
with TBitmap.Create do
try
Canvas.Font.Assign(FFont);
lMaxHeight := lMaxHeight { top spacing } + Divide(lMaxHeight, 2) { minimum bottom spacing } + Canvas.TextHeight('Q');
finally
Free;
end;
//Set the calculated size
Self.SetHeight(lMaxHeight);
end;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTHeader.GetMainColumn : TColumnIndex;
begin
if FColumns.Count > 0 then
Result := FMainColumn
else
Result := NoColumn;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTHeader.GetUseColumns : Boolean;
begin
Result := FColumns.Count > 0;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTHeader.IsFontStored : Boolean;
begin
Result := not ParentFont;
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TVTHeader.SetAutoSizeIndex(Value : TColumnIndex);
begin
if FAutoSizeIndex <> Value then
begin
FAutoSizeIndex := Value;
if hoAutoResize in FOptions then
TVirtualTreeColumnsCracker(Columns).AdjustAutoSize(InvalidColumn);
end;
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TVTHeader.SetBackground(Value : TColor);
begin
if FBackgroundColor <> Value then
begin
FBackgroundColor := Value;
Invalidate(nil);
end;
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TVTHeader.SetColumns(Value : TVirtualTreeColumns);
begin
FColumns.Assign(Value);
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TVTHeader.SetDefaultHeight(Value : TDimension);
begin
if Value < FMinHeight then
Value := FMinHeight;
if Value > FMaxHeight then
Value := FMaxHeight;
if FHeight = FDefaultHeight then
SetHeight(Value);
FDefaultHeight := Value;
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TVTHeader.SetFont(const Value : TFont);
begin
FFont.Assign(Value);
FParentFont := False;
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TVTHeader.SetHeight(Value : TDimension);
var
RelativeMaxHeight, RelativeMinHeight, EffectiveMaxHeight, EffectiveMinHeight : TDimension;
begin
if not Tree.HandleAllocated then
begin
FHeight := Value;
Include(FStates, hsNeedScaling);
end
else
begin
with FFixedAreaConstraints do
begin
RelativeMaxHeight := Divide((Tree.ClientHeight + FHeight) * FMaxHeightPercent, 100);
RelativeMinHeight := Divide((Tree.ClientHeight + FHeight) * FMinHeightPercent, 100);
EffectiveMinHeight := IfThen(FMaxHeightPercent > 0, Min(RelativeMaxHeight, FMinHeight), FMinHeight);
EffectiveMaxHeight := IfThen(FMinHeightPercent > 0, Max(RelativeMinHeight, FMaxHeight), FMaxHeight);
Value := Min(Max(Value, EffectiveMinHeight), EffectiveMaxHeight);
if FMinHeightPercent > 0 then
Value := Max(RelativeMinHeight, Value);
if FMaxHeightPercent > 0 then
Value := Min(RelativeMaxHeight, Value);
end;
if FHeight <> Value then
begin
FHeight := Value;
if not (csLoading in Tree.ComponentState) and not (hsScaling in FStates) then
RecalculateHeader;
Tree.Invalidate;
end;
end;
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TVTHeader.SetImages(const Value : TCustomImageList);
begin
if FImages <> Value then
begin
if Assigned(FImages) then
begin
FImages.UnRegisterChanges(FImageChangeLink);
FImages.RemoveFreeNotification(FOwner);
end;
FImages := Value;
if Assigned(FImages) then
begin
FImages.RegisterChanges(FImageChangeLink);
FImages.FreeNotification(FOwner);
end;
if not (csLoading in Tree.ComponentState) then
Invalidate(nil);
end;
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TVTHeader.SetMainColumn(Value : TColumnIndex);
begin
if (csLoading in Tree.ComponentState) or (csDestroying in Tree.ComponentState) then
FMainColumn := Value
else
begin
if Value < 0 then
Value := 0;
if Value > FColumns.Count - 1 then
Value := FColumns.Count - 1;
if Value <> FMainColumn then
begin
FMainColumn := Value;
Tree.MainColumnChanged;
if not (toExtendedFocus in Tree.TreeOptions.SelectionOptions) then
Tree.FocusedColumn := FMainColumn;
Tree.Invalidate;
end;
end;
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TVTHeader.SetMaxHeight(Value : TDimension);
begin
if Value < FMinHeight then
Value := FMinHeight;
FMaxHeight := Value;
SetHeight(FHeight);
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TVTHeader.SetMinHeight(Value : TDimension);
begin
if Value < 0 then
Value := 0;
if Value > FMaxHeight then
Value := FMaxHeight;
FMinHeight := Value;
SetHeight(FHeight);
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TVTHeader.SetOptions(Value : TVTHeaderOptions);
var
ToBeSet, ToBeCleared : TVTHeaderOptions;
begin
ToBeSet := Value - FOptions;
ToBeCleared := FOptions - Value;
FOptions := Value;
if (hoAutoResize in (ToBeSet + ToBeCleared)) and (FColumns.Count > 0) then
begin
TVirtualTreeColumnsCracker(FColumns).AdjustAutoSize(InvalidColumn);
if Tree.HandleAllocated then
begin
Tree.UpdateHorizontalScrollBar(False);
if hoAutoResize in ToBeSet then
Tree.Invalidate;
end;
end;
if not (csLoading in Tree.ComponentState) and Tree.HandleAllocated then
begin
if hoVisible in (ToBeSet + ToBeCleared) then
RecalculateHeader;
Invalidate(nil);
Tree.Invalidate;
end;
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TVTHeader.SetParentFont(Value : Boolean);
begin
if FParentFont <> Value then
begin
FParentFont := Value;
if FParentFont then
FFont.Assign(TBaseVirtualTree(FOwner).Font);
end;
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TVTHeader.SetSortColumn(Value : TColumnIndex);
begin
if csLoading in Tree.ComponentState then
FSortColumn := Value
else
DoSetSortColumn(Value, FSortDirection);
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TVTHeader.SetSortDirection(const Value : TSortDirection);
begin
if Value <> FSortDirection then
begin
FSortDirection := Value;
Invalidate(nil);
if ((toAutoSort in Tree.TreeOptions.AutoOptions) or (hoHeaderClickAutoSort in Options)) and (Tree.UpdateCount = 0) then
Tree.SortTree(FSortColumn, FSortDirection, True);
end;
end;
//----------------------------------------------------------------------------------------------------------------------
function TVTHeader.CanSplitterResize(P : TPoint) : Boolean;
begin
Result := hoHeightResize in FOptions;
DoCanSplitterResize(P, Result);
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TVTHeader.SetStyle(Value : TVTHeaderStyle);
begin
if FStyle <> Value then
begin
FStyle := Value;
if not (csLoading in Tree.ComponentState) then
Invalidate(nil);
end;
end;
//----------------------------------------------------------------------------------------------------------------------
procedure TVTHeader.StyleChanged();
begin
AutoScale(); //Elements may have changed in size
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 : TDimension);
var
I : Integer;
begin
//This method is only executed if toAutoChangeScale is set
FMinHeight := MulDiv(FMinHeight, M, D);
FMaxHeight := MulDiv(FMaxHeight, M, D);
Self.Height := MulDiv(FHeight, M, D);
//Scale the columns widths too
for I := 0 to FColumns.Count - 1 do
TVirtualTreeColumnCracker(Self.FColumns[I]).ChangeScale(M, D);
if not ParentFont then
Font.Height := MulDiv(Font.Height, 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
VisibleFixedWidth : TDimension;
SplitPoint : TDimension;
//--------------- local function --------------------------------------------
function IsNearBy(IsFixedCol : Boolean; LeftTolerance, RightTolerance : TDimension) : Boolean;
begin
if IsFixedCol then
Result := (P.X < SplitPoint + Tree.EffectiveOffsetX + RightTolerance) and (P.X > SplitPoint + Tree.EffectiveOffsetX - LeftTolerance)
else
Result := (P.X > VisibleFixedWidth) and (P.X < SplitPoint + RightTolerance) and (P.X > SplitPoint - LeftTolerance);
end;
//--------------- end local function ----------------------------------------
var
I : Integer;
LeftTolerance : TDimension; //The area left of the column divider which allows column resizing
begin
Result := False;
if FColumns.Count > 0 then
begin
FColumns.TrackIndex := NoColumn;
VisibleFixedWidth := FColumns.GetVisibleFixedWidth;
LeftTolerance := Round(SplitterHitTolerance * 0.6);
if Tree.UseRightToLeftAlignment then
begin
SplitPoint := - Tree.EffectiveOffsetX;