Skip to content

Commit

Permalink
Fix header cursors and borderStyle
Browse files Browse the repository at this point in the history 
Added TReader(Filer).OnPropertyNotFound to ignore some unsupported properties
  • Loading branch information
@salvadorbs
salvadorbs committed Jan 9, 2024
1 parent da5ae31 commit 027d4bd
Show file tree
Hide file tree
Showing 3 changed files with 44 additions and 23 deletions.
52 changes: 38 additions & 14 deletions Source/VirtualTrees.BaseTree.pas
View file
Original file line number Diff line number Diff line change
Expand Up @@ -284,7 +284,7 @@ TClipboardFormats = class(TStringList)
TVTAfterColumnWidthTrackingEvent = procedure(Sender: TVTHeader; Column: TColumnIndex) of object;
TVTColumnWidthTrackingEvent = procedure(Sender: TVTHeader; Column: TColumnIndex; Shift: TShiftState; var TrackPoint: TPoint; P: TPoint;
var Allowed: Boolean) of object;
TVTGetHeaderCursorEvent = procedure(Sender: TVTHeader; var Cursor: TVTCursor) of object;
TVTGetHeaderCursorEvent = procedure(Sender: TVTHeader; var Cursor: TCursor) of object;
TVTBeforeGetMaxColumnWidthEvent = procedure(Sender: TVTHeader; Column: TColumnIndex; var UseSmartColumnWidth: Boolean) of object;
TVTAfterGetMaxColumnWidthEvent = procedure(Sender: TVTHeader; Column: TColumnIndex; var MaxWidth: TDimension) of object;
TVTCanSplitterResizeColumnEvent = procedure(Sender: TVTHeader; P: TPoint; Column: TColumnIndex; var Allowed: Boolean) of object;
Expand Down Expand Up @@ -422,7 +422,7 @@ TVTVirtualNodeEnumeration = record
TBaseVirtualTree = class abstract(TVTBaseAncestor)
private
FTotalInternalDataSize: Cardinal; // Cache of the sum of the necessary internal data size for all tree
FBorderStyle: TBorderStyle;
//FBorderStyle: TBorderStyle;
FHeader: TVTHeader;
FRoot: PVirtualNode;
FDefaultNodeHeight,
Expand Down Expand Up @@ -569,7 +569,7 @@ TBaseVirtualTree = class abstract(TVTBaseAncestor)

// miscellanous
FPanningWindow: TVirtualPanningWindow; // Helper window for wheel panning
FPanningCursor: TVTCursor; // Current wheel panning cursor.
FPanningCursor: TCursor; // 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.
FOperationCount: Cardinal; // Counts how many nested long-running operations are in progress.
Expand Down Expand Up @@ -760,6 +760,8 @@ TBaseVirtualTree = class abstract(TVTBaseAncestor)
NewRect: TRect): Boolean;
procedure ClearNodeBackground(const PaintInfo: TVTPaintInfo; UseBackground, Floating: Boolean; R: TRect);
function CompareNodePositions(Node1, Node2: PVirtualNode; ConsiderChildrenAbove: Boolean = False): Integer;
procedure DoPropertyNotFound(Reader: TReader; Instance: TPersistent;
var PropName: string; IsPath: boolean; var Handled, Skip: Boolean);
procedure DrawLineImage(const PaintInfo: TVTPaintInfo; X, Y, H, VAlign: TDimension; Style: TVTLineType; Reverse: Boolean);
function FindInPositionCache(Node: PVirtualNode; var CurrentPos: TDimension): PVirtualNode; overload;
function FindInPositionCache(Position: TDimension; var CurrentPos: TDimension): PVirtualNode; overload;
Expand Down Expand Up @@ -815,7 +817,9 @@ TBaseVirtualTree = class abstract(TVTBaseAncestor)
procedure SetBackground(const Value: TVTBackground);
procedure SetBackGroundImageTransparent(const Value: Boolean);
procedure SetBackgroundOffset(const Index: Integer; const Value: TDimension);
{
procedure SetBorderStyle(Value: TBorderStyle);
}
procedure SetBottomNode(Node: PVirtualNode);
procedure SetBottomSpace(const Value: TDimension);
procedure SetButtonFillMode(const Value: TVTButtonFillMode);
Expand Down Expand Up @@ -956,9 +960,9 @@ TBaseVirtualTree = class abstract(TVTBaseAncestor)
FFontChanged: Boolean; // flag for keeping informed about font changes in the off screen buffer // [IPK] - private to protected
procedure AutoScale(); virtual;
procedure AddToSelection(const NewItems: TNodeArray; NewLength: Integer; ForceInsert: Boolean = False); overload; virtual;
procedure AdjustImageBorder(Images: TCustomImageList; BidiMode: TBidiMode; VAlign: Integer; var R: TRect;
procedure AdjustImageBorder(Images: TCustomImageList; BidiMode: TBidiMode; VAlign: TDimension; var R: TRect;
var ImageInfo: TVTImageInfo); virtual; overload;
procedure AdjustImageBorder(ImageWidth, ImageHeight: Integer; BidiMode: TBidiMode; VAlign: Integer; var R: TRect;
procedure AdjustImageBorder(ImageWidth, ImageHeight: TDimension; BidiMode: TBidiMode; VAlign: TDimension; var R: TRect;
var ImageInfo: TVTImageInfo); overload;
procedure AdjustPaintCellRect(var PaintInfo: TVTPaintInfo; var NextNonEmpty: TColumnIndex); virtual;
procedure AdjustPanningCursor(X, Y: TDimension); virtual;
Expand All @@ -984,9 +988,7 @@ TBaseVirtualTree = class abstract(TVTBaseAncestor)
procedure CreateParams(var Params: TCreateParams); override;
procedure CreateWnd; override;
procedure DecVisibleCount;
{$IFDEF DelphiSupport}
procedure DefineProperties(Filer: TFiler); override;
{$ENDIF}
procedure DeleteNode(Node: PVirtualNode; Reindex: Boolean; ParentClearing: Boolean); overload;
procedure DestroyHandle; override;
function DetermineDropMode(const P: TPoint; var HitInfo: THitInfo; var NodeRect: TRect): TDropMode; virtual;
Expand Down Expand Up @@ -1057,7 +1059,7 @@ TBaseVirtualTree = class abstract(TVTBaseAncestor)
function DoGetCellContentMargin(Node: PVirtualNode; Column: TColumnIndex;
CellContentMarginType: TVTCellContentMarginType = ccmtAllSides; Canvas: TCanvas = nil): TPoint; virtual;
procedure DoGetCursor(var Cursor: TCursor); virtual;
procedure DoGetHeaderCursor(var Cursor: TVTCursor); virtual;
procedure DoGetHeaderCursor(var Cursor: TCursor); virtual;
procedure DoGetHintSize(Node: PVirtualNode; Column: TColumnIndex; var R:
TRect); virtual;
procedure DoGetHintKind(Node: PVirtualNode; Column: TColumnIndex; var Kind:
Expand Down Expand Up @@ -1259,7 +1261,11 @@ TBaseVirtualTree = class abstract(TVTBaseAncestor)
property BackGroundImageTransparent: Boolean read FBackGroundImageTransparent write SetBackGroundImageTransparent default False;
property BackgroundOffsetX: TDimension index 0 read FBackgroundOffsetX write SetBackgroundOffset stored IsStored_BackgroundOffsetXY; // default 0;
property BackgroundOffsetY: TDimension index 1 read FBackgroundOffsetY write SetBackgroundOffset stored IsStored_BackgroundOffsetXY; // default 0;
//lcl: incompatible with lazarus' borderStyle
{
property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle default TFormBorderStyle.bsSingle;
}
property BorderStyle;
property BottomSpace: TDimension read FBottomSpace write SetBottomSpace stored IsStored_BottomSpace; //default 0;
property ButtonFillMode: TVTButtonFillMode read FButtonFillMode write SetButtonFillMode default fmTreeColor;
property ButtonStyle: TVTButtonStyle read FButtonStyle write SetButtonStyle default bsRectangle;
Expand Down Expand Up @@ -2220,8 +2226,8 @@ procedure InitializeGlobalStructures();

// Delphi (at least version 6 and lower) does not provide a standard split cursor.
// Hence we have to load our own.
Screen.Cursors[crHeaderSplit] := LoadCursor(TheInstance, 'VT_HEADERSPLIT');
Screen.Cursors[crVertSplit] := LoadCursor(TheInstance, 'VT_VERTSPLIT');
//Screen.Cursors[crHeaderSplit] := LoadCursor(TheInstance, 'VT_HEADERSPLIT');
//Screen.Cursors[crVertSplit] := LoadCursor(TheInstance, 'VT_VERTSPLIT');
// Clipboard format registration.
// Native clipboard format. Needs a new identifier and has an average priority to allow other formats to take over.
// This format is supposed to use the IStream storage format but unfortunately this does not work when
Expand Down Expand Up @@ -2343,7 +2349,7 @@ constructor TBaseVirtualTree.Create(AOwner: TComponent);
FSelectedHotPlusBM := TBitmap.Create;
FSelectedHotMinusBM := TBitmap.Create;

FBorderStyle := TFormBorderStyle.bsSingle;
BorderStyle := TFormBorderStyle.bsSingle;
FButtonStyle := bsRectangle;
FButtonFillMode := fmTreeColor;

Expand Down Expand Up @@ -3235,6 +3241,21 @@ function TBaseVirtualTree.CompareNodePositions(Node1, Node2: PVirtualNode; Consi
end;
end;

procedure TBaseVirtualTree.DoPropertyNotFound(Reader: TReader;
Instance: TPersistent; var PropName: string; IsPath: boolean; var Handled,
Skip: Boolean);
begin
//lcl: skip delphi only properties or events
if (PropName = 'BevelEdges') or (PropName = 'BevelEdges') or (PropName = 'BevelInner') or (PropName = 'BevelKind') or
(PropName = 'BevelOuter') or (PropName = 'BevelWidth') or (PropName = 'Ctl3D') or (PropName = 'ParentCtl3D') or
(PropName = 'StyleElements') or (PropName = 'StyleName') or (PropName = 'OnCanResize') or (PropName = 'OnGesture') or
(PropName = 'Touch') then
begin
Handled := True;
Skip := True;
end;
end;

//----------------------------------------------------------------------------------------------------------------------

procedure TBaseVirtualTree.DrawLineImage(const PaintInfo: TVTPaintInfo; X, Y, H, VAlign: TDimension; Style: TVTLineType;
Expand Down Expand Up @@ -4716,6 +4737,7 @@ procedure TBaseVirtualTree.SetBackgroundOffset(const Index: Integer; const Value

//----------------------------------------------------------------------------------------------------------------------

{
procedure TBaseVirtualTree.SetBorderStyle(Value: TBorderStyle);

begin
Expand All @@ -4725,6 +4747,7 @@ procedure TBaseVirtualTree.SetBorderStyle(Value: TBorderStyle);
RecreateWnd;
end;
end;
}

//----------------------------------------------------------------------------------------------------------------------

Expand Down Expand Up @@ -9576,7 +9599,6 @@ procedure TBaseVirtualTree.DecVisibleCount;

//----------------------------------------------------------------------------------------------------------------------

{$IFDEF DelphiSupport}
procedure TBaseVirtualTree.DefineProperties(Filer: TFiler);

// There were heavy changes in some properties during development of VT. This method helps to make migration easier
Expand Down Expand Up @@ -9610,8 +9632,10 @@ procedure TBaseVirtualTree.DefineProperties(Filer: TFiler);
Filer.DefineProperty('CheckImageKind', FakeReadIdent, nil, false);
/// #730 removed property HintAnimation
Filer.DefineProperty('HintAnimation', FakeReadIdent, nil, false);

//lcl: ignore delphi only properties or events
TReader(Filer).OnPropertyNotFound := DoPropertyNotFound;
end;
{$ENDIF}

procedure TBaseVirtualTree.DestroyHandle;
begin
Expand Down Expand Up @@ -11029,7 +11053,7 @@ procedure TBaseVirtualTree.DoGetCursor(var Cursor: TCursor);

//----------------------------------------------------------------------------------------------------------------------

procedure TBaseVirtualTree.DoGetHeaderCursor(var Cursor: TVTCursor);
procedure TBaseVirtualTree.DoGetHeaderCursor(var Cursor: TCursor);

begin
if Assigned(FOnGetHeaderCursor) then
Expand Down
13 changes: 5 additions & 8 deletions Source/VirtualTrees.Header.pas
View file
Original file line number Diff line number Diff line change
Expand Up @@ -421,9 +421,7 @@ TVTHeader = class(TPersistent)
procedure RescaleHeader;
procedure UpdateMainColumn;
procedure UpdateSpringColumns;
{$IFDEF DelphiSupport}
procedure WriteColumns(Writer : TWriter);
{$ENDIF}
procedure InternalSetMainColumn(const Index : TColumnIndex);
procedure InternalSetAutoSizeIndex(const Index : TColumnIndex);
procedure InternalSetSortColumn(const Index : TColumnIndex);
Expand Down Expand Up @@ -1568,7 +1566,7 @@ function TVTHeader.HandleMessage(var Message: TLMessage): Boolean;
I : TColumnIndex;
OldPosition : Integer;
HitIndex : TColumnIndex;
NewCursor : TVTCursor;
NewCursor : TCursor;
Button : TMouseButton;
IsInHeader, IsHSplitterHit, IsVSplitterHit : Boolean;

Expand Down Expand Up @@ -1976,13 +1974,14 @@ function TVTHeader.HandleMessage(var Message: TLMessage): Boolean;
else
IsVSplitterHit := InHeaderSplitterArea(P) and Self.CanSplitterResize(P);

//lcl: in lazarus we must use TCursor
if IsVSplitterHit or IsHSplitterHit then
begin
NewCursor := Screen.Cursors[Tree.Cursor];
NewCursor := Tree.Cursor;
if IsVSplitterHit and ((hoHeightResize in FOptions) or (csDesigning in Tree.ComponentState)) then
NewCursor := Screen.Cursors[crVSplit]
NewCursor := crVSplit
else if IsHSplitterHit then
NewCursor := Screen.Cursors[crHSplit];
NewCursor := crHSplit;

if not (csDesigning in Tree.ComponentState) then
Tree.DoGetHeaderCursor(NewCursor);
Expand Down Expand Up @@ -2276,7 +2275,6 @@ procedure TVTHeader.UpdateSpringColumns;

//----------------------------------------------------------------------------------------------------------------------

{$IFDEF DelphiSupport}
type
//--- HACK WARNING!
//This type cast is a partial rewrite of the private section of TWriter. The purpose is to have access to
Expand Down Expand Up @@ -2315,7 +2313,6 @@ procedure TVTHeader.WriteColumns(Writer : TWriter);
TWriterHack(Writer).FPropPath := LastPropPath;
end;
end;
{$ENDIF}

//----------------------------------------------------------------------------------------------------------------------

Expand Down
2 changes: 1 addition & 1 deletion Source/VirtualTrees.Types.pas
View file
Original file line number Diff line number Diff line change
Expand Up @@ -170,7 +170,7 @@ interface
type
TDimension = Integer;
PDimension = ^Integer;
TVTCursor = LCLType.HCURSOR;
//TVTCursor = LCLType.HCURSOR;
TVTDragDataObject = IDataObject;
TVTBackground = TPicture;
TVTPaintContext = HDC;
Expand Down

0 comments on commit 027d4bd

Please sign in to comment.