Mega Code Archive
DirectoryTree Component
<![CDATA[
Title: DirectoryTree Component
Question: This component acts and looks like the window to the left of the vertical splitter of Windows Explorer.
Answer:
{---------------------------------------------------------------------
DirectoryTree (Visual Component)
----------------------------------------------------------------------
This component acts and looks like the window, to the left of the
vertical splitter of Windows Explorer. With this visual component you
are able to choose a drive and / or a directory and react on the
OnChange event. If the OnChange event occurs, you can read the new
directory in the property: Directory of the component.
The component even works correct at design time, although you will not
be able to open the drives during design time.
For suggestions, improvements, remarks, enhancements, please email:
M.deHaan@inn.nl
This component is tested under Windows 95A (SP1) and Windows NT
(4.0 SP6) and it is written in Delphi 5.0.
The component will be registered under 'Samples', but you can change
that.
----------------------------------------------------------------------
=================
November 17, 2000
=================
Under WinNT the directories of this component are always sorted. Under
W95 the directories of this component are NOT sorted. I have tried to
get the directories sorted with the property "AlphaSort" set to true,
while creating a new node, but this doesn't seem work for ALL nodes.
All root directories still remain unsorted. A work around for this
inconveniance is shown in the procedure FINDDIRS. The disadvantage of
this method is that it takes just a little bit longer befor the
directorie entries are shown in the component...
================
January 10, 2002
================
By means of first reading the directories in a TStringList and then,
when all the directories are read, read them into the TreeView, the
sorting problem is completely solved! (You can set the sorted property
of the TStringList to false or true, so the TreeView will be sorted or
not.)
================
January 12, 2002
================
Changed the behaviour of the DirectoryTree component.
1) If you click once on a directory name, it will be selected.
2) If you click once on the '+'-button or '-'-button of a node, it
will collapse or implode. Depending on the previous state and
depending if it can collapse. If it cannot collapse (when there are
no subdirectories) the '+'-button disappears. Clicking on the
'+'-button or '-'-button of a node doesn't cause the selected
directory to change, unless a subdirectory of this node was
selected and the node is imploded by clicking on the '+'-button.
3) Double clicking on the icon or the directory name is the same as
under 2.
With these modifications, the DirectoryTree acts more like the
directorytree to the left of the vertical splitter in the Windows
Explorer. (I hope you'll agree to that..)
---------------------------------------------------------------------}
Unit DirectoryTree;
// {$I+,Q+,S+,R+,H+,X+}
Interface
Uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
Dialogs, ComCtrls, ImgList, StdCtrls, FileCtrl;
Const
// You can change this into your own language, if you want
Rootname : String = 'My Computer';
Type
TDirectoryTree = class(TCustomTreeView)
private
{ Private declarations }
fStringList : TStringList; // added 10-01-02
fImageList : TCustomImageList;
fDirectory : String;
fOnChange : TNotifyEvent;
// fDirLabelSet : Boolean; // removed 21-01-02
fTreenodes : TTreenodes;
fCurDrive : String;
fSort : Boolean; // added 17-11-00
Procedure FindDirs(S : String; T : TTreenode);
// Procedure GetNodeInfo(T : TTreenode); // removed 23-01-02
Procedure fChanges; dynamic;
Procedure fSetSort(Value : Boolean);
Protected
{ Protected declarations }
// Procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
// X, Y: Integer); override; // removed 12-01-02
Procedure Click; override; // added 12-01-02
Procedure DblClick; override; // added 12-01-02
Public
{ Public declarations }
Constructor Create(AOwner : TComponent); override;
Destructor Destroy; override;
// Procedure UpDate; reintroduce; // removed 12-01-02
Procedure FindDrives; dynamic;
Procedure CreateWnd; override;
Published
{ Published declarations }
{--- properties ---}
Property Align;
Property Anchors;
Property Color;
Property Constraints;
Property Cursor;
Property Directory : String
read fDirectory write fDirectory;
Property DragCursor;
Property DragKind;
Property DragMode;
Property Enabled;
Property Font;
Property Height;
Property HelpContext;
Property Hint;
Property Left;
Property Name;
Property ParentColor;
Property ParentFont;
Property ParentShowHint;
Property PopupMenu;
Property ShowHint;
Property Sort : Boolean
read fSort write fSetSort; // added 17-11-00
Property TabOrder;
Property TabStop;
Property Tag;
Property Top;
Property Visible;
Property Width;
{--- Events ---}
Property OnChange : TNotifyEvent
read fOnChange write fOnChange;
Property OnClick;
Property OnDblClick;
Property OnDragDrop;
Property OnDragOver;
Property OnEndDrag;
Property OnEnter;
Property OnExit;
Property OnKeyDown;
Property OnKeyPress;
Property OnKeyUp;
Property OnMouseDown;
Property OnMouseMove;
Property OnMouseUp;
Property OnStartDrag;
End;
Procedure Register;
// Load the bitmaps, 16 x 16 bits, 256 color
{$R IMAGES.RES}
Implementation
{--------------------------------------------------------------------}
Function IsDriveReady(Const Ch : Char) : Boolean;
Var
SR : TSearchRec;
oldErrorMode : Integer;
Begin
oldErrorMode := SetErrorMode(SEM_FAILCRITICALERRORS);
{$I-}
If FindFirst(Ch + ':\*.*',faAnyfile,SR) = 0 then
Result := True
else
Result := False;
FindClose(SR);
SetErrorMode(oldErrorMode);
{$I+}
End;
{--------------------------------------------------------------------}
(* From Delphi 5 sources:
c:\program files\borland\delphi5\source\vcl\filectrl.pas
Procedure TDirectoryTree.SetFileListBox(Value: TFileListBox);
Begin
If fFileList nil then
fFileList.DirList := nil;
fFileList := Value;
If fFileList nil then
Begin
fFileList.DirList := Self;
fFileList.FreeNotification(Self);
End;
End; *)
{--------------------------------------------------------------------}
(* From Delphi 5 sources:
c:\program files\borland\delphi5\source\vcl\filectrl.pas
Procedure CutFirstDirectory(var S: TFileName);
Var
Root : Boolean;
P : Integer;
Begin
If S = '\' then
S := ''
else
Begin
If S[1] = '\' then
Begin
Root := True;
Delete(S, 1, 1);
End
else
Root := False;
If S[1] = '.' then
Delete(S, 1, 4);
P := AnsiPos('\',S);
If P 0 then
Begin
Delete(S, 1, P);
S := '...\' + S;
End
else
S := '';
If Root then
S := '\' + S;
End;
End; *)
{--------------------------------------------------------------------}
(* From Delphi 5 sources:
c:\program files\borland\delphi5\source\vcl\filectrl.pas
Function MinimizeName(const Filename: TFileName; Canvas: TCanvas;
MaxLen: Integer): TFileName;
Var
Drive : TFileName;
Dir : TFileName;
Name : TFileName;
Begin
Result := FileName;
Dir := ExtractFilePath(Result);
Name := ExtractFileName(Result);
If (Length(Dir) = 2) and (Dir[2] = ':') then
begin
Drive := Copy(Dir, 1, 2);
Delete(Dir, 1, 2);
end
else
Drive := '';
While ((Dir '') or (Drive '')) and
(Canvas.TextWidth(Result) MaxLen) do
Begin
If Dir = '\...\' then
Begin
Drive := '';
Dir := '...\';
End
else
If Dir = '' then
Drive := ''
else
CutFirstDirectory(Dir);
Result := Drive + Dir + Name;
End;
End; *)
{--------------------------------------------------------------------}
(* From Delphi 5 sources:
c:\program files\borland\delphi5\source\vcl\filectrl.pas
Procedure TDirectoryTree.SetDirLabel (Value: TLabel);
Begin
fDirLabel := Value;
if Value nil then
Value.FreeNotification(Self);
SetDirLabelCaption;
End;
*)
{--------------------------------------------------------------------}
(* From Delphi:
c:\program files\borland\delphi5\source\vcl\filectrl.pas
Procedure TDirectoryTree.SetDirLabelCaption;
Var
DirWidth: Integer;
Begin
If fDirLabel nil then
Begin
DirWidth := Width;
If not fDirLabel.AutoSize then
DirWidth := fDirLabel.Width;
fDirLabel.Caption := MinimizeName(Directory, fDirLabel.Canvas,
DirWidth);
End;
End; *)
{--------------------------------------------------------------------}
Procedure TDirectoryTree.fSetSort(Value : Boolean); // added 17-11-00
Begin
If fSort Value then
Begin
fSort := Value;
Invalidate;
End;
End;
{--------------------------------------------------------------------}
Procedure TDirectoryTree.fChanges;
Begin
If Assigned(fOnChange) then
fOnChange(Self);
End;
{--------------------------------------------------------------------}
// Procedure FindDirs is changed on: 10-01-02
// The dirs found are first loaded in a TStringList of which the
// property "Sorted" can be set to "True" or "False".
// Then, when all directories are found, the TCustomTreeView is updated,
// thus achieving a sorted or a non-sorted TreeView.
{--------------------------------------------------------------------}
Procedure TDirectoryTree.FindDirs(S : String; T : TTreenode);
Var
SR : TSearchRec;
T1 : TTreenode;
S1 : String;
I : Byte;
Begin
S1 := S;
If S[Length(S)] '\' then
S1 := S1 + '\';
If not IsDriveReady(S1[1]) then
Exit;
// Throw away the old entries
fStringList.Clear; // added 10-01-02
// Sorted or not
fStringList.Sorted := fSort; // added 10-01-02
// Sorting cannot be undone, see Delphi's help on "TStringList.Sorted"
// changed 10-01-02
If FindFirst(S1 + '*.*',faAnyFile,SR) = 0 then // changed 12-01-02
Begin
// changed and simplified 12-01-02
If ((SR.Attr and faDirectory) = faDirectory) then
If (SR.Name '.') and (SR.Name '..') then
fStringList.Add(SR.Name);
While FindNext(SR) = 0 do
Begin
If ((SR.Attr and faDirectory) = faDirectory) then
If (SR.Name '.') and (SR.Name '..') then
fStringList.Add(SR.Name);
End;
End;
FindClose(SR); // added 19-01-02
// This peace is added 10-01-02
// Update the TreeView from the StringList, thus solving the sorting
// problem
If fStringList.Count 0 then
Begin
fTreeNodes.BeginUpdate; // added 12-01-02
For I := 0 to fStringList.Count-1 do
Begin
T1 := Items.AddChild(T,fStringList.Strings[I]);
T1.SelectedIndex := 1;
T1.HasChildren := True;
End;
fTreeNodes.EndUpdate; // added 12-01-02
End;
End;
{--------------------------------------------------------------------}
(*
Procedure TDirectoryTree.GetNodeInfo(T : TTreenode);
Var
S : String;
T1 : TTreenode;
Begin
S := T.Text;
If S = Rootname then
Exit;
T1 := T;
While Pos(':',S) 2 do
Begin
T1 := T1.Parent;
S := T1.Text + '\' + S;
End;
If T.Count = 0 then
FindDirs(S,T);
If fDirectory S then
Begin
fDirectory := S;
fChanges;
End;
End;
*)
{--------------------------------------------------------------------}
Procedure TDirectoryTree.FindDrives;
Var
Tr,T1 : TTreenode;
ld : DWord;
I : Integer;
Drive : String;
Begin
Items.Clear;
ld := GetLogicalDrives;
Tr := Items.Add(nil,Rootname);
Tr.ImageIndex := 2;
Tr.SelectedIndex := 2;
fTreeNodes.BeginUpdate; // added 22-01-02
For I := 0 to 25 do
Begin
If (ld and (1 shl I)) 0 then
Begin
Drive := Chr(65 + I) + ':';
T1 := Items.AddChild(Tr,Drive);
T1.HasChildren := True; // Create a '+' in the node
// Adjust drive icon
Case GetDriveType(PChar(Drive[1] + ':\')) of
0,DRIVE_FIXED : Begin
T1.ImageIndex := 3;
T1.SelectedIndex := 3;
End;
DRIVE_CDROM : Begin
T1.ImageIndex := 4;
T1.SelectedIndex := 4;
End;
DRIVE_REMOVABLE : Begin
T1.ImageIndex := 5;
T1.SelectedIndex := 5;
End;
DRIVE_RAMDISK: Begin
T1.ImageIndex := 6;
T1.SelectedIndex := 6;
End;
DRIVE_REMOTE : Begin
T1.ImageIndex := 7;
T1.SelectedIndex := 7;
End;
End; // of Case
If fCurDrive = Drive then
T1.Selected := True; // Select current drive
End;
End;
fTreeNodes.EndUpdate; // added 22-01-02
End;
{--------------------------------------------------------------------}
Constructor TDirectoryTree.Create(AOwner : TComponent);
Var
dBitmap : TBitmap;
Begin
inherited Create(AOwner);
// Init CustomTreeview
ShowRoot := True;
ShowButtons := True;
ReadOnly := True;
// Init Sort
Sort := True; // added 17-11-00
fSort := True;
// fDirLabelSet := False; // removed 21-01-02
fDirectory := '';
fImageList := TCustomImageList.Create(Self);
fImageList.Clear;
fImageList.BkColor := clWhite;
fImageList.BlendColor := clWhite;
fImageList.Masked := True;
fImageList.Height := 16;
fImageList.Width := 16;
fImageList.AllocBy := 7;
// Load DIRCLOSE bitmap
dBitmap := TBitmap.Create; // create dummy bitmap
dBitmap.Handle := LoadBitmap(hInstance,'DIRCLOSE');
// Add to ImageList
fImageList.Add(dBitmap,nil); // 0
// Load DIROPEN bitmap
dBitmap.Handle := LoadBitmap(hInstance,'DIROPEN');
// Add to ImageList
fImageList.Add(dBitmap,nil); // 1
// Load COMPUTER bitmap
dBitmap.Handle := LoadBitmap(hInstance,'COMPUTER');
// Add to ImageList
fImageList.Add(dBitmap,nil); // 2
// Load HARDDISK bitmap
dBitmap.Handle := LoadBitmap(hInstance,'HARDDISK');
// Add to ImageList
fImageList.Add(dBitmap,nil); // 3
// Load CDROMDISK bitmap
dBitmap.Handle := LoadBitmap(hInstance,'CDROMDISK');
// The word 'CDROM' gives
// problems (reserved?)
// Add to ImageList
fImageList.Add(dBitmap,nil); // 4
// Load FLOPPYDISK bitmap
dBitmap.Handle := LoadBitmap(hInstance,'FLOPPYDISK');
// A bitmap named 'FLOPPY'
// already exists
// (reserved?)
// Add to ImageList
fImageList.Add(dBitmap,nil); // 5
// Load RAMDISK bitmap
dBitmap.Handle := LoadBitmap(hInstance,'RAMDISK');
// Add to ImageList
fImageList.Add(dBitmap,nil); // 6
// Load REMOTEDISK bitmap
dBitmap.Handle := LoadBitmap(hInstance,'REMOTEDISK');
// Add to ImageList
fImageList.Add(dBitmap,nil); // 7
// Free the dummy bitmap
dBitmap.Free;
// Assign the imagelist to TreeView.Images
Images := fImageList;
// The CustomTreeView has no treenodes yet, so we have to create
// them...
fTreenodes := TTreenodes.Create(Self);
fTreenodes.Clear; // Clear the treenodes
fStringList := TStringList.Create; // added 10-01-02
End;
{--------------------------------------------------------------------}
Procedure TDirectoryTree.CreateWnd;
Var
P : String;
Begin
inherited CreateWnd;
GetDir(0,P);
fCurDrive := UpCase(P[1]) + ':';
FindDrives; // is dynamic!!
End;
{--------------------------------------------------------------------}
// Added 12-01-02
Procedure TDirectoryTree.DblClick;
Var
T,T1 : TTreenode;
S : String;
HT : THitTests;
iOldCount : Integer;
pPoint : TPoint;
Begin
inherited DblClick;
GetCursorPos(pPoint); // Get cursor position
pPoint := ScreenToClient(pPoint); // Translate to client coordinates
HT := GetHitTestInfoAt(pPoint.X,pPoint.Y); // Check for hits
// Handle the DblClick on an item of a node
If (htOnItem in HT) then
Begin
T := GetNodeAt(pPoint.X,pPoint.Y);
// Highlight the name
T.Selected := True;
// Save old count
iOldCount := T.Count;
S := T.Text;
If S = Rootname then
Exit;
// Get full path
T1 := T;
While Pos(':',S) 2 do
Begin
T1 := T1.Parent;
S := T1.Text + '\' + S;
End;
// Is the path changed?
If fDirectory S then
Begin
fDirectory := S;
fChanges;
End;
// Find the directories (if any)
If T.Count = 0 then
FindDirs(S,T);
// Only the first time it will not expand by clicking on the button
If T.Count = 0 then
T.HasChildren := False // Removes the '+'-button
else
Begin
If (iOldCount = 0) then
T.Expanded := True;
End;
End;
End;
{--------------------------------------------------------------------}
// Added 12-01-02
Procedure TDirectoryTree.Click;
Var
T,T1 : TTreenode;
S : String;
HT : THitTests;
iOldCount : Integer;
pPoint : TPoint;
Begin
inherited Click;
GetCursorPos(pPoint); // Get cursor position
pPoint := ScreenToClient(pPoint); // Translate to client coordinates
HT := GetHitTestInfoAt(pPoint.X,pPoint.Y); // Check for hits
// Handle the Click on the '+'-button or '-'-button of a node
If (htOnButton in HT) then
Begin
T := GetNodeAt(pPoint.X,pPoint.Y);
// Save old count
iOldCount := T.Count;
S := T.Text;
If S = Rootname then
Exit;
// Get full path
T1 := T;
While Pos(':',S) 2 do
Begin
T1 := T1.Parent;
S := T1.Text + '\' + S;
End;
// Find the direectories (if any)
If T.Count = 0 then
FindDirs(S,T);
// Only the first time it will not expand by clicking on the button
If T.Count = 0 then
T.HasChildren := False // Removes the '+'-button
else
Begin
If (iOldCount = 0) then
T.Expanded := True;
End;
End;
//Handle the Click on an item of a node
If (htOnItem in HT) then
Begin
T := GetNodeAt(pPoint.X,pPoint.Y);
S := T.Text;
If S = Rootname then
Exit;
// Get full path
T1 := T;
While Pos(':',S) 2 do
Begin
T1 := T1.Parent;
S := T1.Text + '\' + S;
End;
// Changed?
If fDirectory S then
Begin
fDirectory := S;
fChanges;
End;
// Highlight the name
T.Selected := True;
End;
End;
{--------------------------------------------------------------------}
(*
Procedure TDirectoryTree.Update;
Var
P : String;
Begin
GetDir(0,P);
fCurDrive := UpCase(P[1]) + ':';
ChDir(fCurDrive);
FindDrives;
fChanges;
End;
*)
{--------------------------------------------------------------------}
Destructor TDirectoryTree.Destroy;
Begin
fImageList.Free; // Free the ImageList
fTreenodes.Free; // Free the Treenodes
fStringList.Free; // Free the StringList, added 10-01-02
inherited Destroy;
End;
{--------------------------------------------------------------------}
Procedure Register;
Begin
RegisterComponents('Samples', [TDirectoryTree]);
End;
{--------------------------------------------------------------------}
End.
{====================================================================}
]]>