virtualtrees.pas

Last change: 2008-02-03 This is the source code of KCeasy。

    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;
    function AnimationCallback(Step, StepSize: Integer; Data: Pointer): Boolean;
    procedure InternalPaint(Step, StepSize: Integer);
    procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED;
    procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
    procedure WMNCPaint(var Message: TMessage); message WM_NCPAINT;
    procedure WMShowWindow(var Message: TWMShowWindow); message WM_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;
  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.
    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 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;