PC Plus SuperCD (UK) 2000 March/pcp161b.iso/handson/archive/Issue153/delphi/copydelp.exe/TreeDir2/TreeD2.pas

Pascal/Delphi Source File | 1999-03-21 | 16.7 KB | 486 lines

unit TreeD2;
   { PC Plus sample Delphi 2.0 file manager.
   Author: Huw Collingbourne

   ------------IMPORTANT DISCLAIMER----------------
   This application can erase files from your disk!
   It is provided as a sample program and it is not
   guaranteed to be flawless, safe or fit for any
   purpose whatsoever. In short, while I don't
   believe it will damage or corrupt your files,
   I do not guarantee that it won't!
   ------------------------------------------------

   Functionality:
   * Displays TreeView directory window
   * Displays ListView of files with appropriate icons
   * Splitter panel lets you resize windows at run-time
   * Double-click to excute selected file
   * Single-click file name to rename file
   * Press the DELETE key to erase selected file
   * Popup menu provides alternatives to keystrokes
   * DriveComboBox lets you log onto a new disk

   Limitations:
   * No drag and drop
   * No copy and move functions
   }

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, ComCtrls, ExtCtrls, ShellAPI,
  CommCtrl, FileCtrl,
  FMXUtils, Menus, SHLObj;

type
  TForm1 = class(TForm)
    StatusBar1: TStatusBar;
    ImageList1: TImageList;
    HeaderPanel: TPanel;
    DriveComboBox1: TDriveComboBox;
    PopupMenu1: TPopupMenu;
    Delete: TMenuItem;
    Rename: TMenuItem;
    MainPanel: TPanel;
    ListView1: TListView;
    TreeView1: TTreeView;
    SplitterPanel: TPanel;
    procedure TreeView1Expanding(Sender: TObject; Node: TTreeNode;
      var AllowExpansion: Boolean);
    procedure FormCreate(Sender: TObject);
    procedure TreeView1Click(Sender: TObject);
    procedure ListView1Click(Sender: TObject);
    procedure ListView1DblClick(Sender: TObject);
    procedure SplitterPanelMouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure FormResize(Sender: TObject);
    procedure DriveComboBox1Change(Sender: TObject);
    procedure DeleteClick(Sender: TObject);
    procedure RenameClick(Sender: TObject);
    procedure ListView1Edited(Sender: TObject; Item: TListItem;
      var S: string);
    procedure ListView1Change(Sender: TObject; Item: TListItem;
      Change: TItemChange);
  private
    { Private declarations }
  public
    { Public declarations }
    CurrDirName : string;
    CurrFileName : string;
    ItemEdited : boolean;
    function isDirectory( sr : TSearchRec ) : boolean;
    function excludeFromListView( sr : TSearchRec ) : boolean;
    function hasSubDirectories( d : string ) : boolean;
    function fullPath( Node : TTreeNode ) : string;
    procedure addSubDirs( rootDir : string;  Node   : TTreeNode );
    procedure updatePanels;
    procedure updateListView;
  end;

const    // default root directory in TreeView
  defaultDir = 'C:';
         // minimum width allowed for TreeView or ListView
  MINWIDTH = 100;

var
  Form1: TForm1;

implementation


{$R *.DFM}

function DiskInDrive(Drive: Char): Boolean;
{ Check to see if a disk is in the drive specified.
  This code is taken from Borland's TechInfo help file }
var
  ErrorMode: word;
begin
  { make it upper case }
  if Drive in ['a'..'z'] then Dec(Drive, $20);
  { make sure it's a letter }
  if not (Drive in ['A'..'Z']) then
    raise EConvertError.Create('Not a valid drive ID');
  { turn off critical errors }
  ErrorMode := SetErrorMode(SEM_FailCriticalErrors);
  try
    { drive 1 = a, 2 = b, 3 = c, etc. }
    if DiskSize(Ord(Drive) - $40) = -1 then
      Result := False
    else
      Result := True;
  finally
    { restore old error mode }
    SetErrorMode(ErrorMode);
  end;
end;


function GetFileInfo( fn : string ) : TSHFileInfo;
{ Return a TSHFileInfo with information on the file, fn.
  The precise type of information is controlled by the flags
  passed to the SHGetFileInfo function }
var
  FileInfo : TSHFileInfo;
begin
  FillChar(FileInfo, SizeOf(FileInfo), #0);
  SHGetFileInfo(PChar(fn),0, FileInfo, SizeOf(FileInfo), SHGFI_SYSICONINDEX or
                                                         SHGFI_TYPENAME or
                                                         SHGFI_ATTRIBUTES );
  result := FileInfo;
end;



procedure TForm1.updateListView;
{ Displays file names from current directory in the ListView.
  This procedure uses data supplied by a TSearchRec and a TSHFileInfo
  structure to retrive and display file information such as the
  file date, size, type and attributes. }
var
   NewItem : TListItem;
   Result : integer;
   SearchRec: TSearchRec;
   TypeName : string;     { file type: e.g 'Text document' or 'Delphi Project'}
   FileInfo : TSHFileInfo;
   ByteSize : integer;    { file size   }
   AttStr   : string;     { string representation of file attributes }
   Attributes : integer;  { integer representation of file attributes }
begin
    ListView1.Items.BeginUpdate; // turn off update for speed
    ListView1.Items.Clear;
    ListView1.Items.EndUpdate;   // turn it on again
    Result := FindFirst(currDirName+'*.*', faAnyFile, SearchRec);
    while Result = 0 do
    begin // filter any unwanted files from display
      if not excludeFromListView( SearchRec ) then
      begin
         // first retrieve file information
        FileInfo :=  GetFileInfo(currDirName + Searchrec.Name );
        TypeName := FileInfo.szTypeName;
        AttStr:='';
        Attributes := SearchRec.Attr;
        if (Attributes and faReadOnly > 0) then AttStr := AttStr + 'R';
        if (Attributes and faHidden  > 0) then AttStr := AttStr + 'H';
        if (Attributes and faSysFile > 0) then AttStr := AttStr + 'S';
        if (Attributes and faArchive > 0) then AttStr := AttStr + 'A';
(* // Note: we could retrieve a set of attributes from FileInfo.
       However, these attributes are both more numerous and different
       from standard file attributes (e.g. they don't include an Archive flag but
       they do have Removable-media ghosted icon flags). I don't feel that
       most of these are not appropriate in this application. You can
       find a list of all these constants in Delphi's SHLOBJ.PAS unit.
       This is an example of how you would use FileInfo attributes:
          Attributes := FileInfo.dwAttributes;
         if (Attributes and SFGAO_READONLY >0) then AttStr := AttStr + 'R';
*)

        ByteSize := SearchRec.Size div 1024;
        if ByteSize = 0 then ByteSize := 1;
        // then create a new item in the ListView
        NewItem := ListView1.Items.Add;      // add a file name in lowercase
        NewItem.Caption := LowerCase(SearchRec.Name);
        NewItem.ImageIndex := FileInfo.iIcon; // add an appropriate icon
        // then add subitems in the ListView columns to display file info
        NewItem.SubItems.Add(IntToStr(ByteSize)+'KB');
        NewItem.SubItems.Add(TypeName);
        NewItem.SubItems.Add(AttStr);
        NewItem.SubItems.Add(DateTimeToStr(FileDateToDateTime( SearchRec.Time )));
      end;
      Result := FindNext(SearchRec);
    end;
    FindClose(SearchRec);
end;

procedure TForm1.updatePanels;
{ display path and number of sub directories in the Statusbar panels }
var
  panel0text : string;
begin
  panel0text := currDirName;
  if TreeView1.Selected.Expanded then panel0text := panel0text +
        ' [ ' + IntToStr( TreeView1.Selected.Count ) + ' subdirectories ]';
  StatusBar1.Panels.Items[0].Text := panel0text;
end;

function TForm1.excludeFromListView( sr : TSearchRec ) : boolean;
{ Don't display these files in the file list }
begin
    if isDirectory( sr ) then
       excludeFromListView := true
    else if ((sr.Name = '.') or (sr.Name = '..')) then
     excludeFromListView := true
  else excludeFromListView := false;
end;

function TForm1.isDirectory( sr : TSearchRec ) : boolean;
{ test if current file is a directory }
begin
   isDirectory := ((sr.Attr and faDirectory > 0)
                  and
                  (sr.Name <> '.') and (sr.Name <> '..'));
end;

function TForm1.fullPath( Node : TTreeNode ) : string;
{ Return a string showing path - e.g. C:\GP\Parent\NodeDir\ }
var
  ANode, FirstNode : TTreeNode;
  path : string;
begin
  ANode := Node;
  path := ANode.Text + '\';
  FirstNode := TreeView1.Items.GetFirstNode;
  while ANode <> FirstNode do
  begin
     ANode := ANode.Parent;
     path := ANode.Text + '\' + path;
  end;
  fullPath := path;
end;

function TForm1.hasSubDirectories( d : string ) : boolean;
{ test in the directory indicated by the string 'd' contains
 subdirectories. If so, return true }
var
  SearchRec: TSearchRec;
  SResult : integer;
  noSubDirFound : boolean;
begin    // find first file, Result is 0 if successful
    noSubDirFound := true;
    SResult := FindFirst(d + '\*.*', faDirectory, SearchRec);
    while ((SResult = 0) and (noSubDirFound)) do
    begin
      if isDirectory(SearchRec) then noSubDirFound := false;
      SResult := FindNext(SearchRec);
    end;
    FindClose(SearchRec);
    hasSubDirectories := (noSubDirFound = false);
end;

procedure TForm1.addSubDirs( rootDir : string;  Node : TTreeNode );
{ add directory names as branches of the TreeView . If a directory contains
  any subdirectories, a '+' is placed alongside the directory name in
  the TreeView }
var
  SearchRec: TSearchRec;
  Result : integer;
  NewNode : TTreeNode;
begin    // find first file, Result is 0 if successful
    Result := FindFirst(rootDir + '*.*', faDirectory, SearchRec);
    while Result = 0 do
    begin
      if isDirectory(SearchRec) then
      begin  // if directory is found add it as a child of prev node in TreeView
         NewNode := TreeView1.Items.AddChild(Node, SearchRec.Name);
         NewNode.SelectedIndex := 1;
         if (hasSubDirectories( rootDir + SearchRec.Name ) ) then
            // making HasChildren true adds a '+' to the directory node
            // even if that node hasn't really got any child nodes
            NewNode.HasChildren := true;
      end; // then continue searching }
      Result := FindNext(SearchRec);
    end;
    FindClose(SearchRec);
    Node.AlphaSort;
end;

procedure TForm1.TreeView1Expanding(Sender: TObject; Node: TTreeNode;
  var AllowExpansion: Boolean);
begin
    if Node.GetFirstChild = nil then
       addSubDirs(fullPath(Node) , Node );
  Node.Selected := true; { if expanding the node, select it }
end;

procedure TForm1.FormCreate(Sender: TObject);
var
  ImageListHandle : THandle;
  FileInfo : TSHFileInfo;

begin
  // Get system ImageList so that we can retrieve small icons for each file type
  ImageListHandle := SHGetFileInfo('',
                           0,
                           FileInfo,
                           SizeOf(FileInfo),
                           SHGFI_SYSICONINDEX or SHGFI_SMALLICON);
  SendMessage(ListView1.Handle, LVM_SETIMAGELIST, LVSIL_SMALL, ImageListHandle);
  //!! The next line causes an OnChange event which will fire up
  //!! DriveComboBox1Change which, in turn, populates the TreeView and ListView
  DriveComboBox1.ItemIndex := 1; // C:\ drive
  // Set Form1 variables to default values
  currFileName := '';
  currDirName := DefaultDir;
  ItemEdited := false;
end;

procedure TForm1.TreeView1Click(Sender: TObject);
begin
 // if the same directory node was clicked, do nothing
    if fullpath(TreeView1.Selected) <> currDirName then
    begin
       currDirName := fullpath(TreeView1.Selected);
       updateListView;
       updatePanels;
    end;
end;

procedure TForm1.ListView1Click(Sender: TObject);
{ if a file is selected then update the currFileName variable }
begin
  if ListView1.Selected <> nil then
     currFileName := ListView1.Selected.Caption
  else
     currFileName := '';
  StatusBar1.Panels.Items[1].Text := currFileName;
end;

procedure TForm1.ListView1DblClick(Sender: TObject);
begin
  if ListView1.Selected <> nil then // Check that a file name is Selected
     ExecuteFile(ListView1.Selected.Caption, '',
                 fullPath(TreeView1.Selected), SW_SHOW);
end;

procedure TForm1.SplitterPanelMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
const
  SC_DragMove = $F012; { a magic number }
var
  BottomMargin : integer;
begin
  ListView1.align := alNone; // turn off align during movement
  SplitterPanel.align := alNone;
                       // resize panel so that the top and bottom edges
                       // don't appear if the mouse is moved vertically
  BottomMargin := Form1.ClientHeight - Y;
  SplitterPanel.Top := -BottomMargin;
  SplitterPanel.Height := Form1.ClientHeight * 2;
  Form1.Update;        // update to ensure Memo contents are repainted
  ReleaseCapture;
                       // --- Move the splitter panel ---
  SplitterPanel.perform(WM_SysCommand, SC_DragMove, 0);
                       // make sure Memos aren't resized beneath a minimum width
  if SplitterPanel.Left <= MINWIDTH then
     SplitterPanel.Left := MINWIDTH
  else if (Form1.ClientWidth - (SplitterPanel.Left + SplitterPanel.Width)) <= MINWIDTH then
     SplitterPanel.Left := Form1.ClientWidth - (SplitterPanel.Width+MINWIDTH);
                       // restore default alignments
  TreeView1.Width := SplitterPanel.Left;
  SplitterPanel.align := alLeft;
  ListView1.align := alClient;

end;

procedure TForm1.FormResize(Sender: TObject);
{ Don't allow the user to resize the form below a sensible minimum size }
begin
   if Form1.Width < (MINWIDTH * 2) then
   begin
      Form1.Width := (MINWIDTH * 2);
      TreeView1.Width := MINWIDTH;

   end;
end;

procedure TForm1.DriveComboBox1Change(Sender: TObject);
{ When a new drive has been selected, populate the TreeView with
  the directories on that drive }
var
   Node : TTreeNode;
   currDir : string;
begin
  // When  DriveComboBox1 ItemIndex is set during Form creation,
  // Drive will = ''
  if DriveComboBox1.Drive = '' then
     currDir := defaultDir
  else
     currDir := DriveComboBox1.Drive + ':' ;

  if not DiskInDrive( currDir[1] ) then
     ShowMessage( 'No Disk in: ' + currDir )
  else
  begin
    TreeView1.Items.Clear;
    Node := TreeView1.Items.Add(TreeView1.Selected, currDir);

    Node.SelectedIndex := 1;
    Node.Selected := true;
    addSubDirs(currDir+'\', Node);
    TreeView1.AlphaSort;
              // Expand(false) means - don't recurse to expand all child items
              // Expand(true) would havethe effect of logging (and expanding)
              // all subdirectories beneath the root!
    TreeView1.Items[0].Expand(false);
    currDirName := fullPath(TreeView1.Selected);
    updateListView;
    updatePanels;
  end;

end;

procedure TForm1.DeleteClick(Sender: TObject);
{ Delete the file whose name is selected }
begin
  if ListView1.Selected <> nil then // Check that a file name is Selected
    if MessageDlg('Delete '+ListView1.Selected.Caption+'?', mtConfirmation,
                  [mbYes, mbNo],0) = mrYes then
                  if DeleteFile(CurrDirName+ListView1.Selected.Caption) then
                  updateListView
                  else ShowMessage( 'Cannot delete this file!');
end;

procedure TForm1.RenameClick(Sender: TObject);
begin
  if ListView1.Selected = nil then
     ShowMessage('There is no file name selected!' )
  else
     ListView1.Selected.EditCaption;
end;

procedure TForm1.ListView1Edited(Sender: TObject; Item: TListItem;
  var S: string);
begin
   ItemEdited := True; { set a flag to show that item caption has been edited }
end;

procedure TForm1.ListView1Change(Sender: TObject; Item: TListItem;
  Change: TItemChange);
{ if an item's caption has just been edited (ItemEdited = true) try
  to rename the file. If the Rename operation fails, restore the
  previous caption (curreFileName) and display an error message }
var
   newname : string;
   badname : boolean;  // true if a bad or blank file name is entered
begin
  badname := false;
  if ItemEdited = true then
  begin
    ItemEdited := false;
    if ListView1.Selected = nil then
      ShowMessage ('Nothing is selected' )
    else
    begin  // if ListView1.Selected <> nil
      newname := Item.Caption;
      if newname = '' then
         badname := true
      else
      if RenameFile(currDirName+currFileName, currDirName+newname) then
        currFileName := newname
      else
         badname := true;
      // If File Renaming failed, restore old name
      if badname then
      begin
        ListView1.ItemFocused.Caption := currFileName;
        ShowMessage('Cannot rename ' + currDirName+currFileName +
                   ' to ' + currDirName+newname );
      end; // end if RenameFile fails
    end;  // end if ListView1.Selected <> nil
  end; // end if ItemEdited = true
end;

end.