Delphi 2 - Developers' Solutions/Delphi 2 Developers' Solutions.iso/dds/chap02/howto06/drwsutl2.pas

Pascal/Delphi Source File | 1996-03-05 | 71.7 KB | 1,903 lines

unit Drwsutl2;

interface

uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, Dialogs, StdCtrls, Buttons, ExtCtrls, ShellAPI, FileCtrl, DRWSUtl1;

const
  EOC_CHANGEDIR = 1;  { Error Operation Code for change directory failure }
  EOC_SOURCECOPY = 2; { Error Operation Code for source copy failure      }
  EOC_DESTCOPY = 3;   { Error Operation Code for destination copy failure }
  EOC_DELETEFILE = 4; { Error Operation Code for file delete failure      }
  EOC_DELETEDIR = 5;  { Error Operation Code for directory delete failure }
  EOC_RENAMEFILE = 6; { Error Operation Code for renaming failure         }
  EOC_MAKEDIR = 7;    { Error Operation Code for MkDir failure            }
  EOC_SETATTR = 8;    { Error Operation Code for Set Attributes failure   }

  FAC_COPY = 1;       { File Action Code for recursive copying            }
  FAC_MOVE = 2;       { File Action Code for recursive moving             }
  FAC_DELETE = 3;     { File Action Code for recursive deletion           }
type
  { This is a descendant of TFileListbox }
  { Which puts icons of files into the   }
  { Objects array rather than the stand- }
  { ard bitmaps.                         }
  TIconFileListBox = class( TFileListBox )
  public
    { public methods and data }
    function GetNextSelection( SourceDirectory : String;
              var CurrentItem : Integer ) : String;
  end;
  TFileWorkBench = class( TComponent )
  public
    GlobalError        : Integer;  { This is used by FMXUCopyFile for er code }
    GlobalErrorType    : Integer;  { This holds the Operation code            }
    function ForceTrailingBackSlash( const TheFileName : String ) : String;
    function StripNonRootTrailingBackSlash(
              const TheFileName : String ) : String;
    procedure GetFileAttributes( TheFile : String; var IsDirectory , IsArchive ,
                IsVolumeID , IsHidden , IsReadOnly , IsSysFile : Boolean );
    procedure HandleIOException( TheOpCode : Integer; ThePath : String;
                                 TheMessage : String; TheCode : Integer );
    procedure HandleDOSError( TheOpCode : Integer; ThePath : String;
                TheCode : Integer );
    procedure FMXUCopyFile(const FileName, DestName: String);
    function CopyFile( TargetPath ,
               DestinationPath : String ) : Boolean;
    procedure ChangeTheDirectory( NewPath : String );
    procedure ChangeTheDriveAndDirectory( NewDrive : Integer );
    procedure CopyTheFile( OldPath , NewPath : String );
    procedure MoveTheFile( OldPath , NewPath : String );
    procedure DeleteTheFile( ThePath : String );
    procedure RenameTheFile( OldPath , NewName : String );
    procedure CreateNewDirectory( NewPath : String );
    procedure RemoveDirectory( ThePath : String );
    procedure RecursivelyCopyDirectory( OldPath , NewPath : String );
    procedure RecursivelyMoveDirectory( OldPath , NewPath : String );
    procedure RecursivelyDeleteDirectory( ThePath : String );
    procedure HandleRecursiveAction( StartingPath , NewPath : String;
               ActionCode : Integer );
  end;
  TFileIconPanel = class( TPanel )
  private
    { Private declarations }
    FHighlightColor : TColor;                 { This holds bright edge bevel }
    FShadowColor    : TColor;                 { This holds dark edge bevel   }
    procedure TheClick( Sender : TObject );   { This holds override click    }
    procedure TheDblClick( Sender : TObject );{ This holds override dblclick }
  protected                                   { event method procedure.      }
    { Protected declarations }
    procedure Paint; override;                { This allows custom painting  }
  public
    { Public declarations }
    FTheIcon : TIcon;                         { This is the display icon    }
    FTheName : String;                        { This is the filename        }
    FTheLabel : TLabel;                       { This is the display label   }
    Selected : Boolean;                       { This holds selection status }
    constructor Create(AOwner : TComponent); override; { override create    }
    procedure Initialize( PanelX              ,             { Left          }
                          PanelY              ,             { Top           }
                          PanelWidth          ,             { Width         }
                          PanelHeight         ,             { Height        }
                          PanelBevelWidth     ,             { Bevel Width   }
                          LabelFontSize         : Integer;  { Font size     }
                          PanelColor          ,             { Main color    }
                          PanelHighlightColor ,             { Bright color  }
                          PanelShadowColor    ,             { Dark color    }
                          LabelTextColor        : TColor;   { Text color    }
                          TheFilename         ,             { Filename      }
                          LabelFontName         : String;   { Font name     }
                          LabelFontStyle        : TFontStyles;  { Font style}
                          ExtraData             : Integer       );  { Drive }
    destructor Destroy; override;             { override destroy to free    }
  end;
  TFileIconPanelScrollBox = class( TScrollBox )
  public
    { Public methods and data }
    TheFWB              : TFileWorkBench; { Used for file manipulation         }
    IconsNeedRefreshing : Boolean;                   { Flag to redo display    }
    TheIconSize        : Integer;   { Holds Individual Icon size               }
    TheIconSpacing     : Integer;   { Holds total icon footprint               }
    MaxIconsInARow     : Integer;   { Set for screen size.                     }
    TheStoredHandle    : HWnd;
    procedure Update;                                { Called to reset display }
    constructor Create( AOwner : TComponent ); override;  { Override inherited }
    procedure ClearTheFIPs;                          { Clears the FIPs safely  }
    procedure AddDriveIcons( var XCounter , YCounter : Integer ); { Add drives }
    procedure GetColorsForFileIcon( TheFile : String;
               var BC , HC , SC , TC : TColor );
    procedure GetIconsForEntireDirectory( TargetPath  : String );
    function GetNextSelection( SourceDirectory : String;
              var CurrentItem : Integer ) : String;
    procedure DisplayRecursiveSearchResults(
      TheStartingDirectory : String );
  end;

  { This procedure gets an icon for a file using FindExecutable  }
  { and ExtractIcon. (assumes file/dir is passed)                }
  procedure GetIconForFile( TheName : String; var TheIcon : TIcon );
  { This procedure spaces out the bitbtn components on a tpanel }
  procedure SpacePanelButtons( WhichPanel : TPanel );

implementation
{$R DRWSUTL2.RES}                 { Import custom resource file }

{ This procedure spaces out the bitbtn components on a tpanel }
procedure SpacePanelButtons( WhichPanel : TPanel );
var TheCalculatedSpacing     ,            { Holds primary spacing }
    TheFullCalculatedSpacing   : Integer; { Holds full spacing    }
    Counter_1                  : Integer; { Loop counter          }
    TotalIBs                   : Integer; { Gets total buttons    }
begin
  { Set up spacing values }
  TotalIBs := WhichPanel.ControlCount;
  TheCalculatedSpacing := (( WhichPanel.Width - 6 - ( TotalIbs * 49 ))
   div ( TotalIbs + 1 ));
  TheFullCalculatedSpacing := TheCalculatedSpacing + 49;
  { Loop through all imported buttons and set their Left values }
  for Counter_1 := 1 to WhichPanel.ControlCount do
  begin
    if Counter_1 = 1 then
    begin
      TBitBtn( WhichPanel.Controls[ Counter_1 - 1 ] ).Left := 3 +
       TheCalculatedSpacing;
    end
    else
    begin
      TBitBtn( WhichPanel.Controls[ Counter_1 - 1 ] ).Left := 3 +
       (( Counter_1 - 1 ) * TheFullCalculatedSpacing ) + TheCalculatedSpacing;
    end;
  end;
end;

{ This procedure gets an icon for a file using FindExecutable  }
{ and ExtractIcon. (assumes file/dir is passed)                }
procedure GetIconForFile( TheName : String; var TheIcon : TIcon );
var TheExt           : String; { File extension holder }
    TheOtherPChar  ,           { Windows ASCIIZ string }
    ThePChar         : PChar;  { Windows ASCIIZ string }
    Dummy : Word;
begin
  { Check for directory and if so get directory icon from RES file }
  if (( FileGetAttr( TheName ) and faDirectory ) = faDirectory ) then
  begin
    { Set up the PChar to communicate with Windows }
    GetMem( TheOtherPChar , 255 );
    { Convert Pascal-style string to ASCIIZ Pchar }
    StrPCopy( TheOtherPChar , 'DIRECTORY' );
    { Use API call to return icon handle of Icon Resource in FILECTRL.RES }
    TheIcon.Handle := LoadIcon( hInstance , TheOtherPChar );
    { Release memory from PChar }
    FreeMem( TheOtherPChar , 255 );
    { Leave }
    exit;
  end;
  { Assume archive file; get its extension }
  TheExt := Uppercase( ExtractFileExt( TheName ));
  { If not an executable/image file then use FindExecutable to get icon }
  if (( TheExt <> '.EXE' ) and ( TheExt <> '.BAT' ) and
      ( TheExt <> '.PIF' ) and ( TheExt <> '.COM' )) then
  begin
    { Grab three chunks of memory }
    GetMem( ThePChar , 255 );
    { Set up the name and its directory in Windows string formats }
    StrPCopy( ThePChar, TheName );
    Dummy := 65535;
    {**** Windows 95 Specialized call ****** }
    TheIcon.Handle := ExtractAssociatedIcon( hInstance , ThePChar , Dummy );
    if TheIcon.Handle = 0 then
    begin
      GetMem( TheOtherPChar , 255 );
      StrPCopy( TheOtherPChar , 'NOICON' );
      TheIcon.Handle := LoadIcon( hInstance , TheOtherPChar );
      FreeMem( TheOtherPChar , 255 );
      exit;
    end;
    FreeMem( ThePChar , 255 );
  end
  else
  { Assume Windows Executable file, so get icon from it with ExtractIcon API }
  begin
    GetMem( ThePChar , 255 );
    StrPCopy( ThePChar , TheName );
    { Try to get first icon for file }
    Dummy := 65535;
    TheIcon.Handle := ExtractAssociatedIcon( hInstance , ThePChar , Dummy );
    FreeMem( ThePChar , 255 );
    { If handle is 0 invalid icon format so use default from RES file }
    if TheIcon.Handle = 0 then
    begin
      GetMem( TheOtherPChar , 255 );
      StrPCopy( TheOtherPChar , 'NOICON' );
      TheIcon.Handle := LoadIcon( hInstance , TheOtherPChar );
      FreeMem( TheOtherPChar , 255 );
      exit;
    end;
  end;
end;

{ This procedure does a fully error-trapped change directory }
procedure TFileWorkBench.ChangeTheDirectory( NewPath : String );
var CurrentDirectory : String;
begin
  if NewPath = '..' then
  begin { Back up one level }
    {$I+}
    try
      { Find the current directory }
      GetDir( 0 , CurrentDirectory );
      { Use EFP to move up one level }
      CurrentDirectory := ExtractFilePath( CurrentDirectory );
      { Strip trailing \ if not root }
      CurrentDirectory := StripNonRootTrailingBackSlash( CurrentDirectory );
      { Try the change to the new drive }
      ChDir( CurrentDirectory );
    except
      { if any exception occurs instantiate exception and show }
      On E:EInOutError do
      begin
        { Call custom error display/lookup procedure }
        HandleIOException( EOC_CHANGEDIR , CurrentDirectory ,
         E.Message , E.ErrorCode );
      end;
    end;
  end
  else
  begin { Change to explicit path }
    {$I+}
    try
      { Get target directory path }
      CurrentDirectory := NewPath;
      { Strip trailing \ if not root }
      CurrentDirectory := StripNonRootTrailingBackSlash( CurrentDirectory );
      { Try the change to the new drive }
      ChDir( CurrentDirectory );
    except
      { if any exception occurs instantiate exception and show }
      On E:EInOutError do
      begin
        { Call custom error display/lookup procedure }
        HandleIOException( EOC_CHANGEDIR , CurrentDirectory ,
         E.Message , E.ErrorCode );
      end;
    end;
  end;
end;

{ This procedure does a fully error-trapped change directory }
procedure TFileWorkBench.ChangeTheDriveAndDirectory( NewDrive : Integer );
var CurrentDirectory : String;
begin
  {$I+}
  try
    { Find the working directory on new drive }
    GetDir( NewDrive , CurrentDirectory );
    { Try the change to the new drive }
    ChDir( CurrentDirectory );
  except
    { if any exception occurs instantiate exception and show }
    On E:EInOutError do
    begin
      { Call custom error display/lookup procedure }
      HandleIOException( EOC_CHANGEDIR , CurrentDirectory ,
       E.Message , E.ErrorCode );
    end;
  end;
end;

{ This procedure copies a single file with error trapping }
procedure TFileWorkBench.CopyTheFile( OldPath , NewPath : String );
var AResult : Boolean; { Internal data flag }
begin
  { If Copyfile returns false an error occurred }
  AResult := CopyFile( OldPath , NewPath +
   ExtractFileName( OldPath ));
  { Display meaningful error message }
  if not AResult then HandleDOSError( GlobalErrorType ,
   ExtractFileName( OldPath ) , GlobalError );
end;

{ This procedure moves a file by copying and delete it }
procedure TFileWorkBench.MoveTheFile( OldPath , NewPath : String );
var AResult : Boolean; { Internal data flag }
    TheFile : File;    { Use to get errors  }
begin
  { If Copyfile returns false an error occurred }
  AResult := CopyFile( OldPath , NewPath +
    ExtractFileName( OldPath ));
  { Display meaningful error message }
  if not AResult then HandleDOSError( GlobalErrorType ,
   ExtractFileName( OldPath ), GlobalError );
  { After valid copying, delete source file }
  {$I+}
  if AResult then try
    { Use this trick to get valid exception handling }
    AssignFile( TheFile , OldPath );
    { Use erase because Deletefile doesn't give exceptions! }
    Erase( TheFile );
  except
    { if any exception occurs instantiate exception and show }
    On E:EInOutError do
    begin
      { Call custom error display/lookup procedure }
      HandleIOException( EOC_DELETEFILE , ExtractFileName( OldPath ) ,
       E.Message , E.ErrorCode );
    end;
  end;
end;

{ This procedure safely deletes a single file }
procedure TFileWorkBench.DeleteTheFile( ThePath : String );
var TheFile : File; { Internal file handle }
begin
  {$I+}
  try
    { Use this trick to get valid exception handling }
    AssignFile( TheFile , ThePath );
    { Use erase because Deletefile doesn't give exceptions! }
    Erase( TheFile );
  except
    { if any exception occurs instantiate exception and show }
    On E:EInOutError do
    begin
      { Call custom error display/lookup procedure }
      HandleIOException( EOC_DELETEFILE , ExtractFileName( ThePath ) ,
       E.Message , E.ErrorCode );
    end;
  end;
end;

{ This procedure renames a file with full error trapping }
procedure TFileWorkBench.RenameTheFile( OldPath , NewName : String );
var TheFile : File; { Internal file handle }
begin
  {$I+}
  try
    { Use this trick to get valid exception handling }
    AssignFile( TheFile , OldPath );
    { Use this because RenameFile doesn't give exceptions! }
    Rename( TheFile , NewName );
  except
    { if any exception occurs instantiate exception and show }
    On E:EInOutError do
    begin
      { Call custom error display/lookup procedure }
      HandleIOException( EOC_RENAMEFILE , ExtractFileName( OldPath ) ,
       E.Message , E.ErrorCode );
    end;
  end;
end;

{ This procedure creates a new directory with full error trapping }
procedure TFileWorkBench.CreateNewDirectory( NewPath : String );
begin
  {$I+}
  try
    Mkdir( NewPath );
  except
    { if any exception occurs instantiate exception and show }
    On E:EInOutError do
    begin
      { Call custom error display/lookup procedure }
      HandleIOException( EOC_MAKEDIR , ExtractFileName( NewPath ) ,
       E.Message , E.ErrorCode );
    end;
  end;
end;

{ This procedure remove a directory with full error trapping }
procedure TFileWorkBench.RemoveDirectory( ThePath : String );
begin
  {$I+}
  try
    Rmdir( ThePath );
  except
    { if any exception occurs instantiate exception and show }
    On E:EInOutError do
    begin
      { Call custom error display/lookup procedure }
      HandleIOException( EOC_DELETEDIR , ExtractFileName( ThePath ) ,
       E.Message , E.ErrorCode );
    end;
  end;
end;

{ This procedure recursively copies a directory to a new path }
procedure TFileWorkBench.RecursivelyCopyDirectory( OldPath , NewPath : String );
var TheDir : String; { Holds source directory }
begin
  { Get the source directory to copy }
  TheDir := ExtractFileName( OldPath );
  { Force a backslash to the newpath variable }
  NewPath := ForceTrailingBackSlash( NewPath );
  { Add the source directory to the target path }
  NewPath := NewPath + TheDir;
  { Create a new directory with the new name }
  CreateNewDirectory( NewPath );
  { Force a backslash for compatibility }
  NewPath := FOrcetrailingBackSlash( NewPath );
  { Do the recursive call }
  HandleRecursiveAction( OldPath , NewPath , FAC_COPY );
end;

{ This procedure recursively moves a directory tree }
procedure TFileWorkBench.RecursivelyMoveDirectory( OldPath , NewPath : String );
var TheDir    : String; { Holds source directory  }
    SavedPath : String; { Holds saved dir to kill }
begin
  { Get the source directory to move }
  TheDir := ExtractFileName( OldPath );
  { Force a backslash to the newpath variable }
  NewPath := ForceTrailingBackSlash( NewPath );
  { Save the starting path just in case }
  SavedPath := OldPath;
  { Add the source directory to the target path }
  NewPath := NewPath + TheDir;
  { Create a new directory with the new name }
  CreateNewDirectory( NewPath );
  { Force a backslash for compatibility }
  NewPath := FOrcetrailingBackSlash( NewPath );
  { Do the recursive call }
  HandleRecursiveAction( OldPath , NewPath , FAC_MOVE );
  { Remove the source directory }
  RemoveDirectory( SavedPath );
end;

{ This procedure handles recursively deleting an entire directory tree }
procedure TFileWorkBench.RecursivelyDeleteDirectory( ThePath : String );
begin
  HandleRecursiveAction( ThePath , '' , FAC_DELETE );
end;


{ This is the generic routine to copy, move, and delete whole directory trees }
procedure TFileWorkBench.HandleRecursiveAction( StartingPath , NewPath : String;
           ActionCode : Integer );
{ VITAL!!! These variables MUST be local for recursrion to work! }
var
    Finished        : Boolean;         { Loop flag              }
    TheSR           : TSearchRec;      { Searchrecord for FF/FN }
    TheResult       : Integer;         { return variable        }
    TargetPath ,
    FileMask   ,
    TheWorkingDirectory ,
    TheStoredWorkingDirectory ,
    ModifiedDirectory  : String;       { path for FF/FN         }
    TheFIP          : TFileIconPanel;  { generic FIP holder     }
    ButtonColor   ,                    { main panel color       }
    ButtonHLColor ,                    { bright panel color     }
    ButtonSColor  ,                    { dark panel color       }
    Textcolor       : TColor;          { label text color       }
    TheFile         : File;

begin
  { Set up the initial variables }
  Finished := false;
  TheWorkingDirectory := StartingPath;
  TheStoredWorkingDirectory := TheWorkingDirectory;
  TheWorkingDirectory := TheWorkingDirectory + '\*.*';
  TargetPath := ExtractFilePath( TheWorkingDirectory );
  { Make the call to FindFirst set to get any file }
  TheResult := FindFirst( TheWorkingDirectory , faAnyFile , TheSR );
  { loop through all files in the directory and delete them }
  while not Finished do
  begin
    { Make call to FindNext, using only SearchRecord from FindFirst }
    TheResult := FindNext( TheSR );
    { A -1 result means no more files so exit }
    if TheResult <> 0 then finished := true else
    begin
      if (( FileGetAttr( TargetPath + TheSR.Name ) and faDirectory )
       <> faDirectory ) then
      begin { A File }
        case ActionCode of
          FAC_COPY :
              begin
                CopyTheFile( TargetPath + TheSR.Name , NewPath );
              end;
          FAC_MOVE :
              begin
                MoveTheFile( TargetPath + TheSR.Name , NewPath );
              end;
          FAC_DELETE :
              begin { Delete }
                if MessageDlg( 'Delete file ' + TargetPath + TheSR.Name + '?',
                   mtConfirmation , mbYesNoCancel , 0 ) = mrYes then
                    DeleteTheFile( TargetPath + TheSR.Name );
              end;
        end;
      end;
    end;
  end;
  { Set up the variables to do recursive calls on all directories}
  Finished := false;
  ModifiedDirectory := TheStoredWorkingdirectory + '\*.*';
  { Make the call to FindFirst set to get any file, ignore result }
  TheResult := FindFirst( ModifiedDirectory , faDirectory , TheSR );
  while not Finished do
  begin
    { Make call to FindNext, using only SearchRecord from FindFirst }
    TheResult := FindNext( TheSR );
    { A -1 result means no more files so exit }
    if TheResult <> 0 then
      finished := true
    else
    begin
      if TheSR.Name <> '..' then { Ignore backup in this case }
      begin
        if (( FileGetAttr( TargetPath + TheSR.Name ) and faDirectory )
         = faDirectory ) then
        begin
          { Send in the new directory name }
          ModifiedDirectory := TheStoredWorkingDirectory  + '\' +
           TheSR.Name;
          { Reproduce directory structure for recursion in copy/move }
          NewPath := NewPath + TheSR.Name;
          case ActionCode of
            FAC_COPY , FAC_MOVE :
               begin { Create ahead for move and copy }
                 { Make the new directory for moving and copying }
                 CreateNewDirectory( NewPath );
                 { Force a backslash for compatibility }
                 NewPath := ForceTrailingBackSlash( NewPath );
               end;
            FAC_DELETE :
               begin  { No prior action needed for Delete }
               end;
          end;
          { Do the recursive call }
          HandleRecursiveAction( ModifiedDirectory , NewPath , ActionCode );
          case ActionCode of
            FAC_COPY :
               begin { no action for copy }
               end;
            FAC_MOVE , FAC_DELETE :
               begin  { Delete }
                 { Get a confirmation }
                 if MessageDlg( 'Remove Directory ' + TargetPath + TheSR.Name
                  + '?', mtConfirmation , mbYesNoCancel , 0 ) = mrYes then
                   RemoveDirectory( TargetPath + TheSR.Name );
               end;
          end;
        end;
      end;
    end;
  end;
end;

{ This is a generic copy routine taken from Delphi sample code }
{ It has been edited to return viable error codes!             }
procedure TFileWorkBench.FMXUCopyFile(const FileName, DestName: String);
var
  CopyBuffer: Pointer; { buffer for copying }
  BytesCopied: Longint;
  TheAttr : Integer;
  Source, Dest: Integer; { handles }
const
  ChunkSize: Longint = 8192; { copy in 8K chunks }
begin
  GetMem(CopyBuffer, ChunkSize); { allocate the buffer }
  Source := FileOpen(FileName, fmShareDenyWrite); { open source file }
  if Source < 0 then
  begin  { error creating source file }
    GlobalErrorType := EOC_SOURCECOPY;
    GlobalError := -IOResult;
    if GlobalError = 0 then GlobalError := -157;
    FreeMem( CopyBuffer, ChunkSize );
    exit;
  end;
  Dest := FileCreate(DestName); { create output file; overwrite existing }
  if Dest < 0 then
  begin  { error creating destination file }
    FileClose( Source );
    GlobalErrorType := EOC_DESTCOPY;
    GlobalError := -IOResult;
    if GlobalError = 0 then GlobalError := -159;
    FreeMem( CopyBuffer , ChunkSize );
    exit;
  end;
  {$I-}
  repeat
    BytesCopied := FileRead(Source, CopyBuffer^, ChunkSize); { read chunk}
    if BytesCopied > 0 then { if we read anything... }
    FileWrite(Dest, CopyBuffer^, BytesCopied); { ...write chunk }
  until BytesCopied < ChunkSize; { until we run out of chunks }
  {$I+}
  GlobalError := -IOResult;  { get any error code which happens during copying }
  FileClose(Dest); { close the destination file }
  FileClose(Source); { close the source file }
  FreeMem(CopyBuffer, ChunkSize); { free the buffer }
end;

{ This function calls the sample Copy code and handles errors }
function TFileWorkBench.CopyFile( TargetPath ,
          DestinationPath : String ) : Boolean;
begin
  { Set global error value to no error }
  GlobalError := 0;
  { Call the sample procedure to do the copy }
  FMXUCopyFile( TargetPath, DestinationPath );
  { If no error return true else return false }
  if GlobalError < 0 then CopyFile := false else
   CopyFile := true;
end;

{ This procedure handles displaying a user-friendly Dialog box with a }
{ Message for Delphi IO exception errors.                             }
procedure TFileWorkBench.HandleIOException( TheOpCode : Integer;
           ThePath : String; TheMessage : String; TheCode : Integer );
var ErrorMessageString : String;  { Holds internal data }
    OperationString    : String;  { Holds internal data }
begin
  { clear to check for unrecognized code }
  ErrorMessageString := '';
  { Check against imported code }
  case TheCode of
    2    : ErrorMessageString := 'File not found';
    3    : ErrorMessageString := 'Path not found';
    4    : ErrorMessageString := 'Too many open files';
    5    : ErrorMessageString := 'File access denied';
    6    : ErrorMessageString := 'Invalid file handle';
    12    : ErrorMessageString := 'Invalid file access code';
    15    : ErrorMessageString := 'Invalid drive number';
    16  : ErrorMessageString := 'Cannot remove current directory';
    17    : ErrorMessageString := 'Cannot rename across drives';
    100    : ErrorMessageString := 'Disk read error';
    101    : ErrorMessageString := 'Disk write error';
    102    : ErrorMessageString := 'File not assigned';
    103    : ErrorMessageString := 'File not open';
    104    : ErrorMessageString := 'File not open for input';
    105    : ErrorMessageString := 'File not open for output';
  end;
  case TheOpCode of
    EOC_CHANGEDIR : OperationString := 'Unable to Change Directory due to ';
    EOC_SOURCECOPY : OperationString := 'Unable to Copy due to Source File ';
    EOC_DESTCOPY : OperationString := 'Unable to Copy due to Destination File ';
    EOC_DELETEFILE : OperationString := 'Unable to Delete File due to ';
    EOC_DELETEDIR : OperationString := 'Unable to Delete Directory due to ';
    EOC_RENAMEFILE : OperationString := 'Unable to Rename File due to ';
    EOC_MAKEDIR : OperationString := 'Unable to Create New Directory due to ';
    EOC_SETATTR : OperationString := 'Unable to Set File Attributes due to ';
  end;
  { If not recognized use message; not a DOS error; reset cursor for neatness }
  if ErrorMessageString = '' then
  begin
    Screen.Cursor := crDefault;
    MessageDlg( OperationString + ExtractFileName( ThePath ) + ' ' +
     TheMessage , mtError , [mbOK],0);
  end
  else
  begin
    { Recognized DOS exception, reset cursor for neatness }
    Screen.Cursor := crDefault;
    MessageDlg( OperationString + ExtractFileName( ThePath ) + ' ' +
     ErrorMessageString , mtError , [mbOK], 0 );
  end;
end;

{ This procedure handles displaying a user-friendly Dialog box with a }
{ Message for DOS error codes.                                        }
procedure TFileWorkBench.HandleDOSError( TheOpCode : Integer;
           ThePath : String;  TheCode : Integer );
var ErrorMessageString : String;  { internal message holder }
    OperationString : String;     { internal message holder }
begin
  { clear the message holder to check for unrecognized code }
  ErrorMessageString := '';
  { Negate the code back to normal number and check to set string }
  case -TheCode of
    2    : ErrorMessageString := 'File not found';
    3    : ErrorMessageString := 'Path not found';
    4    : ErrorMessageString := 'Too many open files';
    5    : ErrorMessageString := 'File access denied';
    6    : ErrorMessageString := 'Invalid file handle';
    12    : ErrorMessageString := 'Invalid file access code';
    15    : ErrorMessageString := 'Invalid drive number';
    16  : ErrorMessageString := 'Cannot remove current directory';
    17    : ErrorMessageString := 'Cannot rename across drives';
    100    : ErrorMessageString := 'Disk read error';
    101    : ErrorMessageString := 'Disk write error';
    102    : ErrorMessageString := 'File not assigned';
    103    : ErrorMessageString := 'File not open';
    104    : ErrorMessageString := 'File not open for input';
    105    : ErrorMessageString := 'File not open for output';
    157 : ErrormessageString := 'Could not open Source File';
    159 : ErrormessageString := 'Could not open Target File';
  end;
  case TheOpCode of
    EOC_CHANGEDIR : OperationString := 'Unable to Change Directory due to ';
    EOC_SOURCECOPY : OperationString := 'Unable to Copy due to Source File ';
    EOC_DESTCOPY : OperationString := 'Unable to Copy due to Destination File ';
    EOC_DELETEFILE : OperationString := 'Unable to Delete File due to ';
    EOC_DELETEDIR : OperationString := 'Unable to Delete Directory due to ';
    EOC_RENAMEFILE : OperationString := 'Unable to Rename File due to ';
    EOC_MAKEDIR : OperationString := 'Unable to Create New Directory due to ';
    EOC_SETATTR : OperationString := 'Unable to Set File Attributes due to ';
  end;
  { If the string is empty an unrecognized code was sent in }
  if ErrorMessageString = '' then
  begin
    { Sent up db based on source or target error; reset cursor for neatness }
    Screen.Cursor := crDefault;
    MessageDlg( OperationString + ExtractFileName( ThePath ) + ' Error Code: ' +
     IntToStr( TheCode ) , mtError , [mbOK],0);
  end
  else  { Code is recognized, use message from case statement }
  begin
    { Format the output for source or target error }
    Screen.Cursor := crDefault;
    MessageDlg( OperationString + ExtractFilePath( ThePath ) + ' ' +
     ErrorMessageString , mtError , [mbOK], 0 );
  end;
end;

{ This procedure sets the imported booleans to the file's attributes }
procedure TFileWorkBench.GetFileAttributes( TheFile : String; var IsDirectory ,
           IsArchive , IsVolumeID , IsHidden , IsReadOnly ,
            IsSysFile : Boolean );
var TheResult : Integer; { Traps for error code on VolumeID }
begin
  { Clear the imported flags for default }
  IsDirectory := false;
  IsArchive := false;
  IsVolumeID := false;
  IsHidden := False;
  IsReadOnly := false;
  IsSysFile := false;
  { Make the Dos call }
  TheResult := FileGetAttr( TheFile );
  if TheResult < 0 then
  begin
    { Volume ID returns -2 (?) }
    IsVolumeID := true;
    { It has no other properties }
    exit;
  end;
  { Use AND test to set all other properties }
  if (( TheResult and faDirectory ) = faDirectory ) then IsDirectory := true;
  if (( TheResult and faArchive ) = faArchive ) then IsArchive := true;
  if (( TheResult and faVolumeID ) = faVolumeID ) then IsVolumeID := true;
  if (( TheResult and faReadOnly ) = faReadOnly ) then IsReadOnly := true;
  if (( TheResult and faHidden ) = faHidden ) then IsHidden := true;
  if (( TheResult and faSysFile ) = faSysFile ) then IsSysFile := true;
end;

{ This function makes sure a pathname has a trailing \ }
function TFileWorkBench.ForceTrailingBackSlash(
          const TheFileName : String ) : String;
var TempString : String;  { Used to hold function result }
begin
  { If no trailing \ add one (root will already have one.) }
  if TheFileName[ Length( TheFileName ) ] <> '\' then
   TempString := TheFileName + '\' else TempString := TheFileName;
  { Return modified or non-modified string }
  ForceTrailingBackslash := TempString;
end;

{ This function makes sure a non-root dir has no trailing \ }
function TFileWorkBench.StripNonRootTrailingBackSlash(
          const TheFileName : String ) : String;
var TempString : String ; { Used to hold function result }
begin
  { Default is no change }
  TempString := TheFileName;
  { If not root then }
  if Length( TheFileName ) > 3 then
  begin
    { If has a trailing backslash remove it }
    if TheFileName[ Length( TheFileName )] = '\' then
    begin
      TempString := Copy( TheFileName , 1 ,
       Length( TheFileName ) - 1 );
    end;
  end;
  { Export the final result }
  StripNonRootTrailingBackSlash := TempString;
end;

{ This gets the next selected listbox item }
function TIconFileListBox.GetNextSelection( SourceDirectory : String;
          var CurrentItem : Integer ): String;
var TheResult : String;  { Internal storage }
    finished  : boolean; { Loop flag        }
begin
  { If out of items to check signal and exit }
  if CurrentItem > Items.Count then TheResult := '' else
  begin
    { Otherwise scan from current position till match or end }
    finished := false;
    while not finished do
    begin
      { Check against selected property }
      if Selected[ CurrentItem - 1 ] then
      begin
        { If selected then return it and abort loop }
        TheResult := SourceDirectory + Items[ CurrentItem - 1 ];
        finished := true;
        { Increment current position }
        CurrentItem := CurrentItem + 1;
     end
      else
      begin
        { Increment current position }
        CurrentItem := CurrentItem + 1;
        { Otherwise check for end of data and abort if out of entries }
        if CurrentItem > Items.Count then
        begin
          TheResult := '';
          finished := true;
        end;
      end;
    end;
  end;
  { Return stored result }
  GetNextSelection := TheResult;
end;

{ Create method for FIP                                }
constructor TFileIconPanel.Create( AOwner : TComponent );
begin
  { call inherited -- VITAL! }
  inherited Create( AOwner );
  { create icon and label components, making self owner/displayer }
  FTheIcon := TIcon.Create;
  FTheLabel := TLabel.Create( Self );
  FThelabel.Parent := Self;
  { Set own and labels mouse methods to stored methods }
  OnClick := TheClick;
  OnDblClick := TheDblClick;
  FTheLabel.OnClick := TheClick;
  FTheLabel.OnDblClick := TheDblClick;
  { Set alignment and autosize properties of the label }
  FTheLabel.Autosize := false;
  FTheLabel.Alignment := taCenter;
  { Set selected to false }
  Selected := false;
end;

{ Initialization method for FIP                                         }
procedure TFileIconPanel.Initialize( PanelX              ,
                                     PanelY              ,
                                     PanelWidth          ,
                                     PanelHeight         ,
                                     PanelBevelWidth     ,
                                     LabelFontSize         : Integer;
                                     PanelColor          ,
                                     PanelHighlightColor ,
                                     PanelShadowColor    ,
                                     LabelTextColor        : TColor;
                                     TheFilename         ,
                                     LabelFontName         : String;
                                     LabelFontStyle        : TFontStyles;
                                     ExtraData             : Integer );

var TheLabelHeight ,             { Holder for label pixel height }
    TheLabelWidth    : Integer;  { Holder for label pixel width  }
    TheOtherPChar    : PChar;    { Windows ASCIIZ string         }
begin
  { Set the basic properties based on imported parameters }
  Left := PanelX;
  Top := PanelY;
  Width := PanelWidth;
  Height := PanelHeight;
  Color := PanelColor;
  BevelWidth := PanelBevelWidth;
  FHighlightColor := PanelHighlightColor;
  FShadowColor := PanelShadowColor;
  FTheName := TheFilename;
  { If the ExtraData field is non-0 then a drive is being sent in }
  if ExtraData <> 0 then
  begin
    { Use the data field value to determine which icon to get from RES file }
    case ExtraData of
      1 : begin
            GetMem( TheOtherPChar , 255 );
            StrPCopy( TheOtherPChar , 'FLOPPY35' );
            FTheIcon.Handle := LoadIcon( hInstance , TheOtherPChar );
            FreeMem( TheOtherPChar , 255 );
          end;
      2 : begin
            GetMem( TheOtherPChar , 255 );
            StrPCopy( TheOtherPChar , 'FIXEDHD' );
            FTheIcon.Handle := LoadIcon( hInstance , TheOtherPChar );
            FreeMem( TheOtherPChar , 255 );
          end;
      3 : begin
            GetMem( TheOtherPChar , 255 );
            StrPCopy( TheOtherPChar , 'NETWORKHD' );
            FTheIcon.Handle := LoadIcon( hInstance , TheOtherPChar );
            FreeMem( TheOtherPChar , 255 );
          end;
      4 : begin
            GetMem( TheOtherPChar , 255 );
            StrPCopy( TheOtherPChar , 'CDROM' );
            FTheIcon.Handle := LoadIcon( hInstance , TheOtherPChar );
            FreeMem( TheOtherPChar , 255 );
          end;
      5 : begin
            GetMem( TheOtherPChar , 255 );
            StrPCopy( TheOtherPChar , 'RAM' );
            FTheIcon.Handle := LoadIcon( hInstance , TheOtherPChar );
            FreeMem( TheOtherPChar , 255 );
          end;
    end;
    { The FileNme property is already set up for the caption; use directly }
    FTheLabel.Caption := TheFilename;
    { Set up the hint for later use (make sure to set ShowHint) }
    Hint := 'Change to ' + TheFileName;
    ShowHint := true;
    { Set up all imported label properties and center it for drawing }
    with FTheLabel do
    begin
      Font.Name := LabelFontName;
      Font.Size := LabelFontSize;
      Font.Style := LabelFontStyle;
      Font.Color := LabelTextColor;
      Canvas.Brush.Color := PanelColor;
      Canvas.Font := Font;
      TheLabelHeight := Canvas.Textheight( Caption ) + 4;
      TheLabelWidth := Canvas.Textwidth( Caption ) + 4;
      Left := (( Self.Width - TheLabelWidth ) div 2 ) + 1;
      Top := ((( Round( Self.Height * 0.25 ) - 6 ) - TheLabelHeight) div 2) + 1;
      Top := Top + Round( Self.Height * 0.75 );
      Height := TheLabelHeight;
      Width := TheLabelWidth;
    end;
  end
  else
  begin
    { A file or directory has been sent in; use GetIconForFile to obtain an }
    { icon either from the file, its owner, or a RES file default.          }
    GetIconForFile( FTheName , FTheIcon );
    { Check for the Backup caption and set it specially }
    if ExtractfileName( FThename ) = '..' then
    begin
      FTheLabel.Caption := '..';
      Hint := 'Up One Level';
    end
    else
    begin
      { Otherwise just get the filename for the label caption }
      { And the full path for the hint (used later.)          }
      FTheLabel.caption := ExtractFileName( UpperCase( FTheName ));
      Hint := FTheName;
    end;
    { Activate showhint so hints are seen }
    ShowHint := true;
    { Set label properties with imported values and center for display }
    with FTheLabel do
    begin
      Font.Name := LabelFontName;
      Font.Size := LabelFontSize;
      Font.Style := LabelFontStyle;
      Font.Color := LabelTextColor;
      Canvas.Brush.Color := PanelColor;
      Canvas.Font := Font;
      TheLabelHeight := Canvas.Textheight( Caption ) + 4;
      TheLabelWidth := Canvas.Textwidth( Caption ) + 4;
      Left := (( Self.Width - TheLabelWidth ) div 2 ) + 1;
      Top := ((( Round( Self.Height * 0.25 ) - 6 ) - TheLabelHeight) div 2) + 1;
      Top := Top + Round( Self.Height * 0.75 );
      Height := TheLabelHeight;
      Width := TheLabelWidth;
    end;
  end;
end;

{ Destroy method for FIP }
destructor TFileIconPanel.Destroy;
begin
  { free component resources }
  FTheIcon.Free;
  FTheLabel.Free;
  { call inherited -- VITAL! }
  inherited Destroy;
end;

{ TheClick method for FIP; used for event responses }
procedure TFileIconPanel.TheClick( Sender : TObject );
begin
  { Currently ignore drive clicks }
  if Pos( 'DRIVE' , FTheName ) > 0 then exit;
  { Flip status of bevels }
  if BevelOuter = bvRaised then BevelOuter := bvLowered else
   BevelOuter := bvRaised;
  { Flip selected variable }
  Selected := not Selected;
  { Set redisplay }
  Invalidate;
end;

{ TheDblClick method for FIP; used for event responses }
procedure TFileIconPanel.TheDblClick( Sender : TObject );
var CurrentDirectory : String;    { Use to store dirs }
    TheDrive         : String;    { Get drive letter  }
    WhichDrive       : Integer;   { Get drive number  }
    ErrorCheck       : Integer;
    TheFWB           : TFileWorkBench;
begin
  { Create FileWorkBench for later use }
  TheFWB := TFileWorkBench.Create( Self );
  { Check for label or FIP sender }
  if Sender is TFileIconPanel then
  begin
    if FTheLabel.Caption = '..' then
    begin { deal with backup request }
      { Change to new directory }
      TheFWB.ChangeTheDirectory( '..' );
      { Call special method due to SendMessage problem! }
      TFileIconPanelScrollBox( Parent ).Update;
    end
    else
    begin
      { Check for DRIVE id in name }
      if Pos( 'DRIVE' , FTheName ) <> 0 then
      begin { Double Click on a Drive Icon }
        { Pull out the letter from name }
        TheDrive := Copy( FtheName , 7 , 1 );
        { Convert it to a number }
        WhichDrive := ( Ord( TheDrive[ 1 ] ) - Ord( 'A' )) + 1;
        TheFWB.ChangeTheDriveAndDirectory( WhichDrive );
        { Call special method due to SendMessage problem! }
        TFileIconPanelScrollBox( Parent ).Update;
      end
      else
      begin { Double click on a dir/file icon }
        if (( FileGetAttr( FTheName ) and faDirectory ) = faDirectory ) then
        begin { A directory, change to it }
          { Since full path in name, simply change to it! }
          TheFWB.ChangeTheDirectory( FTheName );
          { Call special method due to SendMessage problem! }
          TFileIconPanelScrollBox( Parent ).Update;
        end
        else
        begin { A file; attempt to shellexecute it }
          { Call shellexec as a wrapper around ShellExecute API call }
          { False indicates failure, signal error                    }
          if not ShellExec( FTheName , '' , '', false , SW_SHOWNORMAL , false )
           then MessageDlg('Could not Shell out to ' + FTheName , mtError,
            [mbOK], 0);
        end;
      end;
    end;
  end
  else
  begin
    with Sender as TLabel do
    begin
      if Caption = '..' then
      begin { Deal with backup request }
        { Change to new directory }
        TheFWB.ChangeTheDirectory( '..' );
        { Call special method due to SendMessage problem! }
        TFileIconPanelScrollBox( Parent ).Update;
      end
      else
      begin
        with Parent as TFileIconPanel do
        begin
          { Check for DRIVE id in name }
          if Pos( 'DRIVE' , FTheName ) <> 0 then
          begin { Double Click on a Drive Icon }
            { Pull out the letter from name }
            TheDrive := Copy( FtheName , 7 , 1 );
            { Convert it to a number }
            WhichDrive := ( Ord( TheDrive[ 1 ] ) - Ord( 'A' )) + 1;
            { Call the method to change to default dir on new drive }
            TheFWB.ChangeTheDriveAndDirectory( WhichDrive );
            { Call special method due to SendMessage problem! }
            TFileIconPanelScrollBox( Parent ).Update;
          end
          else
          begin { Double click on a dir/file icon }
            if (( FileGetAttr( FTheName ) and faDirectory ) = faDirectory ) then
            begin { A directory, change to it }
              { Since full path in name, simply change to it! }
              TheFWB.ChangeTheDirectory( FTheName );
              { Call special method due to SendMessage problem! }
              TFileIconPanelScrollBox( Parent ).Update;
            end
            else
            begin { A file; attempt to shellexecute it }
              { Call shellexec as a wrapper around ShellExecute API call }
              { False indicates failure, signal error                    }
              if not ShellExec( FTheName , '' , '', false , SW_SHOWNORMAL ,
               false ) then MessageDlg('Could not Shell out to ' + FTheName ,
                mtError, [mbOK], 0);
            end;
          end;
        end;
      end;
    end;
  end;
  TheFWB.Free; { This prevents resource leak }
end;

{ Paint method for FIP; overrides normal paint }
procedure TFileIconPanel.Paint;
var
  TheOtherRect   : TRect;   { Holds clientrect   }
  TopColor     ,            { Holds bright color }
  BottomColor    : TColor;  { Holds dark color   }

{ These methods are from Borland Intl., copyright 1995 }
procedure Frame3D(    Canvas       : TCanvas;
                  var TheRect      : TRect;
                      TopColor   ,
                      BottomColor  : TColor;
                      Width        : Integer );

procedure DoRect;
var
  TopRight, BottomLeft: TPoint;
begin
  with Canvas, TheRect do
  begin
    TopRight.X := Right;
    TopRight.Y := Top;
    BottomLeft.X := Left;
    BottomLeft.Y := Bottom;
    Pen.Color := TopColor;
    PolyLine([BottomLeft, TopLeft, TopRight]);
    Pen.Color := BottomColor;
    Dec(BottomLeft.X);
    PolyLine([TopRight, BottomRight, BottomLeft]);
  end;
end;

begin
  Canvas.Pen.Width := 1;
  Dec(TheRect.Bottom); Dec(TheRect.Right);
  while Width > 0 do
  begin
    Dec(Width);
    DoRect;
    InflateRect(TheRect, -1, -1);
  end;
  Inc(TheRect.Bottom); Inc(TheRect.Right);
end;

procedure AdjustColors(Bevel: TPanelBevel);
begin
  TopColor := FHighlightColor;
  if Bevel = bvLowered then TopColor := FShadowColor;
  BottomColor := FShadowColor;
  if Bevel = bvLowered then BottomColor := FHighlightColor;
end;

{ Custom code begins here }
begin
  { Get the rectangle of the control with API/method call }
  TheOtherRect := GetClientRect;
  { draw basic rectangle with basic color }
  with Canvas do
  begin
    Brush.Color := Color;
    FillRect(TheOtherRect);
  end;
  { Set up for top "icon" frame  and draw it with frame3d }
  TheOtherRect.Right := Width;
  TheOtherRect.Bottom := Round( Height * 0.75 ) - 6 ;
  if BevelOuter <> bvNone then
  begin
    AdjustColors(BevelOuter);
    Frame3D(Canvas, TheOtherRect, TopColor, BottomColor, BevelWidth);
  end;
  Frame3D(Canvas, TheOtherRect, Color, Color, BorderWidth);
  if BevelInner <> bvNone then
  begin
    AdjustColors(BevelInner);
    Frame3D(Canvas, TheOtherRect, TopColor, BottomColor, BevelWidth);
  end;
  { Do the same for the lower "label" frame }
  TheOtherRect.Top := Round( Height * 0.75 ) - 5;
  TheOtherRect.Left := 0;
  TheOtherRect.Bottom := Height;
  TheOtherRect.Right := Width;
  if BevelOuter <> bvNone then
  begin
    AdjustColors(BevelOuter);
    Frame3D(Canvas, TheOtherRect, TopColor, BottomColor, BevelWidth);
  end;
  Frame3D(Canvas, TheOtherRect, Color, Color, BorderWidth);
  if BevelInner <> bvNone then
  begin
    AdjustColors(BevelInner);
    Frame3D(Canvas, TheOtherRect, TopColor, BottomColor, BevelWidth);
  end;
  { Then draw the icon using canvas draw method }
  Canvas.Draw( (( Width - 32 ) div 2 ) + 1 ,
  ((( Round( Height * 0.75 ) - 6 ) - 32 ) div 2 ) + 1 , FTheIcon );
end;

{ This procedure clears a scrollbox of all FileIconPanels }
procedure TFileIconPanelScrollbox.ClearTheFIPs;
var Counter_1 : Integer;
    TheComponent : TComponent;
begin
  { Note that must use while loop since component count continually }
  { decreases as removes are made!                                  }
  while ComponentCount > 0 do
  begin
    { Save the component as a generic TComponent }
    TheComponent := Components[ 0 ];
    { Call removecomponent to pull it out of the owner list for sb }
    { This avoids GPF when freeing the sb.                         }
    RemoveComponent( Components[ 0 ]);
    { Typecast the pointer and free it to release memory and res. }
    TFileIconPanel( TheComponent ).Free;
  end;
end;

{ This procedure scans for drives and obtains their type and creates file }
{ icon panels to represent them.                                          }
procedure TFileIconPanelScrollBox.AddDriveIcons( var XCounter ,
           YCounter : Integer );
type
  { This if from filectrl unit; reproduce here for completeness }
  TDriveType = (dtUnknown, dtNoDrive, dtFloppy, dtFixed, dtNetwork, dtCDROM,
                dtRAM);
var
  DrivePC         : array[0..256] of char;
  DriveNum        : Integer;         { Used to get next drive via DOS fn   }
  IconType        : Integer;         { Used to hold icon type (defacto dt) }
  DriveChar       : Char;            { Used to hold drive letter           }
  DriveType       : TDriveType;      { Used for set-valued drive type      }
  Finished        : Boolean;         { Loop flag                           }
  TheFIP          : TFileIconPanel;  { Generic FileIconPanel variable      }
  ButtonColor   ,                    { Main panel color                    }
  ButtonHLColor ,                    { Bright panel color                  }
  ButtonSColor  ,                    { Dark panel color                    }
  Textcolor       : TColor;          { Label text color                    }

(*{ This code is from the FileCtrl Unit; copyright Borland Intl 1995      }
{ Check whether drive is a CD-ROM.  Returns True if MSCDEX is installed }
{  and the drive is using a CD driver                                   }

function IsCDROM(DriveNum: Integer): Boolean; assembler;
asm
  MOV   AX,1500h { look for MSCDEX }
  XOR   BX,BX
  INT   2fh
  OR    BX,BX
  JZ    @Finish
  MOV   AX,150Bh { check for using CD driver }
  MOV   CX,DriveNum
  INT   2fh
  OR    AX,AX
  @Finish:
end;

{ This code is from the FileCtrl Unit; copyright Borland Intl 1995      }
{ Check whether drive is a RAM drive.                                   }
function IsRAMDrive(DriveNum: Integer): Boolean; assembler;
var
  TempResult: Boolean;
asm
  MOV   TempResult,False
  PUSH  DS
  MOV   BX,SS
  MOV   DS,BX
  SUB   SP,0200h
  MOV   BX,SP
  MOV   AX,DriveNum
  MOV   CX,1
  XOR   DX,DX
  INT   25h  { read boot sector }
  ADD   SP,2
  JC    @ItsNot
  MOV   BX,SP
  CMP   BYTE PTR SS:[BX+15h],0F8h  { reverify fixed disk }
  JNE   @ItsNot
  CMP   BYTE PTR SS:[BX+10h],1  { check for single FAT }
  JNE   @ItsNot
  MOV   TempResult,True
  @ItsNot:
  ADD   SP,0200h
  POP   DS
  MOV   AL, TempResult
end;

{ This code is from the FileCtrl Unit; copyright Borland Intl 1995      }
{ Finds the type of a drive letter.                                     }
function FindDriveType(DriveNum: Integer): TDriveType;
begin
  Result := TDriveType(GetDriveType(DriveNum));
  if (Result = dtFixed) or (Result = dtNetwork) then
  begin
    if IsCDROM(DriveNum) then Result := dtCDROM
    else if (Result = dtFixed) then
    begin
        { do not check for RAMDrive under Windows NT }
      if ((GetWinFlags and $4000) = 0) and IsRAMDrive(DriveNum) then
        Result := dtRAM;
    end;
  end;
end;*)

begin
  { Set the button colors to an aquamarine color scheme for drives }
  ButtonColor := clTeal;
  ButtonHLColor := clAqua;
  ButtonSColor := clNavy;
  TextColor := clblack;
  { Set initial variables before looping for all drives }
  finished := false;
  DriveNum := 0;
  while not finished do
  begin
    { Start with no drive found }
    IconType := 0;
    (*=============REMOVED DUE TO WINDOWS 95=========
    { Call the Borland method to get the drive info }
    DriveType := FindDriveType(DriveNum);
    ===============END WINDOWS 95 REMOVAL==========*)
    { Set its letter and make it uppercase }
    DriveChar := Chr(DriveNum + ord('a'));
    DriveChar := Upcase(DriveChar);
    StrPCopy( DrivePC , DriveChar + ':\' );
    {*&&&&&&&&&&&&&&&  WIN 95 CALL  &&&&&&&&&&&&&&&&&&&*}
    DriveType := TDriveType(GetDriveType( DrivePC ));
    { Assign an icon based on the drive type; if no drive exists type is nil }
    case DriveType of
      dtFloppy  : IconType := 1;
      dtFixed   : IconType := 2;
      dtNetwork : IconType := 3;
      dtCDROM   : IconType := 4;
      dtRAM     : IconType := 5;
    end;
    { Set to check next drive letter }
    DriveNum := DriveNum + 1;
    { But if no match then out of drives so set exit flag }
    if IconType = 0 then finished := true;
    { If drive was valid then set up the new FileIconPanel on the imported }
    { Scrollbox                                                            }
    if not finished then
    begin
      { Create the FileIconPanel and set its parent for memory mgmt and display}
      TheFIP := TFileIconPanel.Create( Self );
      TheFIP.Parent := Self;
      { Call its initialize method with imported position values and the   }
      { preset color scheme, a drive caption, and a minimum font. Note the }
      { setting of the ExtraData field to non-zero; this signals a drive   }
      { rather than a file being sent in.                                  }
      TheFIP.Initialize((( XCounter - 1 ) * TheIconSpacing ),
       (( YCounter - 1  ) * TheIconSpacing ) , TheIconSize , TheIconSize , 3 ,
        7 , ButtonColor, ButtonHLColor,
       ButtonSColor , TextColor , 'DRIVE ' + DriveChar + ':' , 'MS Serif' , [] ,
       IconType );
      { Increment the column counter; if it exceeds max move to new row      }
      { Note that these are 'var' parameters and will export final position. }
      XCounter := XCounter + 1;
      if XCounter > MaxIconsInARow then
      begin
        XCounter := 1;
        YCounter := YCounter + 1;
      end;
    end;
  end;
end;

{ This procedure assigns colors to FIP's based on file attributes }
procedure TFileIconPanelScrollBox.GetColorsForFileIcon( TheFile : String;
           var BC , HC , SC , TC : TColor );
var AmADir      ,             { Booleans hold file attribs }
    AmAnArchive ,
    AmAVolumeId ,
    AmHidden    ,
    AmReadOnly  ,
    AmSystem      : Boolean;
begin
  { Make the call to internal fileworkbench to set attributes }
  TheFWB.GetFileAttributes( TheFile , AmADir , AmAnArchive , AmAVolumeId ,
   AmHidden , AmReadOnly , AmSystem );
  { Volume ID has no subtypes }
  if AmAVolumeID then
  begin
    BC := clOlive;
    HC := clYellow;
    SC := clBlack;
    TC := clWhite;
    exit;
  end;
  { Check all directory combinations }
  if AmADir then
  begin
    BC := clNavy;
    HC := clBlue;
    SC := clBlack;
    TC := clWhite;
    if AmHidden then
    begin
      if AmReadOnly then
      begin
        if AmSystem then
        begin { One HECK of a file! }
          BC := clBlack;
          HC := clSilver;
          SC := clGray;
          TC := clWhite;
        end
        else
        begin { Dir,RO,Hid }
          BC := clMaroon;
          HC := clFuchsia;
          SC := clGreen;
          TC := clWhite;
        end;
      end
      else
      begin { Dir,Hid }
        BC := clPurple;
        HC := clFuchsia;
        SC := clBlack;
        TC := clWhite;
      end;
    end
    else
    begin
      if AmReadOnly then
      begin
        if AmSystem then
        begin { Dir,RO,Sys }
          BC := clMaroon;
          HC := clLime;
          SC := clGreen;
          TC := clWhite;
        end
        else
        begin { Dir,RO }
          BC := clGreen;
          HC := clLime;
          SC := clBlack;
          TC := clWhite;
        end;
      end
      else
      begin
        if AmSystem then
        begin { Dir,Sys }
          BC := clMaroon;
          HC := clRed;
          SC := clBlack;
          TC := clWhite;
        end;
      end;
    end;
  end
  else { Archive Only; check all combinations }
  begin
    BC := clSilver;
    HC := clWhite;
    SC := clGray;
    TC := clBlack;
    if AmHidden then
    begin
      if AmReadOnly then
      begin
        if AmSystem then
        begin { Hid,RO,Sys }
          BC := clRed;
          HC := clLime;
          SC := clPurple;
          TC := clBlack;
        end
        else
        begin { RO,Hid }
          BC := clLime;
          HC := clFuchsia;
          SC := clMaroon;
          TC := clBlack;
        end;
      end
      else
      begin { Hid }
        BC := clFuchsia;
        HC := clWhite;
        SC := clPurple;
        TC := clBlack;
      end;
    end
    else
    begin
      if AmReadOnly then
      begin
        if AmSystem then
        begin { RO,Sys }
          BC := clRed;
          HC := clLime;
          SC := clMaroon;
          TC := clBlack;
        end
        else
        begin { RO }
          BC := clLime;
          HC := clWhite;
          SC := clGreen;
          TC := clBlack;
        end;
      end
      else
      begin
        if AmSystem then
        begin { System }
          BC := clRed;
          HC := clWhite;
          SC := clMaroon;
          TC := clBlack;
        end;
      end;
    end;
  end;
end;

{ This procedure gets all icons for an given directory, including drives and }
{ standard subdirectories. It does not get special combinations or h/ro/sys  }
procedure TFileIconPanelScrollbox.GetIconsForEntireDirectory(
            TargetPath  : String );
var Finished        : Boolean;         { Loop flag              }
    TheSR           : TSearchRec;      { Searchrecord for FF/FN }
    TheResult       : Integer;         { return variable        }
    TempPath        : String;          { path for FF/FN         }
    TheFIP          : TFileIconPanel;  { generic FIP holder     }
    RowCounter    ,                    { position in row of FIP }
    ColumnCounter   : Integer;         { position in col of FIP }
    ButtonColor   ,                    { main panel color       }
    ButtonHLColor ,                    { bright panel color     }
    ButtonSColor  ,                    { dark panel color       }
    Textcolor       : TColor;          { label text color       }
    IsADir ,                           { Variable for file attr }
    IsAnArchive ,
    IsAVolumeID,
    IsAReadOnlyFile,
    IsAHiddenFile ,
    IsASystemFile     : Boolean;
    MaxTextLength     : Integer;       { Used to safely set size}
begin
  { hide during refresh }
  Visible := false;
  { Delete the current set, if any }
  ClearTheFIPs;
  { Get the icon sizes }
  TheFIP := TFileIconPanel.Create( Self );
  TheFIP.Parent := Self;
  TheFIP.FTheLabel.Canvas.Font.Name := 'MS Serif';
  TheFIP.FTheLabel.Canvas.Font.Size := 7;
  MaxTextLength := TheFIP.FTheLabel.Canvas.TextWidth( 'COMMAND.COM' );
  TheFIP.Free;
  TheIconSize := MaxTextLength + 13;
  TheIconSpacing := TheIconSize + 5;
  { Set up maximum icons per row based on screen size }
  MaxIconsInARow := ( Screen.Width div TheIconSpacing );
  { Set up the position counters }
  RowCounter := 1;
  ColumnCounter := 1;
  { Get the drives for the current machine }
  AddDriveIcons( ColumnCounter , RowCounter  );
  { Set up the initial variables }
  Finished := false;
  TempPath := TargetPath + '*.*';
  { Make the call to FindFirst set to get any file; will return '.' }
  { so discard it.                                                  }
  TheResult := FindFirst( TempPath , faAnyFile , TheSR );
  { loop through all files in the directory and look for directories }
  while not Finished do
  begin
    { Make call to FindNext, using only SearchRecord from FindFirst }
    TheResult := FindNext( TheSR );
    { A -1 result means no more files so exit }
    if TheResult <> 0 then finished := true else
    begin
      { Otherwise check for a directory attribute }
      if (( FileGetAttr( TargetPath + TheSR.Name ) and faDirectory ) =
       faDirectory ) then
      begin
        GetColorsForFileIcon( TargetPath + TheSR.Name , ButtonColor ,
         ButtonHLColor , ButtonSColor , TextColor );
        { If found create a new FileIconPanel on the imported scrollbox }
        { Note sending 0 ExtraData parameter to indicate file not drive }
        TheFIP := TFileIconPanel.Create( Self );
        TheFIP.Parent := Self;
        TheFIP.Initialize((( ColumnCounter - 1 ) * TheIconSpacing ),
         (( RowCounter - 1  ) * TheIconSpacing ) , TheIconSize, TheIconSize ,
          3 , 7 , ButtonColor, ButtonHLColor , ButtonSColor , TextColor ,
           TargetPath + TheSr.Name , 'MS Serif' , [] , 0 );
        { Increment column counter and move to new row if past limit }
        ColumnCounter := ColumnCounter + 1;
        if ColumnCounter > MaxIconsInARow then
        begin
          ColumnCounter := 1;
          RowCounter := RowCounter + 1;
        end;
      end;
    end;
  end;
  { Set up new initialization variables }
  Finished := false;
  TempPath := TargetPath + '*.*';
  { Make needed call to FindFirst and discard '.' }
  TheResult := FindFirst( TempPath , faAnyFile , TheSR );
  while not Finished do
  begin
    { Loop through file again, this time getting only archive files }
    TheResult := FindNext( TheSR );
    { Result of -1 indicates no more files }
    if TheResult <> 0 then Finished := true else
    begin
      { If faArchive file then add new FileIconPanel }
      TheFWB.GetFileAttributes(( Targetpath + TheSR.Name ) , IsADir ,
       IsAnArchive , IsAVolumeId , IsAHiddenFile , IsAReadOnlyFile ,
        IsASystemFile );
      if (( IsAnArchive ) and ( not IsADir )) then
      begin
        GetColorsForFileIcon( TargetPath + TheSR.Name , ButtonColor ,
         ButtonHLColor , ButtonSColor , TextColor );
        { Initialize new FileIconPanel and call initialize, sending 0 ED }
        TheFIP := TFileIconPanel.Create( Self );
        TheFIP.Parent := Self;
        TheFIP.Initialize((( ColumnCounter - 1 ) * TheIconSpacing ),
         (( RowCounter - 1  ) * TheIconSpacing ) , TheIconSize , TheIconSize ,
          3 , 7 , ButtonColor, ButtonHLColor , ButtonSColor , TextColor ,
           TargetPath + TheSr.Name , 'MS Serif' , [] , 0 );
        { Increment column counter and if needed row counter }
        ColumnCounter := ColumnCounter + 1;
        if ColumnCounter > MaxIconsInARow then
        begin
          ColumnCounter := 1;
          RowCounter := RowCounter + 1;
        end;
      end;
    end;
  end;
  { Reset to visible }
  Visible := true;
end;

{ Update method for FIPscrollbox }
procedure TFileIconPanelScrollBox.Update;
begin
  IconsNeedRefreshing := true;
  { Force a repaint }
  InvalidateRect( TheStoredHandle , nil , true );
end;

{ Create method for FIPScrollbox }
constructor TFileIconPanelScrollBox.Create( AOwner : TComponent );
begin
  inherited Create( AOwner );
  TheFWB := TFileWorkBench.Create( Self );
end;

{ This function returns the next selected file's name }
function TFileIconPanelScrollBox.GetNextSelection( SourceDirectory : String;
                           var CurrentItem : Integer ) : String;
var TheResult    : String;      { Holds result of function }
    TheComponent : TComponent;  { Used for typecast        }
    finished     : boolean;     { Loop control variable    }
    TheComponentCount : Integer;
begin
  TheComponentCount := ComponentCount;
  { If past end of components exit with no result }
  if CurrentItem > TheComponentCount then TheResult := '' else
  begin
    { Set loop counter and run till find match or run out }
    finished := false;
    while not finished do
    begin
      { Pull component out of the list and check it }
      TheComponent := Components[ CurrentItem - 1 ];
      { Increment counter for later }
      CurrentItem := CurrentItem + 1;
      { Do the typecast with AS }
      with TheComponent as TFileIconPanel do
      begin
        { If its selected make sure OK }
        if Selected then
        begin
          { Don't accept backup for this level of operation }
          if FTheLabel.Caption <> '..' then
          begin
            { Otherwise return the name and abort the loop }
            TheResult := FTheName;
            finished := true;
          end;
        end
        else
        begin
          { Check to see if out of components }
          if CurrentItem > TheComponentCount then
          begin
            { If so signal error and abort }
            TheResult := '';
            finished := true;
          end;
        end;
      end;
    end;
  end;
  GetNextSelection := TheResult;
end;

{ This procedure places a selection of files in the display based on wildcards }
procedure TFileIconPanelScrollBox.DisplayRecursiveSearchResults(
           TheStartingDirectory : String );
var XCounter ,
    YCounter   : Integer;

{ This procedure does a recursive file search by first getting all matches (in-}
{ cluding directories) and adding them to the list. Then it checks for ALL the }
{ subdirectories and does the same trick on them til there are no more matches }
{ and no more subdirectories, at which point it exits and recurses back up.    }
procedure RecursiveFileSearch( TheWorkingDirectory : String; var XCounter ,
                               YCounter : Integer );

{ VITAL!!! These variables MUST be local for recursrion to work! }
var
    Finished        : Boolean;         { Loop flag              }
    TheSR           : TSearchRec;      { Searchrecord for FF/FN }
    TheResult       : Integer;         { return variable        }
    TargetPath ,
    FileMask   ,
    TheStoredWorkingDirectory ,
    ModifiedDirectory  : String;       { path for FF/FN         }
    TheFIP          : TFileIconPanel;  { generic FIP holder     }
    ButtonColor   ,                    { main panel color       }
    ButtonHLColor ,                    { bright panel color     }
    ButtonSColor  ,                    { dark panel color       }
    Textcolor       : TColor;          { label text color       }

begin
  { Set up the initial variables }
  Finished := false;
  TheStoredWorkingDirectory := TheWorkingDirectory;
  Targetpath := ExtractFilePath( TheWorkingDirectory );
  FileMask := ExtractFileName( TheWorkingDirectory );
  { Make the call to FindFirst set to get any file }
  TheResult := FindFirst( TheWorkingDirectory , faAnyFile , TheSR );
  if TheResult < 0 then finished := true;
  if (( TheSr.Name <> '.' ) and ( TheSr.Name <> '..' ) and ( TheResult >= 0 ))
  then begin
    if (( FileGetAttr( TargetPath + TheSR.Name ) and faDirectory ) =
     faDirectory ) then
    begin { A directory }
      GetColorsForFileIcon( TargetPath + TheSR.Name , ButtonColor ,
       ButtonHLColor , ButtonSColor , TextColor );
      { If found create a new FileIconPanel on the imported scrollbox }
      { Note sending 0 ExtraData parameter to indicate file not drive }
      TheFIP := TFileIconPanel.Create( Self );
      TheFIP.Parent := Self;
      TheFIP.Initialize((( XCounter - 1 ) * TheIconSpacing ),
       (( YCounter - 1  ) * TheIconSpacing ) , TheIconSize , TheIconSize , 3 ,
        7 , ButtonColor, ButtonHLColor , ButtonSColor , TextColor , TargetPath
         + TheSr.Name , 'MS Serif' , [] , 0 );
      { Increment column counter and move to new row if past limit }
      XCounter := XCounter + 1;
      if XCounter > MaxIconsInARow then
      begin
        XCounter := 1;
        YCounter := YCounter + 1;
      end;
    end
    else
    begin { A File }
      { Set up the default color scheme for files }
      GetColorsForFileIcon( TargetPath + TheSR.Name , ButtonColor ,
       ButtonHLColor , ButtonSColor , TextColor );
      { If found create a new FileIconPanel on the imported scrollbox }
      { Note sending 0 ExtraData parameter to indicate file not drive }
      TheFIP := TFileIconPanel.Create( Self );
      TheFIP.Parent := Self;
      TheFIP.Initialize((( XCounter - 1 ) * TheIconSpacing ),
       (( YCounter - 1  ) * TheIconSpacing ) , TheIconSize, TheIconSize , 3 ,
        7 , ButtonColor, ButtonHLColor , ButtonSColor , TextColor , TargetPath
         + TheSr.Name , 'MS Serif' , [] , 0 );
      { Increment column counter and move to new row if past limit }
      XCounter := XCounter + 1;
      if XCounter > MaxIconsInARow then
      begin
        XCounter := 1;
        YCounter := YCounter + 1;
      end;
    end;
  end;
  { loop through all files in the directory and look for matches }
  while not Finished do
  begin
    { Make call to FindNext, using only SearchRecord from FindFirst }
    TheResult := FindNext( TheSR );
    { A -1 result means no more files so exit }
    if TheResult <> 0 then finished := true else
    begin
      if (( FileGetAttr( TargetPath + TheSR.Name ) and faDirectory ) =
       faDirectory ) then
      begin { A directory }
        { Set up the blue color scheme for directories }
        GetColorsForFileIcon( TargetPath + TheSR.Name , ButtonColor ,
         ButtonHLColor , ButtonSColor , TextColor );
        { If found create a new FileIconPanel on the imported scrollbox }
        { Note sending 0 ExtraData parameter to indicate file not drive }
        TheFIP := TFileIconPanel.Create( Self );
        TheFIP.Parent := Self;
        TheFIP.Initialize((( XCounter - 1 ) * TheIconSpacing ),
         (( YCounter - 1  ) * TheIconSpacing ) , TheIconSize , TheIconSize , 3 ,
           7 , ButtonColor, ButtonHLColor , ButtonSColor , TextColor ,
            TargetPath + TheSr.Name , 'MS Serif' , [] , 0 );
        { Increment column counter and move to new row if past limit }
        XCounter := XCounter + 1;
        if XCounter > MaxIconsInARow then
        begin
          XCounter := 1;
          YCounter := YCounter + 1;
        end;
      end
      else
      begin { A File }
        { Set up the default color scheme for files }
        GetColorsForFileIcon( TargetPath + TheSR.Name , ButtonColor ,
         ButtonHLColor , ButtonSColor , TextColor );
        { If found create a new FileIconPanel on the imported scrollbox }
        { Note sending 0 ExtraData parameter to indicate file not drive }
        TheFIP := TFileIconPanel.Create( Self );
        TheFIP.Parent := Self;
        TheFIP.Initialize((( XCounter - 1 ) * TheIconSpacing ),
         (( YCounter - 1  ) * TheIconSpacing ) , TheIconSize , TheIconSize , 3 ,
          7 , ButtonColor, ButtonHLColor , ButtonSColor , TextColor ,
           TargetPath + TheSr.Name , 'MS Serif' , [] , 0 );
        { Increment column counter and move to new row if past limit }
        XCounter := XCounter + 1;
        if XCounter > MaxIconsInARow then
        begin
          XCounter := 1;
          YCounter := YCounter + 1;
        end;
      end;
    end;
  end;
  { Set up the variables to do recursive calls on all directories}
  Finished := false;
  ModifiedDirectory := ExtractFilePath( TheWorkingdirectory ) + '*.*';
  { Make the call to FindFirst set to get any file, ignore result }
  TheResult := FindFirst( ModifiedDirectory , faDirectory , TheSR );
  while not Finished do
  begin
    { Make call to FindNext, using only SearchRecord from FindFirst }
    TheResult := FindNext( TheSR );
    { A -1 result means no more files so exit }
    if TheResult <> 0 then finished := true
    else
    begin
      if TheSR.Name <> '..' then { Ignore backup in this case }
      begin
        { Do second check due to bug in FindNext }
        if (( FileGetAttr( TargetPath + TheSR.Name ) and faDirectory )
        = faDirectory ) then
        begin
          { Set up modified directory to recurse into }
          ModifiedDirectory := ExtractFilePath( TheStoredWorkingDirectory ) +
           TheSR.Name + '\' + FileMask;
          { Perform the recursion }
          RecursiveFileSearch( ModifiedDirectory , XCounter , YCounter );
        end;
      end;
    end;
  end;
end;

begin
  { Keep the scrollbox from updating during refresh }
  Visible := false;
  { Make the clear call }
  ClearTheFIPs;
  XCounter := 1;
  YCounter := 1;
  { Get the drives for the current machine }
  AddDriveIcons( XCounter , YCounter );
  RecursiveFileSearch( TheStartingDirectory , XCounter , YCounter );
  { Make the scrollbox visible again }
  Visible := true;
end;

end.