{TDirTree Component for Delphi 3 written by Markus Stephany MirBir.St@T-Online.de MirBir.St@Saargate.de http://home.t-online.de/home/mirbir.st/ V 1.16 march 14, 1998 credits to all the people who reported bugs and suggestions to me, especially to Feng Ting, Davendra Patel, Yuval Perlov, Doug Hay, botevi@bu.omega.bg, Sebastian Hildebrandt, Heiko Webers, Keith Speers, Ashley Bass, Jean Louis LeClef, Demian Lessa, Herbert Sauro, Adam Roslon and all the others i forgot now... // a treeview that shows the system's drives and folders (or a part of them ,s.b.) // displays explorer-like icons and filenames this is free for freeware, public domain, shareware and also for commercial applications. if something is going wrong (or even not), contact me (see above), but do not make 3 me responsable for anything !! added properties : Directory read/write gets/sets the DirTree's directory Drive read/write gets/sets the drive (restoring the previously used directory for that drive) added functions : Reload reads the items again and tries to set the old dir. (use it e.g. with a shell-notification) added event : OnAddDir (Filename : string ; var DoAdd : boolean) You can use this event to decide whether to add a drive/path or not (see the sample for more info) ********** revision 1.02: now it runs a bit faster at startup. added property : ReadOnStart : Now You can decide whether the control should read the directories on creation or explicit by calling Reload ********** revision 1.1: now it should run under NT without getting asked to insert a floppy disk or cd-rom added properties: DirType : You can set the file-attributes to decide which directories to show (this works not for the drive-items (cause of NT)) ShellIcons (readonly) : an imagelist where you can read the shell's small-icons (maybe for a listview for files, you have not to create another imagelist for small icons) AllowNetwork : enables/disables displaying of network-drives ********** revision 1.11: uses ...forms... was missed by some people (and i can understand them) i hope that there are not longer problems under delphi3 and delphi 2.00 and windows nt, oh, i hope it so ! ********** revision 1.12: a bug is fixed when using a "real" network-drive ('\\blabla...') added property: DropDirectory : is something is dropped to TDirTree, this property gives you the directory of the droptarget-node GoBelowRecycleBin : if set to false, don't show subdirectories of the recycle bin-folders ********** revision 1.13: added function: GetNodefromPath(dir:string):ttreenode : returns the node which belongs to the specified path (if existing in the items); ********** revision 1.14: property-name items changed to Items (because of the case sensitivity of bcb) thanks to keith speers kspeers@ms5.hinet.net for this bug-report added procedure: (thanks to ashley bass abass@iname.com for his suggestions) RenamePart(oldpath,newname:string); rename the node belonging to the give path and correct the children DeletePart(dpath:string); deletes the node belonging to the path and all its kids; AddPath(expath,newsub:string); adds a new sub dir to the children of the existing path expath ********** revision 1.15: (feb 27, 1998) added property : FastLoad : boolean ; if set to true (default), DirTree will not search for all subdirectories, it will just show a + button in front of each root-node (much faster startup than set to false) credits to jean louis leclef OrionTech@euronet.be added procedure : ClearNode(node:ttreenode); deletes all kids of the given node and checks whether there are subs or not (this may be useful for adding dynamic reloading of nodes on collapsing a node, e.g. if this is called in oncollapsed-event, the node will reread its subdirectories when it gets expanded again) made a change in getsubkids for speeding up reading of "child-owning" directories ********** revision 1.15a: (mar 08, 1998) changed property Readonly to property ReadOnly (because of compiler errors in bcb) ********** revision 1.16 (mar 13,1998) changed some internal stuff, rewritten with case-sensitivity, added some documentation, changed TDirName-Objects to TDirEntry-record pointers, fixed some bugs if we are in the delphi-ide property shellicons is no longer published, now it is public. most of the stuff above comes from demian lessa, know-how@svn.com.br, thanx a lot changed event handler OnAddDir (Filename : string ; var DoAdd : boolean) to OnAddDir (Sender : TObject ; Filename : string ; var DoAdd : boolean) error-management under nt added, regards to sebastian hildebrandt, hildebrandt@t0.or.at i do not longer support c++builder, if someone wants to use tdirtree in bcb, he is invited to do so, but this unit is written and supported "Only for Delphi 3.x" (maybe for d2.x too) added functions : thanx for the suggestion to Herbert Sauro, Herbert.Sauro@ft.com GetSysPathName(Path:string):string; returns the real name of the given path (as it is written to the disk), e.g. ...('C:\WINDOWS\SYSTEM\') might return 'C:\Windows\System', this is not a procedure of object, (do not use DirTree1.GetSysPathName..., just use GetSysPathName...), the trailing backslash will not be returned GetShellPathName(Path:string):string; returns the shell parsed name of the given path or file added events : OnGetIcon(Sender:TObject ; Node:TTreeNode) ; here you can give the node a custom imageindex and selectedindex OnFindDir (Sender : TObject ; Path : string ; var Rec : TDirRec ; var Result : Integer ; const First : Boolean) now you can completely decide by yourself what files to add (e.g. archives) you have just to set the faDirectory-Flag in Rec.Attr to add the file to the directory tree this is based on an idea of adam roslon, adam@roslon.com, thanx added function : FileOrDirExists(Path : string) : Boolean; returns true if the file or directory called path is present on the system } unit DirTree; interface uses Windows, Messages, sysutils, Classes, Controls, ComCtrls,ShellApi,FileCtrl,Forms; {this is an event-descriptor for the OnAddDir-event} type TAddFileEvent = procedure (Sender : TObject ; FileName : string ; var DoAdd : Boolean) of object; {these are all supported file-attributes} TDirAttr = (dtReadOnly, dtHidden, dtSystem, dtArchive, dtNormal, dtAll); TDirType = set of TDirAttr; {this is an internally used directory-descriptor} TDirRec = packed record Attr : Integer; Name : string; Handle : Integer; Data : TWin32FindData; end; {this is an event-descriptor for the OnFindDir-event} type TFindDirEvent = procedure (Sender : TObject ; Path : string ;var Rec : TDirRec ; var Result : Integer ; const First : Boolean) of Object; {this is the data-property of each node} type PDirEntry = ^TDirEntry; TDirEntry = packed record Name : string; IsExp : Boolean; end; type TDirTree = class(TcustomTreeView) private { Private-Deklarationen } fFastLoad : Boolean; // to start without getting the button-state of all available drives fIList : TImageList; // the placeholder for the shell's small image-list fActDirs : array['A'..'Z'] of string; // remember the last used directories on the given drives fOnAdd : TAddFileEvent; // will be fired before adding an directory to the list fOnDeletion : TTVExpandedEvent; // to delete the direntry record if a node is to be deleted fOnGetIcon : TTVExpandedEvent; // this can be fired to store a different image index fOnFindDir : TFindDirEvent ; // this can be assigned to read custom dirs and other files to the tree fIFolS : Integer ; // shell's icon-index for "normal" folders, selected state (opened) fIFolN : Integer ; // the same for non-selected "normal" folders fReadOnStart : Boolean; // shall we read the tree automatically at startup ? fAllowChange : Boolean; // if false, don't fire the onchange-event fDirType : TDirType; // which folders to read fNetAll : Boolean; // shared drives allowed ? fBelBin : Boolean; // allowed to go to subdirs of "recycled" (for norton's protection) ) fWinDir : string; // holder for windows' directory procedure DelItem (Sender: TObject; Node: TTreeNode); // overwritten event-handler to delete items protected { Protected-Deklarationen } destructor Destroy; override; procedure CreateWnd ; override; // to implement readonstart procedure ReadNew; // refreshs the tree procedure AddNode (var Item : TTreeNode; A : string); //adds a (root-) node to the tree (for drives) (?) procedure GetSubKids (Par : TTreeNode); //get the button-states of the item's kids procedure SetDrive (Val : Char); procedure SetDirectory (Val : string); procedure SetDirType (Val : TDirType); procedure Change(Node: TTreeNode); override; procedure SetNetAllow (Val : Boolean); procedure SetBelBin(Val:Boolean); procedure ClearList; // clears the list and frees the pdirentry-records procedure Loaded; override; procedure GetImageIndex(Node:TTreeNode;NormalIcon:Integer); function CanExpand(Node: TTreeNode): Boolean ; override; function GetDirectory : string; function GetDrive : Char; function AddKid (Par : TTreeNode; A : string) : TTreeNode; // adds an item and returns this one function GetDropDir:string; // get the directory belonging to the drop-target item function AskAdd (FNam : string):Boolean; // can we add the elemnt to the tree (calls onadddir-event) function Okay (Attr:Integer):Boolean; // are the dir's attributes in the current mask ? function IsExpanded(Item : TTreeNode):Boolean; // credits to demian lessa,know-how@svn.com.br property Items stored False; public { Public-Deklarationen } constructor Create (AOwner: TComponent);override; procedure GetBtn (var Item : TTreeNode); // get the first kid of the item's path procedure ReLoad ; // Reload the tree procedure FullExpand; // expands all nodes procedure GetKids (var Item : TTreeNode); // get all child node's for the item-node procedure RenamePart (OldPath,NewName:string); // eg ..('c:\windows\system','sys32') renames 'c:\windows\system' to 'c:\windows\sys32' (only in the tree, not on the drive) procedure DeletePart (DPath:string); // eg ..('c:\windows') deletes the node belonging to 'c:\windows' an all its child nodes ('') procedure AddPath (ExPath,NewSub:string); // adds a child node newsub to the existing node expath procedure ClearNode (Node:TTreeNode); // deletes the subnodes of the given node function GetNodeFromPath (Path:string):TTreeNode; // returns the node belonging to a special directory, if existant property Drive : Char read GetDrive write SetDrive; property DropDirectory : string read GetDropDir; property ShellIcons : TImageList read fIList; // the shell's small image list (to associate with other components !!!!just read it!!! published { Published-Deklarationen } property Directory : string read GetDirectory write SetDirectory; // sets/reads the selected node/path property OnAddDir : TAddFileEvent read fOnAdd write fOnAdd; // event handler get fired on adding a node to the tree property OnDeleteItem : TTVExpandedEvent read fOnDeletion write fOnDeletion; // overwritten ondeletion event property OnGetIcon : TTVExpandedEvent read fOnGetIcon write fOnGetIcon; // to set custom images for a node property OnFindDir : TFindDirEvent read fOnFindDir write fOnFindDir; // read also files into the tree; property BorderStyle; property ReadOnStart : Boolean read fReadOnStart write fReadOnStart; // read the tree automaticaaly on startup ? property DragCursor; property DirType : TDirType read fDirType write SetDirType; // described above property AllowNetwork : Boolean read fNetAll write SetNetAllow; // '' property GoBelowRecycleBin : Boolean read fBelBin write SetBelBin; // '' property FastLoad : Boolean read fFastLoad write fFastLoad; // '' property ReadOnly; property DragMode; property HideSelection; property OnEditing; property OnEdited; property OnExpanding; property OnExpanded; property OnCollapsing; property OnCollapsed; property OnChanging; property OnChange; property Align; property Enabled; property Font; property Color; property ParentColor; property ParentCtl3D; property Ctl3D; property TabOrder; property TabStop default True; property Visible; property OnClick; property OnEnter; property OnExit; property OnDragDrop; property OnDragOver; property OnStartDrag; property OnEndDrag; property OnMouseDown; property OnMouseMove; property OnMouseUp; property OnDblClick; property OnKeyDown; property OnKeyPress; property OnKeyUp; property PopupMenu; property ParentFont; property ParentShowHint; property ShowHint; end; procedure Register; function GetSysPathName (Path:string):string; // returns the name of the given path as it is written to the disk (upper, lowercase and so on) function GetShellPathName (Path:string):string; // returns the name of the given path as it is displayed by the shell function FileOrDirExists (Path:string):Boolean; // checks whether the specified file exists on the drive (can also be a directory) implementation procedure Register; begin RegisterComponents('Merkes'' Pages', [TDirTree]); end; {helper routines} function FindFirstDir(Path:string;var Rec:TDirRec):Integer; // our special version of findfirst begin with Rec do begin FillChar(Rec,SizeOf(TDirRec),0); Handle:=FindFirstFile(PChar(Path),Data); if Handle <> INVALID_HANDLE_VALUE then begin Result := 0; // we have found the directory (or file) Attr := Data.dwFileAttributes; Name := Data.cFileName; end else Result := GetLastError; // we got no valid handle for the searched directory end; end; function FindNextDir(var Rec:TDirRec):Integer; // our version of findnext (a bit faster than borland's cause we do not convert all items of the win32finddata) begin with Rec do begin if FindNextFile(Handle,Data) then begin Result := 0; Attr := Data.dwFileAttributes; Name := Data.cFileName end else Result := GetLastError; end; end; procedure MakeTDirEntry(a:TTreeNode;b:string;c:Boolean); // creates the directory-data for the node a, path=b, expanded=c var d : PDirEntry; begin d := New(PDirEntry); d^.IsExp := c; d^.Name := b; a.Data:=d; end; function AzPos(a:string):Integer; // calculates the count of "\" in the given string var ct: Integer; begin Result := 0; repeat ct := Pos ('\',a); if ct = 0 then Exit; Inc (Result,1); a:=Copy(a,ct+1,MaxInt); until False; end; function GetPart(a:string;b:Integer):string; // get the b'st "\" delimited part of a var ct,ix : Integer; begin Result := a; ix := 0; for ct := 1 to Length(a) do begin if a[ct] = '\' then Inc (ix,1); if ix = b then begin Result := Copy(a,1,ct); Exit; end; end; end; procedure AddBSlash(var Val:string); // add a trailing backslash to val, if there is none begin if Val <> '' then if Val[Length(Val)] <> '\' then Val := Val+'\'; end; function DelBSlash(Val:string):string; // remove a trailing backslash from val, if there is none begin if Val <> '' then if Val[Length(Val)] = '\' then Delete(Val,Length(Val),1); Result := val; end; function EntryName(Node:TTreeNode):string; // get the tdirentry-name (the real path) for the specified node; begin Result := ''; if Assigned(Node.Data) then Result := PDirEntry(Node.Data)^.Name; end; function GetSysShellName (Path:string;Shell:Boolean):string; // returns the name of the given path as it is written to the disk or as displayed by the shell var az,afg : Integer; part : string; function GetSysFileName(Name:string):string; // returns the filename as read from the drive var rec : TDirRec; begin Name := DelBSlash(Name); Result := ExtractFileName(Name); if FindFirstDir(Name,rec) = 0 then Result := rec.Name; Windows.FindClose(rec.Handle); AddBSlash(Result); end; function GetShellFileName(Name:string):string; // returns the filename as displayed by the shell var sfi : TSHFileInfo; begin Name := DelBSlash(Name); Result := ExtractFileName(Name); if SHGetFileInfo(PChar(Name),0,sfi,SizeOf(TSHFileInfo),SHGFI_DISPLAYNAME) <> 0 then Result := sfi.szDisplayName; AddBSlash(Result); end; begin Path := DelBSlash(Path); Result := Path; if not FileOrDirExists(Path) then Exit; az := AzPos(Path)+1; if az < 2 then begin if Path <> '' then Path[1] := UpCase(Path[1]); Exit; end; Result := UpCase(Path[1])+':\'; AddBSlash(Path); for afg := 2 to az do begin part := GetPart(Path,afg); if Shell then Result := Result+GetShellFileName(part) else Result := Result+GetSysFileName(part); end; Result := DelBSlash(Result); end; {exported stuff} function GetSysPathName (Path:string):string; // returns the name of the given path as it is written to the disk (upper, lowercase and so on) begin Result := GetSysShellName(Path,False); end; function GetShellPathName (Path:string):string; // returns the name of the given path as it is displayed by the shell begin Result := GetSysShellName(Path,True); end; function FileOrDirExists (Path:string):Boolean; // checks whether the specified file exists on the drive (can also be a directory) var E : Integer; begin E := SetErrorMode(SEM_FAILCRITICALERRORS); try Result := GetFileAttributes(PChar(Path)) <> -1; finally SetErrorMode(E); end; end; {TDirTree implementation} constructor TDirTree.Create; var sfi : TSHFileInfo; n : Char; // drive-holder tp : array [0..MAX_PATH] of char; begin inherited Create(AOwner); fIList := TImageList.Create(Self); // create the shell's image list (or better, a copy) // now get the closed and open icon for normal folders (i hope the windir is a normal folder) GetWindowsDirectory(tp,MAX_PATH); fWinDir := StrPas(tp); AddBSlash(fWinDir); fIList.Handle := SHGetFileInfo(tp,0,sfi,SizeOf(TSHFileInfo), SHGFI_SYSICONINDEX or SHGFI_SMALLICON); // get the shell's image list's handle fIList.ShareImages := True; // don't free the shell's image list on destroying our copy ! Images := fIList; // set the dirtree's images to this copy of the shell's il fIFolN := sfi.iIcon; SHGetFileInfo(tp,0,sfi,SizeOf(TSHFileInfo), SHGFI_OPENICON or SHGFI_SYSICONINDEX or SHGFI_SMALLICON); // get the shell's image list's handle fIFolS := sfi.iIcon; fFastLoad := False; // no fastload for default OnDeletion := DelItem; // set our own event-handler for deleting a node (to delete the tdirentry) fReadOnStart := True; // default: read automatically at startup fBelBin := True; // default: show subdirectories of "recycled" pathes for n := 'A' to 'Z' do fActDirs[n]:=UpperCase(n)+':\'; // read the root of all drives as default dirs for the drives try fActDirs[UpCase(GetCurrentDir[1])] := UpperCase(GetCurrentDir); // read the current directory except; end; SortType := stNone; // no sorting (it's slow) HideSelection := False; fAllowChange := False; // firing onchange event is not allowed until the first reading has been done fDirType := [dtAll,dtNormal]; // read all types of directories fNetAll := True; // allow network drives fOnGetIcon := nil; fOnFindDir := nil; end; procedure TDirTree.ClearList; // delete all items and their data-object var ct : Integer; begin if Items.Count > 0 then for ct := 0 to Items.Count -1 do try if Items[ct].Data <> nil then begin PDirEntry(Items[ct].Data)^.Name := ''; Dispose(PDirEntry(Items[ct].Data)); end; finally Items[ct].Data := nil; end; Items.Clear; // delete all items and their data end; destructor TDirTree.Destroy; begin fAllowChange := False; // don't fire onchange-event ClearList; // clear all items fIList.Free; // clear the image list inherited Destroy; end; procedure TDirTree.SetBelBin(Val:Boolean); // go below recycle bin ? begin if fBelBin <> Val then begin fBelBin:=Val; ReLoad; end; end; procedure TDirTree.GetImageIndex(Node:TTreeNode;NormalIcon:Integer); // can fire the event handler to get an icon index var Info : TSHFileInfo; begin Node.ImageIndex := NormalIcon; // now check whether a normal folder icon or not if NormalIcon = fIFolN then Node.SelectedIndex := fIFolS else begin FillChar(Info,SizeOF(TSHFileInfo),0); SHGetFileInfo(PChar(PDirEntry(Node.Data)^.Name),0,Info,SizeOf(TSHFileInfo),SHGFI_SYSICONINDEX or SHGFI_SMALLICON or SHGFI_OPENICON); Node.SelectedIndex := Info.iIcon; end; if Assigned(fOnGetIcon) then fOnGetIcon(Self,Node); // for setting custom image indices end; function TDirTree.GetDropDir:string; // get the path belonging to the node where dropped to begin Result := ''; try if DropTarget <> nil then Result := EntryName(DropTarget); finally end; end; procedure TDirTree.ReLoad ; var t : Char; // drive-holder node,nd1 : TTreeNode; // first node, first child tdir : string; // holder for path name begin tdir := GetDirectory; // store the current directory ReadNew; // reread the whole tree SetDirectory(tdir); // try to restore the actual path if Items.Count = 0 then Exit; if Selected = nil then SetDirectory(Copy(tdir,1,3)); // actual directory is no longer existant, set root path if Selected = nil then begin // didn't work , try to get another drive node := Items.GetFirstNode; nd1 := Node.GetFirstChild; while (nd1 <> nil) and (not IsExpanded(nd1)) and (Node.GetNextSibling <> nil) do begin node := node.GetNextSibling; nd1 := node.GetFirstChild; end; t := UpCase(EntryName(node)[1]); try SetDirectory(fActDirs[t]); // try to set this directory if GetDirectory <> fActDirs[t] then begin node.Selected := True; // no, select this existing node Change(node); end; except end; end; end; function TDirTree.Okay (Attr:Integer):Boolean; // check whether the dir-attributes fit to the mask begin Result := False; if dtAll in fDirType then Result := True else begin if (Attr and faHidden) = faHidden then if not (dtHidden in fDirType) then Exit; // is hidden, but not in mask, don't add if (Attr and faSysFile) = faSysFile then if not (dtSystem in fDirType) then Exit; // '', for system-attribute if (Attr and faArchive) = faArchive then if not (dtArchive in fDirType) then Exit; Result := True; // exclusive mask fits, return true if dtNormal in fDirType then Exit; // check whether some attribute(s) must be set ? if (Attr and (faHidden or faSysFile or faArchive)) = 0 then Result := False; end; end; function TDirTree.AskAdd (FNam : string):Boolean; var c : integer; begin Result := True; // is it allowed to go below rycle-bin ? if not fBelBin then begin c:= Pos('\recycled\',AnsiLowerCase(FNam)); if c > 0 then if c < (Length(FNam) -9) then Result:=False; // would be a path under the recycle bin end; if Result and Assigned (fOnAdd) then fOnAdd(Self,FNam,Result); // allow custom decision whether to add or not end; procedure TDirTree.SetDirType (Val :TDirType); // set allowed file-attributes begin if Val <> fDirType then begin fDirType := Val; ReLoad; end; end; procedure TDirTree.SetNetAllow (Val : Boolean); // enable/disable displaying of shared drives begin if Val <> fNetAll then begin fNetAll := Val; ReLoad; end; end; procedure TDirTree.SetDirectory (Val : string); var az : Integer; // count of "\" in the path node : TTreeNode; // temp. oldcur : TCursor; // show busy-corsor afg : Integer; // current "\..." part index (belongs to az) tsr : string; // current "\..." part '' function GetRoot(a:string):TTreeNode; // get the rootnode ("x:\") for the given path var sr : TTreeNode; begin Result:=nil; sr := Items.GetFirstNode; while sr <> nil do begin if lstrcmpi(PChar(a),PChar(EntryName(sr))) = 0 then begin if not IsExpanded(sr) then GetKids(sr); // expand root node Result:=sr; Break; // found, end end; sr := sr.GetNextSibling; // not yet found, continue searching end; end; function GetChi(c:TTreeNode;a:string):TTreeNode; // get the node belonging to the specified path and expand it var sr : TTreeNode; begin Result:=nil; sr := c.GetFirstChild; while sr <> nil do begin if lstrcmpi(PChar(a),PChar(EntryName(sr))) = 0 then begin if not IsExpanded(sr) then GetKids(sr); Result:=sr; Break; end; sr := c.GetNextChild(sr); end; end; begin if Val = '' then raise Exception.Create('Invalid Directory Name'); if Val = '?' then Exit; // what happened here (if no directory can be found) AddBSlash(Val); // add a backslash if necessary if not FileOrDirExists(DelBSlash(Val)) then Val := GetCurrentDir[1]+':\'; // if the wanted path isn't present, use the current dir if (not FNetAll) and (not(csDesigning in ComponentState)) and (GetDriveType(PChar(Val[1]+':\')) = Drive_Remote) then Val := fWinDir; // get the partial strings az := AzPos(Val); // get count of "\" if az = 0 then Exit; // seems to be an empty val oldcur := Screen.Cursor; Screen.Cursor := crHourGlass; // show that we are busy try Items.BeginUpdate; // don't update the tree until finished Val := UpperCase(Val); // cast up for better comparing (?) node := nil; for afg := 1 to az do begin // get the partial string #afg tsr := GetPart(Val,afg); if afg = 1 then // if the first (root), get the root node node := GetRoot(tsr) // otherwise get the child node else node := GetChi(node,tsr); if node = nil then Exit; // if there is no child node, just set the existing part of the path end; Selected := node; // select the node found TopItem := node; // scroll into view finally Items.EndUpdate; // no update the tree on screen Screen.Cursor := oldcur; // and restore the previous cursor end; end; function TDirTree.GetDirectory : string; // retrieve the currently selected path begin if Selected = nil then Result := '?' else // no path selected try Result := EntryName(Selected); except Result := '?'; // there's something wrong end; end; function TDirTree.AddKid (Par:TTreeNode; A : string):TTreeNode; // add a child node (a subdir) to the given node/path var sfi : TSHFileInfo; item : TTreeNode; begin Result := nil; if Par = nil then Exit; // no parent, no child AddBSlash(A); // add a backslash if necessary SHGetFileInfo(PChar(A),0,sfi,SizeOf(TSHFileInfo),SHGFI_SYSICONINDEX or SHGFI_SMALLICON or SHGFI_DISPLAYNAME); // get the displayname and the normal icon index item := Par.Owner.AddChild(Par,sfi.szDisplayName); // add this item to the tree with the shell's displayed name MakeTDirEntry(item,UpperCase(A),False); // add an descriptor (node's data-property) GetImageIndex(item,sfi.iIcon); Result := item; end; procedure TDirTree.AddNode (var Item : TTreeNode; A:string); // adds a root node to the tree (a drive node) var sfi : TSHFileInfo; begin AddBSlash(A); // add a bsl if needed SHGetFileInfo(PChar(A),0,sfi,SizeOf(TSHFileInfo),SHGFI_SYSICONINDEX or SHGFI_SMALLICON or SHGFI_DISPLAYNAME); // get the displayname and the normal icon index item := Items.Add(nil,sfi.szDisplayName); // and add it to the root of the tree MakeTDirEntry(item,UpperCase(A),False); // add an descriptor (node's data-property) GetImageIndex(item,sfi.iIcon); end; procedure TDirTree.GetSubKids (Par:TTreeNode); // retrieves info whether to show + buttons or not var node : TTreeNode; begin if csDesigning in ComponentState then Exit; // no buttons in the delphi ide if Par = nil then Exit; node := Par.GetFirstChild; while node <> nil do begin // walk thru all child nodes GetBtn(node); node := Par.GetNextChild(node); end; end; procedure TDirTree.GetKids (var Item:TTreeNode); // read all subdirs of the given path var sr : TDirRec; // our searchrecord res,ct : Integer; // search result, count of found subdirectories pt : string; // parent path for search fDirs : TStringList; // container for subdirs E : Integer; // set error mode (to avoid problems under nt) begin if csDesigning in ComponentState then Exit; if Item = nil then Exit; // delphi ide, no path : exit if IsExpanded(Item) then Exit; // already has read the subdirs, exit fDirs := TStringList.Create; try pt := EntryName(Item); // get the path for the specified node Item.DeleteChildren; // delete all (internal structure) children PDirEntry(Item.Data)^.IsExp := True; // after this procedure it is expanded and stores its subdirectories FillChar(sr,SizeOf(TDirRec),0); // here comes some error-handling to avoid an ugly error message under nt if the drive is empty // credits to sebastian hildebrandt, hildebrandt@t0.or.at E := SetErrorMode(SEM_FAILCRITICALERRORS); try if Assigned(fOnFindDir) then fOnFindDir(Self,pt,sr,res,True) else res := FindFirstDir(pt+'*.*',sr); // search for pathes while res = 0 do begin if ((sr.Attr and faDirectory) > 0) and (sr.Name <> '.') and (sr.Name <> '..') then if AskAdd(pt+sr.Name+'\') then if Okay(sr.Attr) // if all conditions are okay then fDirs.Add(sr.Name); // add the path to the container if Assigned(fOnFindDir) then fOnFindDir(Self,pt,sr,res,False) else res := FindNextDir(sr); end; finally SetErrorMode(E); end; Windows.FindClose(sr.Handle); // nothing (more) found fDirs.Sorted := True; // no do an alphabetical sorting if fDirs.Count > 0 then for ct := 0 to fDirs.Count -1 do AddKid(Item,pt+fDirs[ct]); // no add all subdirs to the tree finally FDirs.Free; end; end; procedure TDirTree.GetBtn (var Item:TTreeNode); // get the + button state for the spec. node var sr : TDirRec; res : Integer; pt : string; E : Integer; { this is almost the same as above, but here we just search for the first subdirectory, if one found, add a dummy child node to display the + button and exit} begin if csDesigning in ComponentState then Exit; if Item = nil then Exit; if IsExpanded(Item) then Exit; pt := EntryName(Item); E := SetErrorMode(SEM_FAILCRITICALERRORS); try if Assigned(fOnFindDir) then fOnFindDir(Self,pt,sr,res,True) else res := FindFirstDir(pt+'*.*',sr); while res = 0 do begin if ((sr.Attr and faDirectory) > 0) and (sr.Name <> '.') and (sr.Name <> '..') then if AskAdd(pt+sr.Name+'\') then if Okay(sr.Attr) then begin Items.AddChild(Item,'**'); Break; end; if Assigned(fOnFindDir) then fOnFindDir(Self,pt,sr,res,False) else res := FindNextDir(sr); end; finally SetErrorMode(E); end; Windows.FindClose(sr.Handle); end; procedure TDirTree.ReadNew; // reload the tree var oldcur : TCursor; // we want to display that we are busy node : TTreeNode; // the temp. node ct : Integer; // to walk thru all drives drv : Char; // a..z bits : set of 0..25; // binary array for all drives that do exist E : Integer; // to set the error mode function DriveExists(db:byte):Boolean; // here we check if the drive in db is present in the system var dr : Char; E : Integer; begin Result := False; if not (ct in bits) then Exit; dr := Char(db+Ord('A')); E := SetErrorMode(SEM_FAILCRITICALERRORS); try if not fNetAll then if GetDriveType(PChar(dr+':\')) = DRIVE_REMOTE then Exit; Result := True; finally SetErrorMode(E); end; end; begin if HandleAllocated then if not (csLoading in ComponentState) then begin fAllowChange := False; // no changes allowed and no event fired until this will be finished oldcur := Screen.Cursor; Screen.Cursor := crHourGlass; // show that we are busy Items.BeginUpdate; ClearList; Application.ProcessMessages; // let the task go ahead (a bit) // now let us read the drives E := SetErrorMode(SEM_FAILCRITICALERRORS); // don't know whether needed here try Integer(bits):=GetLogicalDrives; finally SetErrorMode(E); end; for ct := 0 to 25 do if DriveExists(ct) then begin drv := Char (ct+Ord('A')); // casting numbers 0..25 to drives A..Z if AskAdd(drv+':\') then begin // if it is allowed to add this drive AddNode(node,drv+':\'); // create a new root node in the tree if fFastLoad then // do not search for the existance of sub dirs Items.AddChild(node,'') else case GetDriveType(PChar(drv+':\')) of 0,1,DRIVE_REMOVABLE,DRIVE_CDROM :Items.AddChild(node,''); // always guess button state for disks and cdroms else GetBtn(node); // net, hard : retrieve the real button state (if no fastload) end; end; end; fAllowChange := True; Items.EndUpdate; TopItem := Selected; // make the selected node visible Screen.Cursor := oldcur; end; end; procedure TDirTree.CreateWnd ; begin inherited; if fReadOnStart then ReadNew; // for automatic startup-filling of the tree end; function TDirTree.CanExpand(Node: TTreeNode): Boolean ; var oldcur : TCursor; begin oldcur := Screen.Cursor; Screen.Cursor := crhourglass; GetKids(Node); // first setup the subtree and the button states GetSubKids(Node); Screen.Cursor := oldcur; Result := inherited CanExpand(Node); end; procedure TDirTree.Change(Node: TTreeNode); // setup the current dir and check whether it is allowed to fire the onchange-event var sr : string; begin if not (csDestroying in ComponentState) then if fAllowChange then begin if Node <> nil then begin sr := UpperCase(EntryName(Node)); try fActDirs[sr[1]] := sr; except end; end; inherited change (node); end; end; procedure TDirTree.FullExpand; var oldcur : TCursor; var Node: TTreeNode; begin oldcur := Screen.Cursor; Screen.Cursor := crHourGlass; Node := Items.GetFirstNode; while Node <> nil do begin Node.Expand(True); Node := Node.GetNextSibling; end; Screen.Cursor := oldcur; end; procedure TDirTree.SetDrive (Val : Char); // try to set the wanted drive and the last used directory on that drive var sr : string; begin if UpCase(val) = UpCase (GetDirectory[1]) then Exit; // nothing changed try sr := fActDirs[UpCase(Val)]; if not FileOrDirExists(sr) then sr := Copy(sr,1,3); SetDirectory(sr); except end; end; function TDirTree.GetDrive : Char; begin Result := UpCase(GetDirectory[1]); end; function TDirTree.GetNodeFromPath(Path:string):TTreeNode; // if there is a node that belongs to the given path, returns it var az : Integer; node : TTreeNode; oldcur : TCursor; afg : Integer; tsr : string; function GNd(c:TTreeNode;a:string):TTreeNode; // find a node that has this path var sr : TTreeNode; begin Result := nil; if Items.Count = 0 then Exit; if c <> nil then sr := c.GetFirstChild else sr := Items[0]; while sr <> nil do begin if EntryName(sr) = a then begin Result := sr; Exit; end; sr := sr.GetNextSibling; end; end; begin Result := nil; AddBSlash(Path); // get the part strings (delimited by "\") az := AzPos(Path); if az = 0 then Exit; oldcur := Screen.Cursor; Screen.Cursor := crHourGlass; Path := UpperCase(Path); node := nil; for afg := 1 to az do begin // get the partial directories tsr := GetPart(Path,afg); node := GNd(node,tsr); if node = nil then begin Screen.Cursor := oldcur; Exit; end; end; Result := Node; Screen.Cursor := oldcur; end; procedure TDirTree.DelItem (Sender: TObject; Node: TTreeNode); // delete not only the item but also the assigned tdirentry begin if Node.Data <> nil then begin PDirEntry(Node.Data)^.Name := ''; Dispose(PDirEntry(Node.Data)); Node.Data := nil; end; if Assigned(fOnDeletion) then fOnDeletion(Sender,Node); end; procedure TDirTree.RenamePart (OldPath,NewName:string); // rename a part of the tree (e.g. after renaming a directory on the drive) var n : TTreeNode; procedure RenameNodeAndKids(n:TTreeNode); // renames all childs (and assigned tdirentries) of that node var sfi : TSHFileInfo; oldsr : string; n1 : TTreeNode; begin // first look whether the icon of this directory has changed oldsr := NewName+Copy(EntryName(n),Length(OldPath)+1,MaxInt); SHGetFileInfo(PChar(oldsr),0,sfi,SizeOf(TSHFileInfo),SHGFI_SYSICONINDEX or SHGFI_SMALLICON or SHGFI_DISPLAYNAME); n.Text := sfi.szDisplayName; // n.ImageIndex := sfi.iIcon; PDirEntry(n.Data)^.Name := oldsr; GetImageIndex(n,sfi.iIcon); if n = Selected then Change(n); if IsExpanded(n) and n.HasChildren then begin n1 := n.GetFirstChild; while n1 <> nil do begin RenameNodeAndKids(n1); // recurse subdirectories n1 := n.GetNextChild(n1); end; end; end; begin if NewName = '' then Exit; if OldPath = '' then Exit; // nothing to do resp. empty string is not usefull n := GetNodeFromPath(OldPath); // find the wanted path if n <> nil then begin OldPath := EntryName(n); // fix the name NewName := ExtractFilePath(DelBSlash(OldPath))+NewName; // add the newname to the parent path of oldpath AddBSlash(NewName); NewName := UpperCase(NewName); RenameNodeAndKids(n); // now rename the partial tree end; end; procedure TDirTree.DeletePart (DPath:string); // remove the given path incl. child nodes from the tree var n : TTreeNode; begin n := GetNodeFromPath(DPath); if n <> nil then Items.Delete(n); end; procedure TDirTree.AddPath(ExPath,NewSub:string); // adds a partial tree under the given (and existing) path var n,n1 : TTreeNode; begin n := GetNodeFromPath(ExPath); if n <> nil then n1:=AddKid(n,EntryName(n)+NewSub); GetBtn(n1); n.AlphaSort; end; procedure TDirTree.ClearNode (Node:TTreeNode); // delete the children of that node and read them new on next access begin if Node = nil then Exit; Node.DeleteChildren; PDirEntry(Node.Data)^.IsExp := False; GetBtn(Node); end; function TDirTree.IsExpanded(Item : TTreeNode):Boolean; begin Result := False; try if Item <> nil then if Assigned(Item.Data) then Result := PDirEntry(Item.Data)^.IsExp; except Result := False; end; end; procedure TDirTree.Loaded; begin inherited Loaded; ReadNew; SetDirectory( GetDirectory ); end; end.