home *** CD-ROM | disk | FTP | other *** search
/ Delphi Magazine Collection 2001 / Delphi Magazine Collection 20001 (2001).iso / DISKS / Issue54 / Persist / tiTreeView.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  2000-01-08  |  15.4 KB  |  521 lines
  1. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
  2.   TechInsite Pty. Ltd.
  3.   PO Box 429, Abbotsford, Melbourne. 3067 Australia
  4.   Phone: +61 3 9419 6456
  5.   Fax:   +61 3 9419 1682
  6.   Web:   www.techinsite.com.au
  7.   EMail: peter_hinrichsen@techinsite.com.au
  8.  
  9.   Created: 01/07/1999
  10.  
  11.   Notes: A TTreeView for browsing a nested list of TPersistent(s) and
  12.          TList(s)
  13.  
  14. * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  15. unit tiTreeView;
  16.  
  17. interface
  18. uses
  19.   ComCtrls
  20.   ,CommCtrl
  21.   ,Classes
  22.   ,Menus
  23.   ;
  24.  
  25. type
  26.  
  27.   TtiTreeView = class ;
  28.  
  29. {
  30.   TtiTVDataMapping = class( TCollectionItem )
  31.   private
  32.     FsListPropName: string;
  33.     FsDataClassName: string;
  34.   published
  35.     property DataClassName : string read FsDataClassName write FsDataClassName ;
  36.     property ListPropName : string read FsListPropName write FsListPropName ;
  37.   public
  38.   end ;
  39.  
  40.   TtiTreeView = class ;
  41.  
  42.   TtiTVDataMappings = class( TCollection )
  43.   private
  44.     FOwner : TtiTreeView;
  45.     function  GetItem(Index: Integer): TtiTVDataMapping;
  46.     procedure SetItem(Index: Integer; const Value: TtiTVDataMapping);
  47.   published
  48.   public
  49.     constructor Create(AOwner: TtiTreeView);
  50.     function Add : TtiTVDataMapping ;
  51.     property Owner: TtiTreeView read FOwner;
  52.     property Items[Index: Integer]: TtiTVDataMapping read GetItem write SetItem;
  53.   end ;
  54. }
  55.  
  56.   //----------------------------------------------------------------------------
  57.   TTVPopupMenu = class( TPopupMenu )
  58.   private
  59.     FmiNew    : TMenuItem ;
  60.     FmiDel    : TMenuItem ;
  61.     FmiSep1   : TMenuItem ;
  62.     FmiSave   : TMenuItem ;
  63.     FmiCancel : TMenuItem ;
  64.     FmiSep2   : TMenuItem ;
  65.     FmiClose  : TMenuItem ;
  66.     FTV       : TtiTreeView ;
  67.     procedure DoNew( sender : TObject ) ;
  68.     procedure DoDelete( sender : TObject ) ;
  69.     procedure DoCancel( sender : TObject ) ;
  70.     procedure DoSave( sender : TObject ) ;
  71.     procedure DoClose( sender : TObject ) ;
  72.     procedure DoOnPopup( sender : TObject ) ;
  73.   public
  74.     Constructor Create( Owner : TComponent ) ; override ;
  75.     Destructor  Destroy ; override ;
  76.     Property    TV : TtiTreeView read FTV write FTV ;
  77.   end ;
  78.  
  79.   TtiTVNewEvent       = procedure( ptiTreeView : TtiTreeView ;
  80.                                    pNode       : TTreeNode ;
  81.                                    pParentNode : TTreeNode ;
  82.                                    pData       : TObject ) of object ;
  83.   TtiTVDeleteEvent    = procedure( ptiTreeView : TtiTreeView ;
  84.                                    pNode       : TTreeNode ;
  85.                                    pData       : TObject ) of object ;
  86.   TTVGetDataPageEvent = procedure( pData : TObject ; pNode : TTreeNode ) of object ;
  87.   TTVUpdateNodeText   = procedure( const psValue : string ) of object ;
  88.  
  89.   //----------------------------------------------------------------------------
  90.   TtiTreeView = class( TCustomTreeView )
  91.   private
  92.     FData: TPersistent ;
  93.     FOnGetDataPage: TTVGetDataPageEvent;
  94.     FNodesLoaded : TList ;
  95.  
  96.     FPopupMenu : TTVPopupMenu ;
  97.     FOnCancel  : TNotifyEvent;
  98.     FOnClose   : TNotifyEvent;
  99.     FOnDelete  : TtiTVDeleteEvent ;
  100.     FOnSave    : TNotifyEvent;
  101.  
  102.     FOnNew: TtiTVNewEvent;
  103.  
  104.     procedure SetData(const Value: TPersistent );
  105.     procedure DoOnExpanding(Sender: TObject; Node: TTreeNode ; var AllowExpansion: Boolean );
  106.  
  107.     function  HasNodeChildren( pValue: TObject ) : boolean;
  108.     procedure DoSave ;
  109.     procedure DoClose ;
  110.     procedure DoCancel ;
  111.     procedure AddNodeChildren( pNode: TTreeNode ; pData : TObject ) ;
  112.     procedure GetObjectPropNames(pPersistent: TObject; pSL: TStringList);
  113.     function  CountObjectProps( pPersistent : TObject ) : integer ;
  114.     procedure DoOnChange( sender : TObject ; node : TTreeNode ) ;
  115.     function  CanShowObjectProp(pValue: TObject): boolean;
  116.  
  117.   published
  118.     property Align ;
  119.     property Anchors ;
  120.     property Data : TPersistent read FData write SetData ;
  121.     property Images ;
  122.     property OnChanging ;
  123.  
  124.     property OnGetDataPage : TTVGetDataPageEvent read FOnGetDataPage write FOnGetDataPage  ;
  125.     property OnNew    : TtiTVNewEvent    read FOnNew    write FOnNew    ;
  126.     property OnSave   : TNotifyEvent     read FOnSave   write FOnSave   ;
  127.     property OnDelete : TtiTVDeleteEvent read FOnDelete write FOnDelete ;
  128.     property OnClose  : TNotifyEvent     read FOnClose  write FOnClose  ;
  129.     property OnCancel : TNotifyEvent     read FOnCancel write FOnCancel ;
  130.     // We can't publish OnChange as is is used internally
  131.     // property OnChange ;
  132.  
  133.   public
  134.     Constructor create( owner : TComponent ) ; override ;
  135.     Destructor  destroy ; override ;
  136.     Procedure   UpdateNodeText( const psValue : string ) ;
  137.     Property    Items ;
  138.     Procedure   DoNew ;
  139.     Procedure   DoDelete ;
  140.   end ;
  141.  
  142. implementation
  143. uses
  144.   SysUtils
  145.   ,TypInfo
  146.   ;
  147.  
  148. // * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
  149. // *
  150. // * TtiTreeView
  151. // *
  152. // * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
  153. constructor TtiTreeView.create(owner: TComponent);
  154. begin
  155.   inherited create( owner ) ;
  156.   OnExpanding   := DoOnExpanding ;
  157.   OnChange      := DoOnChange ;
  158.   ReadOnly      := true ;
  159.   ChangeDelay   := 500 ;
  160.   FPopupMenu    := TTVPopupMenu.Create( self ) ;
  161.   FPopupMenu.TV := self ;
  162.   PopupMenu     := FPopupMenu ;
  163.   FNodesLoaded  := TList.Create ;
  164. end;
  165.  
  166. //------------------------------------------------------------------------------
  167. destructor TtiTreeView.destroy;
  168. begin
  169.   FPopupMenu.Free ;
  170.   FNodesLoaded.Free ;
  171.   inherited ;
  172. end;
  173.  
  174. //------------------------------------------------------------------------------
  175. procedure TtiTreeView.DoOnExpanding( Sender: TObject ;
  176.                                      Node: TTreeNode ;
  177.                                      var AllowExpansion: Boolean ) ;
  178. begin
  179.  
  180.   if FNodesLoaded.IndexOf( Node ) = -1 then begin
  181.     FNodesLoaded.Add( Node ) ;
  182.  
  183.     AddNodeChildren( Node, Node.Data ) ;
  184.   end ;
  185.  
  186.   if Assigned( FOnGetDataPage ) then
  187.     FOnGetDataPage( Data, Node ) ;
  188.  
  189. end ;
  190.  
  191. //------------------------------------------------------------------------------
  192. procedure TtiTreeView.AddNodeChildren( pNode : TTreeNode ; pData : TObject ) ;
  193.   procedure AddChildPersistent( pNode : TTreeNode ;
  194.                                 pData : TPersistent ) ;
  195.   var
  196.     lNode : TTreeNode ;
  197.     lsCaption : string ;
  198.   begin
  199.     if IsPublishedProp( pData, 'caption' ) then begin
  200.       lsCaption         := GetPropValue( pData, 'Caption' ) ;
  201.       lNode             := self.Items.AddChildObject( pNode, lsCaption, pData ) ;
  202.       lNode.HasChildren := HasNodeChildren( pData ) ;
  203.     end ;
  204.   end ;
  205.  
  206.   procedure AddChildList( pNode : TTreeNode ;
  207.                           pData : TList ) ;
  208.   var
  209.     lData     : TPersistent ;
  210.     lNode     : TTreeNode ;
  211.     lsCaption : string ;
  212.     i : integer ;
  213.   begin
  214.     for i := 0 to pData.Count - 1 do begin
  215.       if ( TObject( pData.Items[i] ) is TPersistent ) then begin
  216.         lData := TPersistent( pData.Items[i] ) ;
  217.         if IsPublishedProp( lData, 'caption' ) then begin
  218.           lsCaption         := GetPropValue( lData, 'Caption' ) ;
  219.           lNode             := self.Items.AddChildObject( pNode, lsCaption, lData ) ;
  220.           lNode.HasChildren := HasNodeChildren( lData ) ;
  221.         end ;
  222.       end ;
  223.     end ;
  224.   end ;
  225.  
  226. var
  227.   lChild      : TObject ;
  228.   i           : integer ;
  229.   lslObjProps : TStringList ;
  230. begin
  231.  
  232.     lslObjProps := TStringList.Create ;
  233.     try
  234.       GetObjectPropNames( pData, lslObjProps ) ;
  235.       for i := 0 to lslObjProps.Count - 1 do begin
  236.         lChild := ( GetObjectProp( pData, lslObjProps.Strings[i] ) as TObject ) ;
  237.         if ( lChild is TPersistent ) then
  238.           AddChildPersistent( pNode, TPersistent( lChild ))
  239.         else if ( lChild is TList ) then
  240.           AddChildList( pNode, TList( lChild )) ;
  241.       end ;
  242.     finally
  243.       lslObjProps.Free ;
  244.     end ;
  245.  
  246. end;
  247.  
  248. //------------------------------------------------------------------------------
  249. function TtiTreeView.HasNodeChildren( pValue : TObject ) : boolean ;
  250. begin
  251.   if ( pValue is TPersistent ) then begin
  252.     result := CountObjectProps( pValue ) > 0 ;
  253.   end else if ( pValue is TList ) then begin
  254.     result := TList( pValue ).Count > 0 ;
  255.   end else
  256.     result := false ;
  257. end ;
  258.  
  259. //------------------------------------------------------------------------------
  260. procedure TtiTreeView.SetData(const Value: TPersistent );
  261. var
  262.   lsCaption : string ;
  263.   lNode : TTreeNode ;
  264.   lbDummy : boolean ;
  265. begin
  266.  
  267.   Items.Clear ;
  268.   FNodesLoaded.Clear ;
  269.  
  270.   FData := Value;
  271.   if Value = nil then
  272.     exit ; //==>
  273.  
  274.   if IsPublishedProp( Value, 'Caption' ) then
  275.     lsCaption := GetPropValue( Value, 'Caption' )
  276.   else
  277.     lsCaption := 'Top' ;
  278.  
  279.   lNode := Items.AddObject( nil, lsCaption, Value ) ;
  280.   lNode.HasChildren := HasNodeChildren( Value ) ;
  281.  
  282.   if lNode.HasChildren then
  283.     DoOnExpanding( nil, lNode, lbDummy ) ;
  284.  
  285.   lNode.Expand( false ) ;
  286.   if Assigned( FOnGetDataPage ) then
  287.     FOnGetDataPage( Value, lNode ) ;
  288.  
  289. end;
  290.  
  291. //------------------------------------------------------------------------------
  292. procedure TtiTreeView.UpdateNodeText(const psValue: string);
  293. begin
  294.   if Selected <> nil then
  295.     Selected.Text := psValue ;
  296. end;
  297.  
  298. // * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
  299. // *
  300. // * TTVPopupMenu
  301. // *
  302. // * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
  303. constructor TTVPopupMenu.Create(Owner: TComponent);
  304. begin
  305.   Inherited Create( Owner ) ;
  306.   FmiNew          := TMenuItem.Create( nil ) ;
  307.   FmiNew.Caption  := '&New' ;
  308.   FmiNew.OnClick  := DoNew ;
  309.   FmiNew.Shortcut := TextToShortcut( 'Ctrl+N' ) ;
  310.   Items.Add( FmiNew ) ;
  311.  
  312.   FmiDel    := TMenuItem.Create( nil ) ;
  313.   FmiDel.Caption  := '&Delete' ;
  314.   FmiDel.OnClick  := DoDelete ;
  315.   FmiDel.Shortcut := TextToShortcut( 'Ctrl+D' ) ;
  316.   Items.Add( FmiDel ) ;
  317.  
  318.   FmiSep1   := TMenuItem.Create( nil ) ;
  319.   FmiSep1.Caption  := '-' ;
  320.   Items.Add( FmiSep1 ) ;
  321.  
  322.   FmiSave   := TMenuItem.Create( nil ) ;
  323.   FmiSave.Caption  := '&Save' ;
  324.   FmiSave.OnClick  := DoSave ;
  325.   FmiSave.Shortcut := TextToShortcut( 'Ctrl+S' ) ;
  326.   Items.Add( FmiSave ) ;
  327.  
  328.   FmiCancel := TMenuItem.Create( nil ) ;
  329.   FmiCancel.Caption  := '&Cancel' ;
  330.   FmiCancel.OnClick  := DoCancel ;
  331.   FmiCancel.Shortcut := TextToShortcut( 'Ctrl+C' ) ;
  332.   Items.Add( FmiCancel ) ;
  333.  
  334.   FmiSep2          := TMenuItem.Create( nil ) ;
  335.   FmiSep2.Caption  := '-' ;
  336.   Items.Add( FmiSep2 ) ;
  337.  
  338.   FmiClose          := TMenuItem.Create( nil ) ;
  339.   FmiClose.Caption  := 'C&lose' ;
  340.   FmiClose.OnClick  := DoClose ;
  341.   FmiClose.Shortcut := TextToShortcut( 'Ctrl+F4' ) ;
  342.   Items.Add( FmiClose ) ;
  343.  
  344.   OnPopup := DoOnPopup ;
  345.  
  346. end ;
  347.  
  348. //------------------------------------------------------------------------------
  349. destructor TTVPopupMenu.Destroy;
  350. begin
  351.   FmiNew.Free ;
  352.   FmiDel.Free ;
  353.   FmiSep1.Free ;
  354.   FmiSave.Free ;
  355.   FmiCancel.Free ;
  356.   FmiSep2.Free ;
  357.   FmiClose.Free ;
  358.   Inherited ;
  359. end;
  360.  
  361. //------------------------------------------------------------------------------
  362. procedure TTVPopupMenu.DoCancel( sender : TObject );
  363. begin
  364.   TV.DoCancel ;
  365. end;
  366.  
  367. //------------------------------------------------------------------------------
  368. procedure TTVPopupMenu.DoClose( sender : TObject );
  369. begin
  370.   TV.DoClose ;
  371. end;
  372.  
  373. //------------------------------------------------------------------------------
  374. procedure TTVPopupMenu.DoDelete( sender : TObject );
  375. begin
  376.   TV.DoDelete
  377. end;
  378.  
  379. //------------------------------------------------------------------------------
  380. procedure TTVPopupMenu.DoNew( sender : TObject );
  381. begin
  382.   TV.DoNew ;
  383. end;
  384.  
  385. //------------------------------------------------------------------------------
  386. procedure TTVPopupMenu.DoOnPopup(sender: TObject);
  387. begin
  388.   FmiNew.Enabled    := Assigned( FTV.OnNew ) ;
  389.   FmiDel.Enabled    := Assigned( FTV.OnDelete ) ;
  390.   FmiSave.Enabled   := Assigned( FTV.OnSave ) ;
  391.   FmiCancel.Enabled := Assigned( FTV.OnCancel ) ;
  392.   FmiClose.Enabled  := Assigned( FTV.OnClose ) ;
  393.  
  394. //  FmiSep1.Enabled   := Assigned( FTV. ) ;
  395. //  FmiSep2.Enabled   := Assigned( FTV. ) ;
  396.  
  397. end;
  398.  
  399. procedure TTVPopupMenu.DoSave( sender : TObject );
  400. begin
  401.   TV.DoSave ;
  402. end;
  403.  
  404. //------------------------------------------------------------------------------
  405. procedure TtiTreeView.DoCancel;
  406. begin
  407.   if Assigned( FOnCancel ) then
  408.     FOnCancel( self ) ;
  409. end;
  410.  
  411. //------------------------------------------------------------------------------
  412. procedure TtiTreeView.DoClose;
  413. begin
  414.   if Assigned( FOnClose ) then
  415.     FOnClose( self ) ;
  416. end;
  417.  
  418. //------------------------------------------------------------------------------
  419. procedure TtiTreeView.DoDelete;
  420. var
  421.   lNode : TTreeNode ;
  422.   lData : TObject ;
  423. begin
  424.   if Assigned( FOnDelete ) then begin
  425.     lNode := Selected ;
  426.     if lNode <> nil then
  427.       lData       := lNode.Data
  428.     else
  429.       lData       := nil ;
  430.     FOnDelete( self, lNode, lData ) ;
  431.     DoOnChange( self, Selected ) ;
  432.   end ;  
  433. end;
  434.  
  435. //------------------------------------------------------------------------------
  436. procedure TtiTreeView.DoNew ;
  437. var
  438.   lNode : TTreeNode ;
  439.   lParentNode : TTreeNode ;
  440.   lData : TObject ;
  441. begin
  442.   if Assigned( FOnNew ) then begin
  443.     lNode := Selected ;
  444.     if lNode <> nil then begin
  445.       lParentNode := lNode.Parent ;
  446.       lData       := lNode.Data ;
  447.     end else begin
  448.       lParentNode := nil ;
  449.       lData       := nil ;
  450.     end ;
  451.     FOnNew( self, lNode, lParentNode, lData ) ;
  452.     DoOnChange( self, Selected ) ;
  453.   end ;
  454. end;
  455.  
  456. //------------------------------------------------------------------------------
  457. procedure TtiTreeView.DoSave;
  458. begin
  459.   if Assigned( FOnSave ) then
  460.     FOnSave( self ) ;
  461. end;
  462.  
  463. //------------------------------------------------------------------------------
  464. procedure TtiTreeView.GetObjectPropNames( pPersistent : TObject ;
  465.                                           pSL : TStringList ) ;
  466. var
  467.   lCount : integer ;
  468.   lSize  : integer ;
  469.   lList  : PPropList ;
  470.   i : integer ;
  471. begin
  472.   pSL.Clear ;
  473.   lCount := GetPropList(pPersistent.ClassInfo, [tkClass], nil);
  474.   lSize := lCount * SizeOf(Pointer);
  475.   GetMem(lList, lSize);
  476.   try
  477.     GetPropList(pPersistent.ClassInfo, [tkClass], lList);
  478.     for i := 0 to lcount - 1 do
  479.       psl.add( lList[i].Name ) ;
  480.   finally
  481.     FreeMem( lList, lSize ) ;
  482.   end ;
  483. end ;
  484.  
  485. //------------------------------------------------------------------------------
  486. function TtiTreeView.CountObjectProps( pPersistent : TObject ) : integer ;
  487. var
  488.   lsl : TStringList ;
  489.   i   : integer ;
  490. begin
  491.   result := 0 ;
  492.   lsl := TStringList.Create ;
  493.   try
  494.     GetObjectPropNames( pPersistent, lsl ) ;
  495.     for i := 0 to lsl.Count - 1 do begin
  496.       if CanShowObjectProp( GetObjectProp( pPersistent, lsl.Strings[i] )) then
  497.         inc( result ) ;
  498.     end ;
  499.   finally
  500.     lsl.Free ;
  501.   end ;
  502. end ;
  503.  
  504. //------------------------------------------------------------------------------
  505. function TtiTreeView.CanShowObjectProp( pValue : TObject ) : boolean ;
  506. begin
  507.   result := (( pValue is TPersistent ) and
  508.              ( IsPublishedProp( TPersistent( pValue ), 'Caption' ))) or
  509.             (( pValue is TList ) and
  510.             ( TList( pValue ).Count > 0 )) ;
  511. end ;
  512.  
  513. //------------------------------------------------------------------------------
  514. procedure TtiTreeView.DoOnChange(sender: TObject; node: TTreeNode);
  515. begin
  516.   if Assigned( FOnGetDataPage ) then
  517.     FOnGetDataPage( Node.Data, Node ) ;
  518. end;
  519.  
  520. end.
  521.