Компонент DirectoryTree.

Автор: Maarten de Haan

Данный компонент действует и выглядит аналогично левой части окна Проводника в Windows. Компонент позволяет выбирать диск (дисковод) и / или директорию и реагировать на событие
OnChange. Компонент правильно работает даже во время прорисовки, то есть не даст открыть диск во время прорисовки.

Скачать компонент - 14 Kb

Совместимость: Delphi 5.x (или выше)

Компонент тестировался под Windows 95A (SP1) и Windows NT (4.0 SP5).

Компонент будет зарегистрирован как 'Samples'.
---------------------------------------------------------------------}

Unit DirectoryTree;

{$R-,T-,H+,X+}

Interface

Uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
   Dialogs, ComCtrls, ImgList, StdCtrls, FileCtrl;

Const
   Rootname : String = 'My Computer';

Type
   TDirectoryTree = class(TCustomTreeView)
   private
   { Private declarations }
      fImageList                 : TCustomImageList;
      fDirectory                 : String;
      fOnChange                  : TNotifyEvent;
      fDirLabel                  : TLabel;
      fDirLabelSet               : Boolean;
      fFileList                  : TFileListbox;
      fDirList                   : TDirectoryTree;
      fTreenodes                 : TTreenodes;
      fCurDrive                  : String;

      //Procedure SetDirLabel(Value : TLabel);
      //Procedure SetDirLabelCaption;
      Procedure FindDirs(S : String; T : TTreenode);
      Procedure GetNodeInfo(T : TTreenode);
      Procedure fChanges; dynamic;
      //Procedure SetFileListBox(Value : TFileListBox);
      //Function MinimizeName(const Filename : TFileName;
      //   Canvas : TCanvas; MaxLen : Integer): TFileName;
      //procedure CutFirstDirectory(var S : TFileName);

   Protected
   { Protected declarations }
      Procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
         X, Y: Integer); override;

   Public
   { Public declarations }
      Constructor Create(AOwner : TComponent); override;
      Destructor Destroy; override;
      Procedure UpDate; reintroduce;
      Procedure FindDrives; dynamic;
      Procedure CreateWnd; override;

   Published
   { Published declarations }
      {--- свойства ---}
      Property Align;
      Property Anchors;
      //Property AutoExpand;
      //Property BiDiMode;
      //Property BorderStyle;
      //Property BorderWidth;
      //Property ChangeDelay;
      Property Color;
      Property Constraints;
      Property Cursor;
      //Property DirLabel : TLabel
      //   read fDirLabel write SetDirLabel;
      Property Directory : String
         read fDirectory write fDirectory;
      Property DragCursor;
      Property DragKind;
      Property DragMode;
      Property Enabled;
      //Property FileList : TFileListbox
      //   read fFileList write SetFileListbox;
      Property Font;
      Property Height;
      Property HelpContext;
      //Property HideSelection;
      Property Hint;
      //Property HotTrack;
      //Property Images;
      //Property Indent;
      //Property Items;
      Property Left;
      Property Name;
      //Property ParentBiDiMode;
      Property ParentColor;
      Property ParentFont;
      Property ParentShowHint;
      Property PopupMenu;
      //Property ReadOnly;
      //Property RightClickSelect;
      //Property RowSelect;
      //Property ShowButtons;
      Property ShowHint;
      //Property ShowLines;
      //Property ShowRoot;
      //Property SortType;
      //Property StateImages;
      Property TabOrder;
      Property TabStop;
      Property Tag;
      //Property ToolTips;
      Property Top;
      Property Visible;
      Property Width;
      {--- События ---}
      //Property OnAdvancedCustomDraw;
      //Property OnAdvancedCustomDrawItem;
      Property OnChange : TNotifyEvent
         read fOnChange write fOnChange;
      //Property OnChanging;
      Property OnClick;
      //Property OnCollapsed;
      //Property OnCollapsing;
      //Property OnCompare;
      //Property OnContextPopup;
      //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 OnMouseMove;
      Property OnMouseUp;
      //Property OnStartDock;
      Property OnStartDrag;
      End;

Procedure Register;

// Загружаем bitmap-ы, 16 x 16 бит, 256 цветов
{$R IMAGES.RES}

Implementation

{--------------------------------------------------------------------}
(* Из исходников Delphi 5:
   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; *)
{--------------------------------------------------------------------}
(* Из исходников Delphi 5:
   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; *)
{--------------------------------------------------------------------}
(* Из исходников Delphi 5:
   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; *)
{--------------------------------------------------------------------}
(* Из исходников Delphi 5:
   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;
*)
{--------------------------------------------------------------------}
(* Из 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.fChanges;

Begin
If Assigned(fOnChange) then
   fOnChange(Self);
End;
{--------------------------------------------------------------------}
Procedure TDirectoryTree.FindDirs(S : String; T : TTreenode);

Var
   Res         : Integer;
   SR          : TSearchRec;
   T1          : TTreenode;
   S1          : String;

Begin
S1 := S;
If S[Length(S)] <> '\' then
   S1 := S1 + '\';
Res := FindFirst(S1 + '*.*',faAnyFile,SR);

If Res = 0 then
   Repeat
      If ((SR.Attr and faDirectory) = faDirectory) then
         If (SR.Name <> '.') and (SR.Name <> '..') then
            Begin
            T1 := Items.AddChild(T,SR.Name);
            T1.SelectedIndex := 1;  // Diropen.bmp when selected
            T1.HasChildren := True; // Creates a '+' sign
            End;
      Res := FindNext(SR);
   Until Res <> 0;

FindClose(SR);
End;
{--------------------------------------------------------------------}
Procedure TDirectoryTree.GetNodeInfo(T : TTreenode);

Var
   S      : String;
   T1     : TTreenode;

Begin
S := T.Text;
If S = Rootname then
   Exit;
T1 := T;
Repeat
   T1 := T1.Parent;
   If S[2] <> ':' then
      S := T1.Text + '\' + S;
Until S[2] = ':';

If T.Count = 0 then
   FindDirs(S,T);

fDirectory := S;
fChanges;
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;
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;
      // Корректируем иконку диска
      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; // конец Case
      If fCurDrive = Drive then
         T1.Selected := True; // Выбираем текущий диск
      End;
   End;

End;
{--------------------------------------------------------------------}
Constructor TDirectoryTree.Create(AOwner : TComponent);

Var
   bDirClose,bDirOpen         : TBitmap;
   bFloppy,bComputer          : TBitmap;
   bHardDisk,bCDRom           : TBitmap;
   bRemoteDrive,bRamdisk      : TBitmap;

Begin
inherited Create(AOwner);
ShowRoot := True;
ReadOnly := True;
SortType := stBoth;
fDirLabelSet := False;
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;

// Загружаем картинку DIRCLOSE
bDirClose := TBitmap.Create;
bDirClose.Handle := LoadBitmap(hInstance,'DIRCLOSE');
// Добавляем в ImageList
fImageList.Add(bDirClose,nil);     // 0
bDirClose.Free;

// Загружаем картинку DIROPEN
bDirOpen := TBitmap.Create;
bDirOpen.Handle := LoadBitmap(hInstance,'DIROPEN');
// Добавляем в ImageList
fImageList.Add(bDirOpen,nil);      // 1
bDirOpen.Free;

// Загружаем картинку COMPUTER
bComputer := TBitmap.Create;
bComputer.Handle := LoadBitmap(hInstance,'COMPUTER');
// Добавляем в ImageList
fImageList.Add(bComputer,nil);     // 2
bComputer.Free;

// Загружаем картинку HARDDISK
bHardDisk := TBitmap.Create;
bHardDisk.Handle := LoadBitmap(hInstance,'HARDDISK');
// Добавляем в ImageList
fImageList.Add(bHardDisk,nil);     // 3
bHardDisk.Free;

// Загружаем картинку CDROMDISK
bCDRom := TBitmap.Create;
bCDRom.Handle := LoadBitmap(hInstance,'CDROMDISK');
                                   // Со словом 'CDROM' возникают проблемы
// Добавляем в ImageList
fImageList.Add(bCDRom,nil);        // 4
bCDRom.Free;

// Загружаем картинку FLOPPYDISK
bFloppy := TBitmap.Create;
bFloppy.Handle := LoadBitmap(hInstance,'FLOPPYDISK');
                                   // bitmap с именем 'FLOPPY'
                                   // уже существует
// Добавляем в ImageList
fImageList.Add(bFloppy,nil);       // 5
bFloppy.Free;

// Загружаем картинку RAMDISK
bRamDisk := TBitmap.Create;
bRamDisk.Handle := LoadBitmap(hInstance,'RAMDISK');
// Добавляем в ImageList
fImageList.Add(bRamDisk,nil);      // 6
bRamDisk.Free;

// Загружаем картинку REMOTEDISK
bRemoteDrive := TBitmap.Create;
bRemoteDrive.Handle := LoadBitmap(hInstance,'REMOTEDISK');
// Добавляем в ImageList
fImageList.Add(bRemoteDrive,nil);  // 7
bRemoteDrive.Free;

Images := fImageList; // Assign the imagelist to TreeView.Images
// CustomTreeView не имеет никаких treenodes, поэтому мы должны создать их..
fTreenodes := TTreenodes.Create(Self);
End;
{--------------------------------------------------------------------}
Procedure TDirectoryTree.CreateWnd;

Var
   P : String;

Begin
inherited CreateWnd;
GetDir(0,P);
fCurDrive := UpCase(P[1]) + ':';
FindDrives; //Является динамическим!!
End;
{--------------------------------------------------------------------}
Procedure TDirectoryTree.MouseDown(Button: TMouseButton;
   Shift : TShiftState; X, Y: Integer);

Var
   T,T1           : TTreenode;
   S              : String;
   HT             : THitTests;
   I              : Integer;

Begin
inherited MouseDown(Button,Shift,X,Y);
HT := GetHitTestInfoAt(X,Y);
If (htOnItem in HT) or (htOnIcon in HT) or (htOnButton in HT) then
   Begin
   T := GetNodeAt(X,Y);
   S := T.Text;
   If S = Rootname then
      Exit;
   T1 := T;
   Repeat
      T1 := T1.Parent;
      If S[2] <> ':' then
         S := T1.Text + '\' + S;
   Until S[2] = ':';
   fDirectory := S;
   fChanges;
   I := T.Count;
   GetNodeInfo(T);
   T.Selected := True;
   If T.Count > 0 then
      Begin
      If I = 0 then
         T.Expanded := True;
      End
   else
      T.HasChildren := False; // удаляем знаки '-' или '+'
   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; // Удаляем ImageList
fTreenodes.Free; // Удаляем Treenodes
inherited Destroy;
End;
{--------------------------------------------------------------------}
Procedure Register;

Begin
RegisterComponents('Samples', [TDirectoryTree]);
End;
{--------------------------------------------------------------------}
End.
{====================================================================}