checktreeview.pas

CheckTreeView 控件

unit CheckTreeView;

interface

{$DEFINE VCL70_OR_HIGHER}
{$DEFINE VCL60_OR_HIGHER}

uses
  Windows,
  Messages,
  SysUtils,
  Classes,
  Graphics,
  Controls,
  Forms,
  Dialogs,
  StdCtrls,
  ComCtrls,
  CommCtrl,
  Menus,
  ImgList;

const
  STATE_UNCHECKED   = 1;
  STATE_CHECKED     = 2;
  STATE_PARTCHECKED = 3;

type
  TCheckTvOnNodeContextMenuEvent = procedure( aSender: TObject; aNode: TTreeNode; var aPos: TPoint;
                                           var aMenu: TPopupMenu ) of object;

  TCheckCustomTreeView = class( TCustomTreeView )
  private
    FUpdatingColor: Boolean;
    FDisabledColor: TColor;
    FFocusColor: TColor;
    FNormalColor: TColor;

    FAutoSelect: Boolean;
    FSelectionPen: TPen;
    FOnMouseEnter: TNotifyEvent;
    FOnMouseLeave: TNotifyEvent;

    FRClickNode: TTreeNode;
    FOnNodeContextMenu: TCheckTvOnNodeContextMenuEvent;
    FMenuAlreadyHandled: Boolean;
    procedure CMSysColorChange( var Msg: TMessage ); message cm_SysColorChange;
    procedure CNNotify( var Msg: TWMNotify ); message cn_Notify;
    procedure WMRButtonUp( var Msg: TWMRButtonUp ); message wm_RButtonUp;
    procedure WMContextMenu( var Msg: TMessage ); message wm_ContextMenu;

    { Internal Event Handlers }
    procedure PenChanged( Sender: TObject );

    { Message Handling Methods }
    procedure CMEnabledChanged( var Msg: TMessage ); message cm_EnabledChanged;
    procedure WMPaint( var Msg: TWMPaint ); message wm_Paint;
    procedure WMNCPaint( var Msg: TWMNCPaint ); message wm_NCPaint;
    procedure CMEnter( var Msg: TCMEnter ); message cm_Enter;
    procedure CMExit( var Msg: TCMExit ); message cm_Exit;
    procedure CMMouseEnter( var Msg: TMessage ); message cm_MouseEnter;
    procedure CMMouseLeave( var Msg: TMessage ); message cm_MouseLeave;
    procedure WMSize( var Msg: TWMSize ); message wm_Size;
  protected
    FCanvas: TControlCanvas;
    FOverControl: Boolean;
    FRecreating: Boolean;

    procedure CreateParams( var Params: TCreateParams ); override;
    procedure Loaded; override;
    procedure Notification( AComponent: TComponent; Operation: TOperation ); override;

    procedure UpdateColors; virtual;

    { Event Dispatch Methods }
    procedure MouseEnter; dynamic;
    procedure MouseLeave; dynamic;

    procedure Collapse( Node: TTreeNode ); override;
    procedure Expand( Node: TTreeNode ); override;

    function DoMouseWheelDown( Shift: TShiftState; MousePos: TPoint ): Boolean; override;
    function DoMouseWheelUp( Shift: TShiftState; MousePos: TPoint ): Boolean; override;

    procedure DoPreNodeContextMenu; dynamic;
    procedure DoNodeContextMenu( Node: TTreeNode; P: TPoint ); dynamic;
    procedure KeyDown( var Key: Word;  ShiftState: TShiftState ); override;
    procedure NodeContextMenu( Node: TTreeNode; var Pos: TPoint; var Menu: TPopupMenu ); dynamic;

    function GetSelected: TTreeNode;
    procedure SetSelected( Value: TTreeNode );

    { Property Access Methods }
    function GetColor: TColor; virtual;
    procedure SetColor( Value: TColor ); virtual;
    function IsColorStored: Boolean;
    function IsFocusColorStored: Boolean;
    function GetAutoExpand: Boolean; virtual;
    procedure SetAutoExpand( Value: Boolean ); virtual;
    procedure SetAutoSelect( Value: Boolean ); virtual;
    procedure SetDisabledColor( Value: TColor ); virtual;
    procedure SetFocusColor( Value: TColor ); virtual;
    procedure SetSelectionPen( Value: TPen ); virtual;

    { Property Declarations }

    property AutoExpand: Boolean
      read GetAutoExpand
      write SetAutoExpand
      default False;

    property AutoSelect: Boolean
      read FAutoSelect
      write SetAutoSelect
      default False;

    property Color: TColor
      read GetColor
      write SetColor
      stored IsColorStored
      default clWindow;

    property DisabledColor: TColor
      read FDisabledColor
      write SetDisabledColor
      default clBtnFace;

    property FocusColor: TColor
      read FFocusColor
      write SetFocusColor
      stored IsFocusColorStored
      default clWindow;

    property SelectionPen: TPen
      read FSelectionPen
      write SetSelectionPen;

    property OnMouseEnter: TNotifyEvent
      read FOnMouseEnter
      write FOnMouseEnter;

    property OnMouseLeave: TNotifyEvent
      read FOnMouseLeave
      write FOnMouseLeave;

    { Inherited Properties & Events }
    property ParentColor default False;
    property TabStop default True;

    property OnMouseWheelUp;
    property OnMouseWheelDown;

    property OnNodeContextMenu: TCheckTvOnNodeContextMenuEvent
      read FOnNodeContextMenu
      write FOnNodeContextMenu;
  public
    constructor Create( AOwner: TComponent ); override;
    destructor Destroy; override;

    function UseThemes: Boolean; virtual;

    function NodeFromPath( Path: string ): TTreeNode;
    function PathFromNode( Node: TTreeNode ): string;
    procedure SelectByPath( const Path: string );

    procedure UpdateStateIndexDisplay( Node: TTreeNode );

    procedure FullCollapse;
    procedure FullExpand;

    procedure InvalidateNode( Node: TTreeNode; TextOnly: Boolean; EraseBkgnd: Boolean );

    property Selected: TTreeNode
      read GetSelected
      write SetSelected;
  end;

  TCheckCheckState = ( csUnknown, csUnchecked, csChecked, csPartiallyChecked );

  TCheckTreeChangingEvent = procedure( Sender: TObject; Node: TTreeNode; NewState: TCheckCheckState;
                                         var AllowChange: Boolean ) of object;

  TCheckTreeChangeEvent = procedure( Sender: TObject; Node: TTreeNode; NewState: TCheckCheckState ) of object;

  TCheckTree = class( TCheckCustomTreeView )
  private
    FSelectedItem: Integer;
    FBmpWidth: Integer;
    FImageWidth: Integer;
    FChangingState: Boolean;
    FSuspendCascades: Boolean;
    FCheckImages: TImageList;
    FCascadeChecks: Boolean;
    FSilentStateChanges: Boolean;
    FHighlightColor: TColor;

    FOnStateChanging: TCheckTreeChangingEvent;
    FOnStateChange: TCheckTreeChangeEvent;
    FOnUpdateChildren: TNotifyEvent;

    function GetItemState( AbsoluteIndex: Integer ): TCheckCheckState;
    procedure SetItemState( AbsoluteIndex: Integer; Value: TCheckCheckState );
    procedure SetNodeCheckState( Node:TTreeNode; NewState: TCheckCheckState );
    procedure RecurseChildren( Node: TTreeNode; NodeChecked: Boolean );
    procedure SetAllChildren( Node: TTreeNode; NewState: TCheckCheckState );

    procedure WMPaint( var Msg: TWMPaint ); message wm_Paint;
  protected
    procedure Loaded; override;

    procedure UpdateImageWidth; virtual;
    procedure InitStateImages; virtual;
    procedure UpdateParents( Node: TTreeNode; NodeChecked: Boolean ); virtual;
    procedure UpdateChildren( Node: TTreeNode; NodeChecked: Boolean ); virtual;

    { Event Dispatch Methods }
    function  CanChangeState( Node: TTreeNode; NewState: TCheckCheckState ): Boolean; dynamic;
    procedure StateChange( Node: TTreeNode; NewState: TCheckCheckState ); dynamic;

    procedure MouseDown( Button: TMouseButton; Shift: TShiftState; X, Y: Integer ); override;
    procedure MouseUp( Button: TMouseButton; Shift: TShiftState; X, Y: Integer ); override;
    procedure KeyUp( var Key: Word; Shift: TShiftState ); override;
    procedure WMChar( var Msg: TWMChar ); message wm_Char ;

    { Property Access Methods }
    function GetImages: TCustomImageList;
    procedure SetImages( Value: TCustomImageList );
    procedure SetHighlightColor( Value: TColor );
  public
    constructor Create( AOwner: TComponent ); override;
    destructor Destroy; override;

    procedure ToggleCheckState( Node: TTreeNode );
    procedure ChangeNodeCheckState( Node: TTreeNode; NewState: TCheckCheckState );
    procedure ForceCheckState( Node : TTreeNode; NewState: TCheckCheckState );
    procedure SetAllNodes( NewState: TCheckCheckState );

    procedure UpdateCascadingStates( Node: TTreeNode );
    procedure UpdateChildrenCascadingStates( ParentNode: TTreeNode );

    procedure LoadFromFile( const FileName: string );
    procedure LoadFromStream( Stream: TStream );
    procedure SaveToFile( const FileName: string );
    procedure SaveToStream( Stream: TStream );

    property ItemState[ Index: Integer ]: TCheckCheckState
      read GetItemState
      write SetItemState;

    property SilentCheckChanges: Boolean
      read FSilentStateChanges
      write FSilentStateChanges;
  published
    property CascadeChecks: Boolean
      read FCascadeChecks
      write FCascadeChecks
      default True;

    property HighlightColor: TColor
      read FHighlightColor
      write SetHighlightColor
      default clHighlight;

    property Images: TCustomImageList
      read GetImages
      write SetImages;

    property OnStateChanging: TCheckTreeChangingEvent
      read FOnStateChanging
      write FOnStateChanging;

    property OnStateChange: TCheckTreeChangeEvent
      read FOnStateChange
      write FOnStateChange;

    property OnUpdateChildren: TNotifyEvent
      read FOnUpdateChildren
      write FOnUpdateChildren;

    { Inherited Properties and Events }
    property Align;
    property Anchors;
    property AutoExpand;
    property AutoSelect;
    property BiDiMode;
    property BorderStyle;
    property BorderWidth;
    property ChangeDelay;
    property Color;
    property Constraints;
    property Ctl3D;
    property DisabledColor;
    property DragCursor;
    property DragKind;
    property DragMode;
    property Enabled;
    property Font;
    property FocusColor;
    property HideSelection;
    property HotTrack;
    property Indent;

    property MultiSelect;
    property MultiSelectStyle;

    property ParentBiDiMode;
    property ParentColor;
    property ParentCtl3D;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property ReadOnly default True;
    property RightClickSelect;
    property RowSelect;
    property SelectionPen;
    property ShowButtons;
    property ShowHint;
    property ShowLines;
    property ShowRoot;
    property SortType;
    property StateImages;
    property TabOrder;
    property TabStop;
    property Visible;

    property OnAddition;

    property OnAdvancedCustomDraw;
    property OnAdvancedCustomDrawItem;

    property OnCancelEdit;

    property OnChange;
    property OnChanging;
    property OnClick;
    property OnCollapsed;
    property OnCollapsing;
    property OnCompare;
    property OnContextPopup;

    property OnCreateNodeClass;

    property OnCustomDraw;
    property OnCustomDrawItem;
    property OnDblClick;
    property OnDeletion;
    property OnDragDrop;
    property OnDragOver;
    property OnEdited;
    property OnEditing;
    property OnEndDock;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnExpanded;
    property OnExpanding;
    property OnGetImageIndex;
    property OnGetSelectedIndex;
    property OnKeyDown;
    property OnKeyPress;
    property OnKeyUp;
    property OnMouseDown;
    property OnMouseEnter;
    property OnMouseLeave;
    property OnMouseMove;
    property OnMouseUp;
    property OnMouseWheelDown;
    property OnMouseWheelUp;
    property OnStartDock;
    property OnStartDrag;

    property Items;
  end;


function LastChar( const S: string ): Char;
function CountChar( C: Char; const S: string ): Integer;
function CopyEx( const S: string; Start: Integer; C: Char; Count: Integer ): string;
function RemoveChar( var S: string; C: Char ): Boolean;

function IsWin95: Boolean;
function IsOSR2OrGreater: Boolean;          // Returns TRUE if running Win95 OSR2 or higher.
function IsWinNT: Boolean;
function IsWin2000: Boolean;
function HasWin95Shell: Boolean;

procedure Register;

implementation

uses
  Themes,
  TypInfo,
  ComStrs;

procedure Register;
begin
  RegisterComponents('FrameWork', [TCheckTree]);
end;

{$R checkcommonbitmap.res}

{-- General Utilities ----------------}
var
  gOSVer: TOSVersionInfo;
  //g_IShm: IMalloc_NRC = nil;

function IsWin95: Boolean;
begin
  Result := ( gOSVer.dwPlatformId = VER_PLATFORM_WIN32_WINDOWS );
end;

function IsOSR2OrGreater: Boolean;          // Returns TRUE if running Win95 OSR2 or higher.
begin
  Result := IsWin95 and ( LoWord( gOsVer.dwBuildNumber ) > 1000 );
end;

function IsWinNT: Boolean;
begin
  Result := ( gOSVer.dwPlatformId = VER_PLATFORM_WIN32_NT );
end;

function IsWin2000: Boolean;
begin
  Result := ( gOSVer.dwPlatformId = VER_PLATFORM_WIN32_NT ) and ( gOsVer.dwMajorVersion >= 5 );
end;

function HasWin95Shell: Boolean;
begin
  Result := IsWin95 or ( IsWinNT and ( gOSVer.dwMajorVersion >= 4 ) );
end;


function LastChar( const S: string ): Char;
begin
  Result := S[ Length( S ) ];
end;


function CountChar( C: Char; const S: string ): Integer;
var
  I: Integer;
begin
  Result := 0;
  for I := 1 to Length( S ) do
  begin
    if S[ I ] = C then
      Inc( Result );
  end;
end;


{===============================================================================
  function CopyEx

  This function is an enhanced version of the Copy function. Instead of
  specifying the number of characters to copy, the last character copied is
  determined by the Count instance of the C character in the string.

  For example,
    S := CopyEx( 'C:\Windows\System, 1, '\', 2 );

    S will be 'C:\Windows\'
===============================================================================}

function CopyEx( const S: string; Start: Integer; C: Char; Count: Integer ): string;
var
  I, J: Integer;
begin
  Result := S;
  J := 0;
  for I := Start to Length( S ) do
  begin
    if S[ I ] = C then
      Inc( J );

    if J = Count then
    begin
      Result := Copy( S, Start, I );
      Break;
    end;
  end;
end;


function RemoveChar( var S: string; C: Char ): Boolean;
var