checktreeview.pas

CheckTreeView 控件

var
  Node: TTreeNode;
  P: TPoint;
  Mnu: TPopupMenu;
  OldGetImageEvent: TTVExpandedEvent;
  OldGetSelectedImageEvent: TTVExpandedEvent;

  function GetNodeFromItem( const Item: TTVItem ): TTreeNode;
  begin
    with Item do
      if (state and TVIF_PARAM) <> 0 then
        Result := Pointer(lParam)
      else
        Result := Items.GetNode(hItem);
  end;

begin {= TCheckCustomTreeView.CNNotify =}
  with Msg.NMHdr^ do
    case Code of

      tvn_GetDispInfo:
      begin
        with PTVDispInfo( Pointer( Msg.NMHdr ) )^ do
        begin
          Node := GetNodeFromItem( Item );

          if Assigned( Node ) then
          begin
            if (item.mask and TVIF_IMAGE) <> 0 then
            begin
              GetImageIndex( Node );
              Item.iImage := Node.ImageIndex;
            end;

            if ( Item.mask and tvif_SelectedImage ) <> 0 then
            begin
              GetSelectedIndex( Node );
              Item.iSelectedImage := Node.SelectedIndex;
            end;
          end;

          oldGetImageEvent := OnGetImageIndex;
          oldGetSelectedImageEvent := OnGetSelectedIndex;
          OnGetImageIndex:=nil;
          OnGetSelectedIndex:=nil;
          try
            inherited;
          finally
            OnGetImageIndex := oldGetImageEvent;
            OnGetSelectedIndex := oldGetSelectedImageEvent;
          end;
        end;
      end;

      nm_RClick:
      begin
        // Note: The RightClickSelect property introduced in Delphi 3 can do some of this. We don't use it
        //       in order to maintain Delphi 2 and C++Builder compatibility.
        if not (csDesigning in ComponentState) then
        begin
          GetCursorPos( p );
          p := ScreenToClient( p );
          FRClickNode := GetNodeAt( p.x, p.y );
          if not Assigned( FRClickNode ) then
            FRClickNode := inherited Selected;
          if Assigned( FRClickNode ) then
          begin
            mnu := PopupMenu; // Default is normal popup
            NodeContextMenu( FRClickNode, p, mnu );
            if Assigned( mnu ) then
              with ClientToScreen( p ) do
              begin
                mnu.PopupComponent := self;
                mnu.Popup( x, y );
              end;
            FRClickNode := nil;
            FMenuAlreadyHandled := TRUE;
          end;
        end;

        inherited;
      end;

      else
        inherited;
    end; {case}
end; {TCheckCustomTreeView.CNNotify}


procedure TCheckCustomTreeView.WMRButtonUp( var Msg: TWMRButtonUp );
var
  OldAutoPopup: Boolean;
begin
  if FMenuAlreadyHandled and Assigned(PopupMenu) then
  begin
    OldAutoPopup := PopupMenu.AutoPopup;
    PopupMenu.AutoPopup := FALSE;
    try
      inherited;
    finally
      PopupMenu.AutoPopup := OldAutoPopup;
      FMenuAlreadyHandled := FALSE;
    end;
  end
  else
    inherited;
end;


procedure TCheckCustomTreeView.WMContextMenu( var Msg: TMessage );
begin
  if not ( csDesigning in ComponentState ) and not Assigned( Selected ) and not FMenuAlreadyHandled then
  begin
    if Msg.lParam = -1 then
      DoPreNodeContextMenu
    else
      DoNodeContextMenu( Selected, ScreenToClient( Point( Msg.lParamLo, Msg.lParamHi ) ) );
  end;
end;


// Work around a bug with tooltips in NT4. We just disable them. The bug was fixed around v4.72 of
// comctl32.dll so we don't disable the tooltips for this and later versions.

procedure TCheckCustomTreeView.CreateParams( var Params: TCreateParams );
begin
  inherited;
end;


procedure TCheckCustomTreeView.DoPreNodeContextMenu;
var
  P: TPoint;

  procedure DoDefault;
  begin
    if Assigned( PopupMenu ) then
    begin
      PopupMenu.PopupComponent := Self;
      with ClientToScreen( Point( 0, 0 ) ) do
        PopupMenu.Popup( X, Y );
    end;
  end;

begin
  if Assigned( Selected ) then
  begin
    with Selected.DisplayRect( True ) do
      P := Point( ( Left + Right) div 2, ( Bottom + Top ) div 2 )
  end
  else
  begin
    DoDefault;
    Exit;
  end;
  DoNodeContextMenu( Selected, p );
end; {= TCheckCustomTreeView.DoPreNodeContextMenu =}


procedure TCheckCustomTreeView.DoNodeContextMenu( Node: TTreeNode; P: TPoint );
var
  Menu: TPopupMenu;
begin
  Menu := PopupMenu; // Default to normal popup
  NodeContextMenu( Node, P, Menu );
  if Menu <> PopupMenu then
    FMenuAlreadyHandled := True;
  if Assigned( Menu ) then
  begin
    Menu.PopupComponent := Self;
    with ClientToScreen( P ) do
      Menu.Popup( X, Y );
  end;
end;


procedure TCheckCustomTreeView.KeyDown( var Key: Word; ShiftState: TShiftState );
begin
  if ( ( Key = VK_APPS ) and ( ShiftState = [] ) ) or
     ( ( Key = VK_F10 ) and ( ShiftState = [ ssShift ] ) ) then
  begin
    Key := 0;
    DoPreNodeContextMenu;
  end;
  inherited;
end;


procedure TCheckCustomTreeView.NodeContextMenu( Node: TTreeNode; var Pos: TPoint; var Menu: TPopupMenu );
begin
  if Assigned( FOnNodeContextMenu ) then
    FOnNodeContextMenu( Self, Node, Pos, Menu );
end;


function TCheckCustomTreeView.GetSelected: TTreeNode;
begin
  if HandleAllocated then
  begin
    if RightClickSelect and Assigned( FRClickNode ) then
      Result := FRClickNode
    else
      Result := Items.GetNode( TreeView_GetSelection( Handle ) );
  end
  else
    Result := nil;
end;


procedure TCheckCustomTreeView.SetSelected( Value: TTreeNode );
begin
  inherited Selected := Value;
end;



{=======================================================}
{== TCheckTreeStrings Class Declaration and Methods ==}
{=======================================================}

procedure TreeViewError( const Msg: string );
begin
  raise ETreeViewError.Create( Msg );
end;

procedure TreeViewErrorFmt( const Msg: string; Format: array of const );
begin
  raise ETreeViewError.CreateFmt( Msg, Format );
end;


type
  TCheckTreeStrings = class( TStrings )
  private
    FOwner: TTreeNodes;
  protected
    function Get( Index: Integer ): string; override;
    function GetBufStart( Buffer: PChar; var Level: Integer ): PChar;
    function GetCount: Integer; override;
    function GetObject( Index: Integer ): TObject; override;
    procedure PutObject( Index: Integer; AObject: TObject ); override;
    procedure SetUpdateState( Updating: Boolean ); override;
  public
    constructor Create( AOwner: TTreeNodes );

    function Add( const S: string ): Integer; override;
    procedure Clear; override;
    procedure Delete( Index: Integer ); override;
    procedure Insert( Index: Integer; const S: string ); override;
    procedure LoadTreeFromStream( Stream: TStream );
    procedure SaveTreeToStream( Stream: TStream );
    property Owner: TTreeNodes
      read FOwner;
  end;

constructor TCheckTreeStrings.Create( AOwner: TTreeNodes );
begin
  inherited Create;
  FOwner := AOwner;
end;


function TCheckTreeStrings.Get( Index: Integer ): string;
const
  TabChar = #9;
var
  Level, I: Integer;
  Node: TTreeNode;
begin
  Result := '';
  Node := Owner.Item[ Index ];
  Level := Node.Level;
  for I := 0 to Level - 1 do
    Result := Result + TabChar;
  Result := Result + Node.Text;
end;


function TCheckTreeStrings.GetBufStart( Buffer: PChar; var Level: Integer ): PChar;
begin
  Level := 0;
  while Buffer^ in [' ', #9] do
  begin
    Inc( Buffer );
    Inc( Level );
  end;
  Result := Buffer;
end;


function TCheckTreeStrings.GetObject( Index: Integer ): TObject;
begin
  Result := Owner.Item[ Index ].Data;
end;


procedure TCheckTreeStrings.PutObject( Index: Integer; AObject: TObject );
begin
  Owner.Item[ Index ].Data := AObject;
end;


function TCheckTreeStrings.GetCount: Integer;
begin
  Result := Owner.Count;
end;


procedure TCheckTreeStrings.Clear;
begin
  Owner.Clear;
end;


procedure TCheckTreeStrings.Delete( Index: Integer );
begin
  Owner.Item[ Index ].Delete;
end;


procedure TCheckTreeStrings.SetUpdateState( Updating: Boolean );
begin
  SendMessage( Owner.Handle, WM_SETREDRAW, Ord( not Updating ), 0 );
  if not Updating then
    Owner.Owner.Refresh;
end;


function TCheckTreeStrings.Add( const S: string ): Integer;
var
  Level, OldLevel, I: Integer;
  NewStr: string;
  Node: TTreeNode;
begin
  Result := GetCount;
  if ( Length( S ) = 1 ) and ( S[ 1 ] = Chr( $1A ) ) then
    Exit;
  Node := nil;
  OldLevel := 0;
  NewStr := GetBufStart( PChar( S ), Level );
  if Result > 0 then
  begin
    Node := Owner.Item[ Result - 1 ];
    OldLevel := Node.Level;
  end;
  if ( Level > OldLevel ) or ( Node = nil ) then
  begin
    if Level - OldLevel > 1 then
      TreeViewError( sInvalidLevel );
  end
  else begin
    for I := OldLevel downto Level do
    begin
      Node := Node.Parent;
      if ( Node = nil ) and ( I - Level > 0 ) then
        TreeViewError( sInvalidLevel );
    end;
  end;
  Owner.AddChild( Node, NewStr );
end;


procedure TCheckTreeStrings.Insert( Index: Integer; const S: string );
begin
  Owner.Insert( Owner.Item[ Index ], S );
end;


procedure TCheckTreeStrings.LoadTreeFromStream( Stream: TStream );
var
  List: TStringList;
  ANode, NextNode: TTreeNode;
  ALevel, I, P, NodeState, NodeImage, NodeImageSel: Integer;
  CurrStr: string;
begin
  List := TStringList.Create;
  Owner.BeginUpdate;
  try
    try
      Clear;
      List.LoadFromStream( Stream );
      ANode := nil;
      for I := 0 to List.Count - 1 do
      begin
        CurrStr := GetBufStart( PChar( List[ I ] ), ALevel );

        NodeState := -1;
        NodeImage := -1;
        NodeImageSel := -1;
        P := Pos( '|', CurrStr );
        if P > 0 then
        begin
          NodeState := StrToInt( Copy( CurrStr, 1, P - 1 ) );
          System.Delete( CurrStr, 1, P );

          P := Pos( '|', CurrStr );
          if P > 0 then
          begin
            NodeImage := StrToInt( Copy( CurrStr, 1, P - 1 ) );
            System.Delete( CurrStr, 1, P );

            P := Pos( '|', CurrStr );
            if P > 0 then
            begin
              NodeImageSel := StrToInt( Copy( CurrStr, 1, P - 1 ) );
              System.Delete( CurrStr, 1, P );
            end;
          end;
        end;

        if ANode = nil then
          ANode := Owner.AddChild( nil, CurrStr )
        else if ANode.Level = ALevel then
          ANode := Owner.AddChild( ANode.Parent, CurrStr )
        else if ANode.Level = ( ALevel - 1 ) then
          ANode := Owner.AddChild( ANode, CurrStr )
        else if ANode.Level > ALevel then
        begin
          NextNode := ANode.Parent;
          while NextNode.Level > ALevel do
            NextNode := NextNode.Parent;
          ANode := Owner.AddChild( NextNode.Parent, CurrStr );
        end
        else
          TreeViewErrorFmt( sInvalidLevelEx, [ ALevel, CurrStr ] );

        if ANode <> nil then
        begin
          ANode.StateIndex := NodeState;
          ANode.ImageIndex := NodeImage;
          ANode.SelectedIndex := NodeImageSel;
        end;
      end;
    finally
      Owner.EndUpdate;
      List.Free;
    end;
  except
    Owner.Owner.Invalidate;  // force repaint on exception
    raise;
  end;
end;


procedure TCheckTreeStrings.SaveTreeToStream( Stream: TStream );
const
  TabChar = #9;
  EndOfLine = #13#10;
var
  I: Integer;
  ANode: TTreeNode;
  NodeState, NodeImage, NodeImageSel, NodeStr: string;
begin
  if Count > 0 then
  begin
    ANode := Owner[ 0 ];
    while ANode <> nil do
    begin
      NodeStr := '';
      for I := 0 to ANode.Level - 1 do
        NodeStr := NodeStr + TabChar;
      NodeState := IntToStr( ANode.StateIndex );
      NodeImage := IntToStr( ANode.ImageIndex );
      NodeImageSel := IntToStr( ANode.SelectedIndex );
      NodeStr := NodeStr + NodeState + '|' + NodeImage + '|' + NodeImageSel + '|' + ANode.Text + EndOfLine;
      Stream.Write( Pointer( NodeStr )^, Length( NodeStr ) );
      ANode := ANode.GetNext;
    end;
  end;
end;




{==========================}
{== TCheckTree Methods ==}
{==========================}

constructor TCheckTree.Create( AOwner: TComponent );
begin
  inherited;

  FAutoSelect := False;
  FHighlightColor := clHighlight;
  FCheckImages := TImageList.Create( Self );
  FCheckImages.Name := 'CheckImages';
  StateImages := FCheckImages;