home *** CD-ROM | disk | FTP | other *** search
/ Delphi 2 - Developers' Solutions / Delphi 2 Developers' Solutions.iso / dds / chap06 / howto05 / delphi10 / drwsutl4.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1996-01-09  |  131.5 KB  |  3,584 lines
  1. unit Drwsutl4;
  2.  
  3. interface
  4.  
  5. uses
  6.   SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  7.   Forms, Dialogs, StdCtrls, Buttons, ExtCtrls, ShellAPI, FileCtrl, DelphPCX,
  8.   DRWSUtl1;
  9.  
  10. const
  11.   EOC_CHANGEDIR = 1;  { Error Operation Code for change directory failure }
  12.   EOC_SOURCECOPY = 2; { Error Operation Code for source copy failure      }
  13.   EOC_DESTCOPY = 3;   { Error Operation Code for destination copy failure }
  14.   EOC_DELETEFILE = 4; { Error Operation Code for file delete failure      }
  15.   EOC_DELETEDIR = 5;  { Error Operation Code for directory delete failure }
  16.   EOC_RENAMEFILE = 6; { Error Operation Code for renaming failure         }
  17.   EOC_MAKEDIR = 7;    { Error Operation Code for MkDir failure            }
  18.   EOC_SETATTR = 8;    { Error Operation Code for Set Attributes failure   }
  19.  
  20.   FAC_COPY = 1;       { File Action Code for recursive copying            }
  21.   FAC_MOVE = 2;       { File Action Code for recursive moving             }
  22.   FAC_DELETE = 3;     { File Action Code for recursive deletion           }
  23.  
  24.   KBMJ_SINGLE = 1;   { Keyboard mouse motion constant for single pixel moves }
  25.   KBMJ_SMALL = 10;    { Keyboard mouse motion constant for single pixel moves }
  26.   KBMJ_LARGE = 50;    { Keyboard mouse motion constant for single pixel moves }
  27.  
  28.   CR_KEYSET = 6; { ID for special keypress cursor }
  29.   CR_NULL = 7;   { ID for Null (blank) cursor     }
  30.  
  31. type
  32.   { This is a descendant of TFileListbox }
  33.   { Which puts icons of files into the   }
  34.   { Objects array rather than the stand- }
  35.   { ard bitmaps.                         }
  36.   TIconFileListBox = class( TFileListBox )
  37.   public
  38.     { public methods and data }
  39.     procedure ReadFileNames; override;
  40.     function GetNextSelection( SourceDirectory : String;
  41.               var CurrentItem : Integer ) : String;
  42.     constructor Create(AOwner : TComponent); override; { override create    }
  43.     procedure TheDblClick( Sender : TObject );{ This holds override dblclick }
  44.   end;
  45.   TFileWorkBench = class( TComponent )
  46.   public
  47.     GlobalError        : Integer;  { This is used by FMXUCopyFile for er code }
  48.     GlobalErrorType    : Integer;  { This holds the Operation code            }
  49.     function ForceTrailingBackSlash( const TheFileName : String ) : String;
  50.     function StripNonRootTrailingBackSlash(
  51.               const TheFileName : String ) : String;
  52.     procedure GetFileAttributes( TheFile : String; var IsDirectory , IsArchive ,
  53.                 IsVolumeID , IsHidden , IsReadOnly , IsSysFile : Boolean );
  54.     procedure HandleIOException( TheOpCode : Integer; ThePath : String;
  55.                                  TheMessage : String; TheCode : Integer );
  56.     procedure HandleDOSError( TheOpCode : Integer; ThePath : String;
  57.                 TheCode : Integer );
  58.     function CopyFile( TargetPath ,
  59.                DestinationPath : String ) : Boolean;
  60.     procedure ChangeTheDirectory( NewPath : String );
  61.     procedure ChangeTheDriveAndDirectory( NewDrive : Integer );
  62.     procedure CopyTheFile( OldPath , NewPath : String );
  63.     procedure MoveTheFile( OldPath , NewPath : String );
  64.     procedure DeleteTheFile( ThePath : String );
  65.     procedure RenameTheFile( OldPath , NewName : String );
  66.     procedure CreateNewDirectory( NewPath : String );
  67.     procedure RemoveDirectory( ThePath : String );
  68.     procedure SetFileAttributes( TheFile  : String; TheAttributes : Integer );
  69.     procedure RecursivelyCopyDirectory( OldPath , NewPath : String );
  70.     procedure RecursivelyMoveDirectory( OldPath , NewPath : String );
  71.     procedure RecursivelyDeleteDirectory( ThePath : String );
  72.     procedure HandleRecursiveAction( StartingPath , NewPath : String;
  73.                ActionCode : Integer );
  74.   end;
  75.   TFileIconPanel = class( TPanel )
  76.   private
  77.     { Private declarations }
  78.     FHighlightColor : TColor;                 { This holds bright edge bevel }
  79.     FShadowColor    : TColor;                 { This holds dark edge bevel   }
  80.     procedure TheMouseDown(Sender: TObject;
  81.       Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
  82.     procedure TheMouseMove( Sender: TObject; Shift: TShiftState;
  83.       X, Y: Integer);
  84.     procedure TheMouseUp(Sender: TObject;
  85.       Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
  86.     procedure WMLButtonDblClk(var Message: TWMLButtonDblClk);
  87.      message WM_LBUTTONDBLCLK;
  88.     procedure TheDragOver(Sender, Source: TObject; X,
  89.       Y: Integer; State: TDragState; var Accept: Boolean);
  90.     procedure TheDragDrop(Sender, Source: TObject; X,
  91.       Y: Integer);
  92.   protected                                   { event method procedure.      }
  93.     { Protected declarations }
  94.     procedure Paint; override;                { This allows custom painting  }
  95.   public
  96.     { Public declarations }
  97.     FTheIcon : TIcon;                         { This is the display icon    }
  98.     FTheBMP  : TBitmap;                       { This holds a thumbnail image}
  99.     FTheName : String;                        { This is the filename        }
  100.     FTheLabel : TLabel;                       { This is the display label   }
  101.     Selected : Boolean;                       { This holds selection status }
  102.     constructor Create(AOwner : TComponent); override; { override create    }
  103.     procedure Initialize( PanelX              ,             { Left          }
  104.                           PanelY              ,             { Top           }
  105.                           PanelWidth          ,             { Width         }
  106.                           PanelHeight         ,             { Height        }
  107.                           PanelBevelWidth     ,             { Bevel Width   }
  108.                           LabelFontSize         : Integer;  { Font size     }
  109.                           PanelColor          ,             { Main color    }
  110.                           PanelHighlightColor ,             { Bright color  }
  111.                           PanelShadowColor    ,             { Dark color    }
  112.                           LabelTextColor        : TColor;   { Text color    }
  113.                           TheFilename         ,             { Filename      }
  114.                           LabelFontName         : String;   { Font name     }
  115.                           LabelFontStyle        : TFontStyles;  { Font style}
  116.                           ExtraData             : Integer       );  { Drive }
  117.     destructor Destroy; override;             { override destroy to free    }
  118.   end;
  119.   TFileIconPanelScrollBox = class( TScrollBox )
  120.   public
  121.     { Public methods and data }
  122.     TheFWB              : TFileWorkBench; { Used for file manipulation         }
  123.     IconsNeedRefreshing : Boolean;                   { Flag to redo display    }
  124.     TheIconSize        : Integer;   { Holds Individual Icon size               }
  125.     TheIconSpacing     : Integer;   { Holds total icon footprint               }
  126.     MaxIconsInARow     : Integer;   { Set for screen size.                     }
  127.     TheStoredHandle    : HWnd;
  128.     TheParentForm      : TForm;
  129.     procedure Update;                                { Called to reset display }
  130.     constructor Create( AOwner : TComponent ); override;  { Override inherited }
  131.     procedure ClearTheFIPs;                          { Clears the FIPs safely  }
  132.     procedure AddDriveIcons( var XCounter , YCounter : Integer ); { Add drives }
  133.     procedure GetColorsForFileIcon( TheFile : String;
  134.                var BC , HC , SC , TC : TColor );
  135.     procedure GetIconsForEntireDirectory( TargetPath  : String );
  136.     function GetNextSelection( SourceDirectory : String;
  137.               var CurrentItem : Integer ) : String;
  138.     procedure DisplayRecursiveSearchResults(
  139.       TheStartingDirectory : String );
  140.   end;
  141.   TIOManager = class( TComponent )
  142.   public
  143.     Parent : TForm;
  144.     WhichButton : TMouseButton;
  145.     WhichState  : TShiftState;
  146.     CLState ,
  147.     NLState ,
  148.     SLState   : Boolean;
  149.     function IsCapsLockDown : Boolean;
  150.     function ISNumLockDown : Boolean;
  151.     function IsScrollLockDown : Boolean;
  152.     procedure InitLocks;
  153.     procedure ReadLocks( var TheCL , TheNL , TheSL : Boolean );
  154.     procedure SetLocks( TheCL , TheNL , TheSL : Boolean );
  155.     function WasLeftPressed : Boolean;
  156.     function WasRightPressed : Boolean;
  157.     function WasMiddlePressed : Boolean;
  158.     function WasALTPressed : Boolean;
  159.     function WasSHIFTPressed : Boolean;
  160.     function WasCTRLPressed : Boolean;
  161.     procedure OnF1Pressed(Sender: TObject; var Key: Word;
  162.      Shift: TShiftState);
  163.     procedure OnF2Pressed(Sender: TObject; var Key: Word;
  164.      Shift: TShiftState);
  165.     procedure OnF3Pressed(Sender: TObject; var Key: Word;
  166.      Shift: TShiftState);
  167.     procedure OnF4Pressed(Sender: TObject; var Key: Word;
  168.      Shift: TShiftState);
  169.     procedure OnF5Pressed(Sender: TObject; var Key: Word;
  170.      Shift: TShiftState);
  171.     procedure OnF6Pressed(Sender: TObject; var Key: Word;
  172.      Shift: TShiftState);
  173.     procedure OnF7Pressed(Sender: TObject; var Key: Word;
  174.      Shift: TShiftState);
  175.     procedure OnF8Pressed(Sender: TObject; var Key: Word;
  176.      Shift: TShiftState);
  177.     procedure OnF9Pressed(Sender: TObject; var Key: Word;
  178.      Shift: TShiftState);
  179.     procedure OnF10Pressed(Sender: TObject; var Key: Word;
  180.      Shift: TShiftState);
  181.     procedure OnF11Pressed(Sender: TObject; var Key: Word;
  182.      Shift: TShiftState);
  183.     procedure OnF12Pressed(Sender: TObject; var Key: Word;
  184.      Shift: TShiftState);
  185.  end;
  186.  TMouseManager = class( TComponent )
  187.  public
  188.    TheMX : Integer;
  189.    TheMY : Integer;
  190.    Old_X ,
  191.    Old_Y ,
  192.    New_X ,
  193.    New_Y   : Integer;
  194.    StoredCursor : Integer;
  195.    BitmapCursor  : Boolean;
  196.    IconCursor    : Boolean;
  197.    CursorBMP     : TBitmap;
  198.    CursorIcon    : TIcon;
  199.    IsAnimated    : Boolean;
  200.    TheTimer      : TTimer;
  201.    TheAnimationList : TList;
  202.    CurrentAnimationPointer : Integer;
  203.    AnimationInterval : Integer;
  204.    SavedDC ,
  205.    GlobalDC : HDC;
  206.    GlobalCanvas : TCanvas;
  207.    WorkSpaceBMP : TBitmap;
  208.    BackGroundBMP : TBitmap;
  209.    constructor Create( AOwner : TComponent ); override;
  210.    destructor Destroy; override;
  211.    procedure InitializeNormal;
  212.    procedure InitializeBitmap( TheBmp : TBitmap );
  213.    procedure InitializeIcon( TheIcon : TIcon );
  214.    procedure InitializeAnimated( TheIcon : TIcon; TheInterval : Integer;
  215.                                  TheIconList : TList );
  216.    procedure GetMousePosition( var MouseX , MouseY : Integer );
  217.    procedure SetMousePosition( MouseX , MouseY : Integer );
  218.    procedure MoveSinglePixelLeft;
  219.    procedure MoveSinglePixelRight;
  220.    procedure MoveSinglePixelUp;
  221.    procedure MoveSinglePixelDown;
  222.    procedure MoveSmallJumpLeft;
  223.    procedure MoveSmallJumpRight;
  224.    procedure MoveSmallJumpUp;
  225.    procedure MoveSmallJumpDown;
  226.    procedure MoveLargeJumpLeft;
  227.    procedure MoveLargeJumpRight;
  228.    procedure MoveLargeJumpUp;
  229.    procedure MoveLargeJumpDown;
  230.    procedure StartBitmapCursor( TheX , TheY : Integer );
  231.    procedure MoveBitmapCursor( TheX , TheY : Integer );
  232.    procedure EndBitmapCursor( TheX , TheY : Integer );
  233.    procedure StartIconCursor( TheX , TheY : Integer );
  234.    procedure MoveIconCursor( TheX , TheY : Integer );
  235.    procedure EndIconCursor( TheX , TheY : Integer );
  236.    procedure StartAnimatedIconCursor( TheX , TheY : Integer );
  237.    procedure EndAnimatedIconCursor( TheX , TheY : Integer );
  238.    procedure MoveAnimatedIconCursor( TheX , TheY : Integer );
  239.    procedure TimerAction( Sender : TObject );
  240.  end;
  241.  
  242.   { This procedure gets an icon for a file using FindExecutable  }
  243.   { and ExtractIcon. (assumes file/dir is passed)                }
  244.   procedure GetIconForFile( TheName : String; var TheIcon : TIcon );
  245.   { This procedure spaces out the bitbtn components on a tpanel }
  246.   procedure SpacePanelButtons( WhichPanel : TPanel );
  247.     procedure FMXUCopyFile(const FileName, DestName: String; var GlobalErrorType ,
  248.                GlobalErrorCode : Integer );
  249.  
  250. var TheIOManager : TIOManager;
  251.     TheMouseManager : TMouseManager;
  252.     GlobalAbortFlag : Boolean;
  253.     SavedForm : TForm;
  254.     SavedControl : TFileIconPanel;
  255.     OtherSavedControl : TFileIconPanelScrollbox;
  256.     Savedhandle : HWnd;
  257.     IconDragging : boolean;
  258.     GlobalSource : TObject;
  259.     TheTempBitmap : TBitmap;
  260.     BitmapDragging : boolean;
  261.     ThumbNailWidth,
  262.     ThumbNailHeight : Integer;
  263.     GlobalTransparentColor : TColor;
  264.  
  265. implementation
  266. {$R DRWSUTL4.RES}                 { Import custom resource file }
  267. uses UFMGR34,DRWSUtl6;
  268.  
  269. { It has been edited to return viable error codes!             }
  270. procedure FMXUCopyFile(const FileName, DestName: String; var GlobalErrorType ,
  271.             GlobalErrorCode : Integer );
  272. var
  273.   CopyBuffer: Pointer; { buffer for copying }
  274.   BytesCopied: Longint;
  275.   TheAttr : Integer;
  276.   Source, Dest: Integer; { handles }
  277. const
  278.   ChunkSize: Longint = 8192; { copy in 8K chunks }
  279. begin
  280.   GetMem(CopyBuffer, ChunkSize); { allocate the buffer }
  281.   Source := FileOpen(FileName, fmShareDenyWrite); { open source file }
  282.   if Source < 0 then
  283.   begin  { error creating source file }
  284.     GlobalErrorType := EOC_SOURCECOPY;
  285.     GlobalErrorCode := -IOResult;
  286.     if GlobalErrorCode = 0 then GlobalErrorCode := -157;
  287.     FreeMem( CopyBuffer, ChunkSize );
  288.     exit;
  289.   end;
  290.   Dest := FileCreate(DestName); { create output file; overwrite existing }
  291.   if Dest < 0 then
  292.   begin  { error creating destination file }
  293.     FileClose( Source );
  294.     GlobalErrorType := EOC_DESTCOPY;
  295.     GlobalErrorCode := -IOResult;
  296.     if GlobalErrorCode = 0 then GlobalErrorCode := -159;
  297.     FreeMem( CopyBuffer , ChunkSize );
  298.     exit;
  299.   end;
  300.   {$I-}
  301.   repeat
  302.     BytesCopied := FileRead(Source, CopyBuffer^, ChunkSize); { read chunk}
  303.     if BytesCopied > 0 then { if we read anything... }
  304.     FileWrite(Dest, CopyBuffer^, BytesCopied); { ...write chunk }
  305.   until BytesCopied < ChunkSize; { until we run out of chunks }
  306.   {$I+}
  307.   GlobalErrorCode := -IOResult;  { get any error code which happens during copying }
  308.   FileClose(Dest); { close the destination file }
  309.   FileClose(Source); { close the source file }
  310.   FreeMem(CopyBuffer, ChunkSize); { free the buffer }
  311. end;
  312.  
  313. { This procedure spaces out the bitbtn components on a tpanel }
  314. procedure SpacePanelButtons( WhichPanel : TPanel );
  315. var TheCalculatedSpacing     ,            { Holds primary spacing }
  316.     TheFullCalculatedSpacing   : Integer; { Holds full spacing    }
  317.     Counter_1                  : Integer; { Loop counter          }
  318.     TotalIBs                   : Integer; { Gets total buttons    }
  319. begin
  320.   { Set up spacing values }
  321.   TotalIBs := WhichPanel.ControlCount;
  322.   TheCalculatedSpacing := (( WhichPanel.Width - 6 - ( TotalIbs * 49 ))
  323.    div ( TotalIbs + 1 ));
  324.   TheFullCalculatedSpacing := TheCalculatedSpacing + 49;
  325.   { Loop through all imported buttons and set their Left values }
  326.   for Counter_1 := 1 to WhichPanel.ControlCount do
  327.   begin
  328.     if Counter_1 = 1 then
  329.     begin
  330.       TBitBtn( WhichPanel.Controls[ Counter_1 - 1 ] ).Left := 3 +
  331.        TheCalculatedSpacing;
  332.     end
  333.     else
  334.     begin
  335.       TBitBtn( WhichPanel.Controls[ Counter_1 - 1 ] ).Left := 3 +
  336.        (( Counter_1 - 1 ) * TheFullCalculatedSpacing ) + TheCalculatedSpacing;
  337.     end;
  338.   end;
  339. end;
  340.  
  341. { This procedure gets an icon for a file using FindExecutable  }
  342. { and ExtractIcon. (assumes file/dir is passed)                }
  343. procedure GetIconForFile( TheName : String; var TheIcon : TIcon );
  344. var TheExt           : String; { File extension holder }
  345.     TheOtherPChar  ,           { Windows ASCIIZ string }
  346.     TheResultPChar ,           { Windows ASCIIZ string }
  347.     ThePChar         : PChar;  { Windows ASCIIZ string }
  348. begin
  349.   { Check for directory and if so get directory icon from RES file }
  350.   if (( FileGetAttr( TheName ) and faDirectory ) = faDirectory ) then
  351.   begin
  352.     { Set up the PChar to communicate with Windows }
  353.     GetMem( TheOtherPChar , 255 );
  354.     { Convert Pascal-style string to ASCIIZ Pchar }
  355.     StrPCopy( TheOtherPChar , 'DIRECTORY' );
  356.     { Use API call to return icon handle of Icon Resource in FILECTRL.RES }
  357.     TheIcon.Handle := LoadIcon( hInstance , TheOtherPChar );
  358.     { Release memory from PChar }
  359.     FreeMem( TheOtherPChar , 255 );
  360.     { Leave }
  361.     exit;
  362.   end;
  363.   { Assume archive file; get its extension }
  364.   TheExt := Uppercase( ExtractFileExt( TheName ));
  365.   { If not an executable/image file then use FindExecutable to get icon }
  366.   if (( TheExt <> '.EXE' ) and ( TheExt <> '.BAT' ) and
  367.       ( TheExt <> '.PIF' ) and ( TheExt <> '.COM' )) then
  368.   begin
  369.     { Grab three chunks of memory }
  370.     GetMem( TheOtherPChar , 255 );
  371.     GetMem( TheResultPChar , 255 );
  372.     GetMem( ThePChar , 255 );
  373.     { Set up the name and its directory in Windows string formats }
  374.     StrPCopy( ThePChar, TheName );
  375.     StrPCopy( TheOtherPChar , ExtractFilePath( TheName ));
  376.     { Use FindExecutable API call to get path and name of owning file }
  377.     if FindExecutable( ThePChar , TheOtherPChar , TheResultPChar ) > 31 then
  378.     begin
  379.       { If get a result of 32 or more then try to get first icon of owner }
  380.       { Using ExtractIcon API call; 0 indicates first icon.               }
  381.       TheIcon.Handle := ExtractIcon( hInstance , TheResultPchar , 0 );
  382.       { If a handle is 0 then no icon in owner, get default icon from RES file }
  383.       if TheIcon.Handle = 0 then
  384.       begin
  385.         GetMem( TheOtherPChar , 255 );
  386.         StrPCopy( TheOtherPChar , 'NOICON' );
  387.         TheIcon.Handle := LoadIcon( hInstance , TheOtherPChar );
  388.         FreeMem( TheOtherPChar , 255 );
  389.         exit;
  390.       end;
  391.     end
  392.     else
  393.     { if no assigned executable, then get default icon from RES file }
  394.     begin
  395.       GetMem( TheOtherPChar , 255 );
  396.       StrPCopy( TheOtherPChar , 'NOICON' );
  397.       TheIcon.Handle := LoadIcon( hInstance , TheOtherPChar );
  398.       FreeMem( TheOtherPChar , 255 );
  399.       exit;
  400.     end;
  401.     FreeMem( TheOtherPChar , 255 );
  402.     FreeMem( TheResultPChar , 255 );
  403.     FreeMem( ThePChar , 255 );
  404.   end
  405.   else
  406.   { Assume Windows Executable file, so get icon from it with ExtractIcon API }
  407.   begin
  408.     GetMem( ThePChar , 255 );
  409.     StrPCopy( ThePChar , TheName );
  410.     { If no icons in file then get default icon (note use FFFF for -1) }
  411.     if ExtractIcon( hInstance , ThePchar , 65535 ) = 0 then
  412.     begin
  413.       Freemem( ThePChar , 255 );
  414.       GetMem( TheOtherPChar , 255 );
  415.       StrPCopy( TheOtherPChar , 'NOICON' );
  416.       TheIcon.Handle := LoadIcon( hInstance , TheOtherPChar );
  417.       FreeMem( TheOtherPChar , 255 );
  418.       exit;
  419.     end
  420.     else
  421.     begin
  422.       { Try to get first icon for file }
  423.       TheIcon.Handle := ExtractIcon( hInstance , ThePChar , 0 );
  424.       FreeMem( ThePChar , 255 );
  425.       { If handle is 0 invalid icon format so use default from RES file }
  426.       if TheIcon.Handle = 0 then
  427.       begin
  428.         GetMem( TheOtherPChar , 255 );
  429.         StrPCopy( TheOtherPChar , 'NOICON' );
  430.         TheIcon.Handle := LoadIcon( hInstance , TheOtherPChar );
  431.         FreeMem( TheOtherPChar , 255 );
  432.         exit;
  433.       end;
  434.     end;
  435.   end;
  436. end;
  437.  
  438. { This creates the TMouseManager and inits vars to null }
  439. constructor TMouseManager.Create( AOwner : TComponent );
  440. begin
  441.   { Call inherited FIRST! }
  442.   inherited Create( AOwner );
  443.   { Set all variables to 0 , false or nil }
  444.   TheMX := 0;
  445.   TheMY := 0;
  446.   Old_X  := 0;
  447.   Old_Y  := 0;
  448.   New_X  := 0;
  449.   New_Y  := 0;
  450.   StoredCursor := 0;
  451.   BitmapCursor  := false;
  452.   IconCursor    := false;
  453.   CursorBMP     := nil;
  454.   CursorIcon    := nil;
  455.   IsAnimated    := false;
  456.   TheTimer      := nil;
  457.   TheAnimationList := nil;
  458.   CurrentAnimationPointer := 0;
  459.   AnimationInterval := 0;
  460.   SavedDC := 0;
  461.   GlobalDC := 0;
  462.   GlobalCanvas := nil;
  463.   WorkSpaceBMP := nil;
  464.   BackGroundBMP := nil;
  465. end;
  466.  
  467. { This destroys the tmousemanager and releases all resources }
  468. destructor TMouseManager.Destroy;
  469. begin
  470.   { Free any assigned resources (the moving bmp ones already are gone) }
  471.   if assigned( TheTimer ) then
  472.    TheTimer.Free;
  473.   if assigned( TheAnimationList ) then
  474.    TheAnimationList.Free;
  475.   Inherited Destroy;
  476. end;
  477.  
  478. { This sets up the mouse manager for normal cursor operations }
  479. procedure TMouseManager.InitializeNormal;
  480. var TheMP : TPoint;
  481. begin
  482.   { Reset State Variables }
  483.   BitmapCursor := false;
  484.   IconCursor := false;
  485.   IsAnimated := false;
  486.   { Call API to get mouse coordinates }
  487.   GetCursorPos( TheMP );
  488.   { Store the coordinates for later use }
  489.   TheMX := TheMP.X;
  490.   TheMY := TheMP.Y;
  491.   Old_X := TheMX;
  492.   Old_Y := TheMY;
  493.   New_X := TheMX;
  494.   New_Y := TheMY;
  495. end;
  496.  
  497. { This procedure initializes a bitmap cursor }
  498. procedure TMouseManager.InitializeBitmap( TheBmp : TBitmap );
  499. begin
  500.   InitializeNormal;
  501.   CursorBMP := TheBMP;
  502.   BitmapCursor := true;
  503. end;
  504.  
  505. { This procedure initalizes an icon cursor }
  506. procedure TMouseManager.InitializeIcon( TheIcon : TIcon );
  507. begin
  508.   InitializeNormal;
  509.   CursorIcon := TheIcon;
  510.   IconCursor := true;
  511. end;
  512.  
  513. { This procedure initializes an animated icon cursor }
  514. procedure TMouseManager.InitializeAnimated( TheIcon : TIcon;
  515.            TheInterval : Integer; TheIconList : TList );
  516. begin
  517.   InitializeNormal;
  518.   CursorIcon := TheIcon;
  519.   IconCursor := true;
  520.   IsAnimated := true;
  521.   AnimationInterval := TheInterval;
  522.   TheAnimationList := TheIconList;
  523.   TheTimer := TTimer.Create( Self );
  524.   TheTimer.Enabled := false;
  525.   TheTimer.Interval := AnimationInterval;
  526.   TheTimer.OnTimer := TimerAction;
  527. end;
  528.  
  529. { This procedure returns the current stored mouse position }
  530. procedure TMouseManager.GetMousePosition( var MouseX , MouseY : Integer );
  531. begin
  532.   { Return stored position rather than call API }
  533.   MouseX := TheMX;
  534.   MouseY := TheMY;
  535. end;
  536.  
  537. { This procedure sets the Mouse Position internally }
  538. procedure TMouseManager.SetMousePosition( MouseX , MouseY : Integer );
  539. begin
  540.   { Set internal coordinates; don't call API }
  541.   TheMX := MouseX;
  542.   TheMY := MouseY;
  543. end;
  544.  
  545. { This procedure is used to drive the mouse with the keyboard }
  546. procedure TMouseManager.MoveSinglePixelLeft;
  547. begin
  548.   { Use internal coordinates and check for screen wrapping }
  549.   if TheMX > KBMJ_SINGLE then
  550.   begin
  551.     { Not wrapped; move along one unit to the left }
  552.     TheMX := TheMX - KBMJ_SINGLE;
  553.     SetCursorPos( TheMX , TheMY );
  554.   end
  555.   else
  556.   begin
  557.     { Wrapped; jump to right and move back one unit }
  558.     TheMX := Screen.Width - KBMJ_SINGLE;
  559.     SetCursorPos( TheMX , TheMY );
  560.   end;
  561. end;
  562.  
  563. { This procedure is used to drive the mouse with the keyboard }
  564. procedure TMouseManager.MoveSinglePixelRight;
  565. begin
  566.   { Use internal coordinates and check for screen wrapping }
  567.   if TheMX < ( Screen.Width - KBMJ_SINGLE ) then
  568.   begin
  569.     { Not wrapped; move along one unit to the right }
  570.     TheMX := TheMX + KBMJ_SINGLE;
  571.     SetCursorPos( TheMX , TheMY );
  572.   end
  573.   else
  574.   begin
  575.     { Wrapped; jump to left and move in one unit }
  576.     TheMX := KBMJ_SINGLE;
  577.     SetCursorPos( TheMX , TheMY );
  578.   end;
  579. end;
  580.  
  581. { This procedure is used to drive the mouse with the keyboard }
  582. procedure TMouseManager.MoveSinglePixelUp;
  583. begin
  584.   { Use internal coordinates and check for screen wrapping }
  585.   if TheMY > KBMJ_SINGLE then
  586.   begin
  587.     { Not wrapped; move along one unit to the top }
  588.     TheMY := TheMY - KBMJ_SINGLE;
  589.     SetCursorPos( TheMX , TheMY );
  590.   end
  591.   else
  592.   begin
  593.     { Wrapped; jump to bottom and move back one unit }
  594.     TheMY := Screen.Height - KBMJ_SINGLE;
  595.     SetCursorPos( TheMX , TheMY );
  596.   end;
  597. end;
  598.  
  599. { This procedure is used to drive the mouse with the keyboard }
  600. procedure TMouseManager.MoveSinglePixelDown;
  601. begin
  602.   { Use internal coordinates and check for screen wrapping }
  603.   if TheMY < ( Screen.Height - KBMJ_SINGLE ) then
  604.   begin
  605.     { Not wrapped; move along one unit to the bottom }
  606.     TheMY := TheMY + KBMJ_SINGLE;
  607.     SetCursorPos( TheMX , TheMY );
  608.   end
  609.   else
  610.   begin
  611.     { Wrapped; jump to top and move back one unit }
  612.     TheMY := KBMJ_SINGLE;
  613.     SetCursorPos( TheMX , TheMY );
  614.   end;
  615. end;
  616.  
  617. { This procedure is used to drive the mouse with the keyboard }
  618. procedure TMouseManager.MoveSmallJumpLeft;
  619. begin
  620.   { Use internal coordinates and check for screen wrapping }
  621.   if TheMX > KBMJ_SMALL then
  622.   begin
  623.     { Not wrapped; move along one unit to the left }
  624.     TheMX := TheMX - KBMJ_SMALL;
  625.     SetCursorPos( TheMX , TheMY );
  626.   end
  627.   else
  628.   begin
  629.     { Wrapped; jump to right and move back the unit }
  630.     TheMX := Screen.Width - KBMJ_SMALL;
  631.     SetCursorPos( TheMX , TheMY );
  632.   end;
  633. end;
  634.  
  635. { This procedure is used to drive the mouse with the keyboard }
  636. procedure TMouseManager.MoveSmallJumpRight;
  637. begin
  638.   { Use internal coordinates and check for screen wrapping }
  639.   if TheMX < ( Screen.Width - KBMJ_SMALL ) then
  640.   begin
  641.     { Not wrapped; move along one unit to the right }
  642.     TheMX := TheMX + KBMJ_SMALL;
  643.     SetCursorPos( TheMX , TheMY );
  644.   end
  645.   else
  646.   begin
  647.     { Wrapped; jump to left and move in one unit }
  648.     TheMX := KBMJ_SMALL;
  649.     SetCursorPos( TheMX , TheMY );
  650.   end;
  651. end;
  652.  
  653. { This procedure is used to drive the mouse with the keyboard }
  654. procedure TMouseManager.MoveSmallJumpUp;
  655. begin
  656.   { Use internal coordinates and check for screen wrapping }
  657.   if TheMY > KBMJ_SMALL then
  658.   begin
  659.     { Not wrapped; move along one unit to the top }
  660.     TheMY := TheMY - KBMJ_SMALL;
  661.     SetCursorPos( TheMX , TheMY );
  662.   end
  663.   else
  664.   begin
  665.     { Wrapped; jump to bottom and move back one unit }
  666.     TheMY := Screen.Height - KBMJ_SMALL;
  667.     SetCursorPos( TheMX , TheMY );
  668.   end;
  669. end;
  670.  
  671. { This procedure is used to drive the mouse with the keyboard }
  672. procedure TMouseManager.MoveSmallJumpDown;
  673. begin
  674.   { Use internal coordinates and check for screen wrapping }
  675.   if TheMY < ( Screen.Height - KBMJ_SMALL ) then
  676.   begin
  677.     { Not wrapped; move along one unit to the bottom }
  678.     TheMY := TheMY + KBMJ_SMALL;
  679.     SetCursorPos( TheMX , TheMY );
  680.   end
  681.   else
  682.   begin
  683.     { Wrapped; jump to top and move back one unit }
  684.     TheMY := KBMJ_SMALL;
  685.     SetCursorPos( TheMX , TheMY );
  686.   end;
  687. end;
  688.  
  689. { This procedure is used to drive the mouse with the keyboard }
  690. procedure TMouseManager.MoveLargeJumpLeft;
  691. begin
  692.   { Use internal coordinates and check for screen wrapping }
  693.   if TheMX > KBMJ_LARGE then
  694.   begin
  695.     { Not wrapped; move along the unit to the left }
  696.     TheMX := TheMX - KBMJ_LARGE;
  697.     SetCursorPos( TheMX , TheMY );
  698.   end
  699.   else
  700.   begin
  701.     { Wrapped; jump to right and move back the unit }
  702.     TheMX := Screen.Width - KBMJ_LARGE;
  703.     SetCursorPos( TheMX , TheMY );
  704.   end;
  705. end;
  706.  
  707. { This procedure is used to drive the mouse with the keyboard }
  708. procedure TMouseManager.MoveLargeJumpRight;
  709. begin
  710.   { Use internal coordinates and check for screen wrapping }
  711.   if TheMX < ( Screen.Width - KBMJ_LARGE ) then
  712.   begin
  713.     { Not wrapped; move along one unit to the right }
  714.     TheMX := TheMX + KBMJ_LARGE;
  715.     SetCursorPos( TheMX , TheMY );
  716.   end
  717.   else
  718.   begin
  719.     { Wrapped; jump to left and move in one unit }
  720.     TheMX := KBMJ_LARGE;
  721.     SetCursorPos( TheMX , TheMY );
  722.   end;
  723. end;
  724.  
  725. { This procedure is used to drive the mouse with the keyboard }
  726. procedure TMouseManager.MoveLargeJumpUp;
  727. begin
  728.   { Use internal coordinates and check for screen wrapping }
  729.   if TheMY > KBMJ_LARGE then
  730.   begin
  731.     { Not wrapped; move along one unit to the top }
  732.     TheMY := TheMY - KBMJ_LARGE;
  733.     SetCursorPos( TheMX , TheMY );
  734.   end
  735.   else
  736.   begin
  737.     { Wrapped; jump to bottom and move back one unit }
  738.     TheMY := Screen.Height - KBMJ_LARGE;
  739.     SetCursorPos( TheMX , TheMY );
  740.   end;
  741. end;
  742.  
  743. { This procedure is used to drive the mouse with the keyboard }
  744. procedure TMouseManager.MoveLargeJumpDown;
  745. begin
  746.   { Use internal coordinates and check for screen wrapping }
  747.   if TheMY < ( Screen.Height - KBMJ_LARGE ) then
  748.   begin
  749.     { Not wrapped; move along one unit to the bottom }
  750.     TheMY := TheMY + KBMJ_LARGE;
  751.     SetCursorPos( TheMX , TheMY );
  752.   end
  753.   else
  754.   begin
  755.     { Wrapped; jump to top and move back one unit }
  756.     TheMY := KBMJ_LARGE;
  757.     SetCursorPos( TheMX , TheMY );
  758.   end;
  759. end;
  760.  
  761. { This procedure sets up the bitmaps and global HDC prior to moving a }
  762. { Bitmap cursor.                                                      }
  763. procedure TMouseManager.StartBitmapCursor( TheX , TheY : Integer );
  764. var WorkingPoint1 ,
  765.     WorkingPoint2 : TPoint;
  766. begin
  767.   GlobalDC := GetDC( 0 );
  768.   WorkspaceBMP := TBitmap.Create;
  769.   WorkspaceBMP.Width := Screen.Width;
  770.   WorkSpaceBMP.Height := Screen.Height;
  771.   BitBlt( WorkspaceBMP.Canvas.Handle , 0 , 0 , Screen.Width , Screen.Height ,
  772.    GlobalDC , 0 , 0 , SrcCopy );
  773.   BackgroundBMP := TBitmap.Create;
  774.   BackgroundBMP.Width := CursorBMP.Width;
  775.   BackgroundBMP.Height := CursorBMP.Height;
  776.   New_X := TheX;
  777.   New_Y := TheY;
  778.   StoredCursor := Screen.Cursor;
  779.   Screen.Cursor := CR_NULL;
  780.   {Grab the background image}
  781.   WorkingPoint1.X := New_X - ( CursorBMP.Width div 2 );
  782.   WorkingPoint1.Y := New_Y - ( CursorBMP.Height div 2 );
  783.   WorkingPoint2.X := New_X + ( CursorBMP.Width - ( CursorBMP.Width div 2 ));
  784.   WorkingPoint2.Y := New_Y + ( CursorBMP.Height - ( CursorBMP.Height div 2 ));
  785.   BackgroundBmp.Canvas.CopyRect( Rect( 0 , 0 , CursorBMP.Width , CursorBMP.Height ) ,
  786.    WorkspaceBMP.Canvas , Rect( WorkingPoint1.X , WorkingPoint1.Y , WorkingPoint2.X ,
  787.     WorkingPoint2.Y ));
  788.   {Put the cursor bitmap onto the workspace canvas}
  789.   with WorkspaceBMP.Canvas do
  790.   begin
  791.     CopyMode := cmSrcCopy;
  792.     CopyRect( Rect( WorkingPoint1.X , WorkingPoint1.Y , WorkingPoint2.X , WorkingPoint2.Y ),
  793.      CursorBMP.Canvas , Rect( 0 , 0 , CursorBMP.Width , CursorBMP.Height ));
  794.   end;
  795.   {Copy the workspace bitmap onto the visible screen}
  796.     BitBlt( GlobalDC , WorkingPoint1.X , WorkingPoint1.Y , CursorBMP.Width , CursorBMP.Height ,
  797.      WorkspaceBMP.Canvas.Handle , WorkingPoint1.X , WorkingPoint1.Y , SrcCopy );
  798.   Old_X := New_X;
  799.   Old_Y := New_Y;
  800. end;
  801.  
  802. { This procedure moves a bitmap cursor according to the imported New coords }
  803. procedure TMouseManager.MoveBitmapCursor( TheX , TheY : Integer );
  804. var StartX,
  805.     StartY,
  806.     XDiff,
  807.     YDiff : Integer;
  808.     WorkingPoint1 ,
  809.     WorkingPoint2  : TPoint;
  810. begin
  811.   New_X := TheX;
  812.   New_Y := TheY;
  813.   WorkingPoint1.X := Old_X - ( CursorBMP.Width div 2 );
  814.   WorkingPoint1.Y := Old_Y - ( CursorBMP.Height div 2 );
  815.   WorkingPoint2.X := Old_X + ( CursorBMP.Width - ( CursorBMP.Width div 2 ));
  816.   WorkingPoint2.Y := Old_Y + ( CursorBMP.Height - ( CursorBMP.Height div 2 ));
  817.   with WorkspaceBMP.Canvas do
  818.   begin
  819.     CopyMode := cmSrcCopy;
  820.     CopyRect( Rect( WorkingPoint1.X , WorkingPoint1.Y , WorkingPoint2.X , WorkingPoint2.Y ),
  821.       BackgroundBMP.Canvas , Rect( 0 , 0 , CursorBMP.Width , CursorBMP.Height ));
  822.   end;
  823.   {Put the saved bitmap onto the workspace canvas}
  824.   with WorkspaceBMP.Canvas do
  825.   begin
  826.     CopyMode := cmSrcCopy;
  827.     CopyRect( Rect( WorkingPoint1.X , WorkingPoint1.Y , WorkingPoint2.X , WorkingPoint2.Y ),
  828.      BackgroundBMP.Canvas , Rect( 0 , 0 , CursorBMP.Width , CursorBMP.Height ));
  829.   end;
  830.   {Grab the background image}
  831.   WorkingPoint1.X := New_X - ( CursorBMP.Width div 2 );
  832.   WorkingPoint1.Y := New_Y - ( CursorBMP.Height div 2 );
  833.   WorkingPoint2.X := New_X + ( CursorBMP.Width - ( CursorBMP.Width div 2 ));
  834.   WorkingPoint2.Y := New_Y + ( CursorBMP.Height - ( CursorBMP.Height div 2 ));
  835.   BackgroundBmp.Canvas.CopyRect( Rect( 0 , 0 , CursorBMP.Width , CursorBMP.Height ) ,
  836.    WorkspaceBMP.Canvas , Rect( WorkingPoint1.X , WorkingPoint1.Y , WorkingPoint2.X ,
  837.     WorkingPoint2.Y ));
  838.   {Put the cursor bitmap onto the workspace canvas}
  839.   with WorkspaceBMP.Canvas do
  840.   begin
  841.     CopyMode := cmSrcCopy;
  842.     CopyRect( Rect( WorkingPoint1.X , WorkingPoint1.Y , WorkingPoint2.X , WorkingPoint2.Y ),
  843.      CursorBMP.Canvas , Rect( 0 , 0 , CursorBMP.Width , CursorBMP.Height ));
  844.   end;
  845.   {Copy the workspace bitmap onto the visible screen}
  846.   if New_X > Old_X then StartX := Old_X else StartX := New_X;
  847.   if New_Y > Old_Y then StartY := Old_Y else StartY := New_Y;
  848.   XDiff := Abs( Old_X - New_X );
  849.   YDiff := Abs( Old_Y - New_Y );
  850.   {Grab the background image}
  851.   WorkingPoint1.X := StartX - ( CursorBMP.Width div 2 );
  852.   WorkingPoint1.Y := StartY - ( CursorBMP.Height div 2 );
  853.   BitBlt( GlobalDC , WorkingPoint1.X , WorkingPoint1.Y , CursorBMP.Width + XDiff ,
  854.    CursorBMP.Height + YDiff , WorkspaceBMP.Canvas.Handle , WorkingPoint1.X ,
  855.     WorkingPoint1.Y , SrcCopy );
  856.   Old_X := New_X;
  857.   Old_Y := New_Y;
  858. end;
  859.  
  860. { This procedure releases a bitmap cursor and frees its DC }
  861. procedure TMouseManager.EndBitmapCursor( TheX , TheY : Integer );
  862. var WorkingPoint1 ,
  863.     WorkingPoint2 : TPoint;
  864. begin
  865.   BitmapCursor := false;
  866.   WorkingPoint1.X := Old_X - ( CursorBMP.Width div 2 );
  867.   WorkingPoint1.Y := Old_Y - ( CursorBMP.Height Div 2 );
  868.   WorkingPoint2.X := Old_X + ( CursorBMP.Width - ( CursorBMP.Width div 2 ));
  869.   WorkingPoint2.Y := Old_Y + ( CursorBMP.Height - ( CursorBMP.Height div 2 ));
  870.   {Put the saved bitmap onto the workspace canvas}
  871.   with WorkspaceBMP.Canvas do
  872.   begin
  873.     CopyMode := cmSrcCopy;
  874.     CopyRect( Rect( WorkingPoint1.X , WorkingPoint1.Y , WorkingPoint2.X , WorkingPoint2.Y ),
  875.        BackGroundBMP.Canvas , Rect( 0 , 0 , CursorBMP.Width ,  CursorBMP.Height ));
  876.   end;
  877.   {Copy the workspace bitmap onto the visible screen}
  878.   BitBlt( GlobalDC , WorkingPoint1.X , WorkingPoint1.Y , CursorBMP.Width , CursorBMP.Height ,
  879.    WorkspaceBMP.Canvas.handle , WorkingPoint1.X , WorkingPoint1.Y , SrcCopy );
  880.   ReleaseDC( 0 , GlobalDC );
  881.   Screen.Cursor := StoredCursor;
  882. end;
  883.  
  884. { This procedure starts the process of displaying an icon cursor }
  885. procedure TMouseManager.StartIconCursor( TheX , TheY : Integer );
  886. var WorkingPoint1 ,
  887.     WorkingPoint2 : TPoint;
  888. begin
  889.   GlobalDC := GetDC( 0 );
  890.   WorkspaceBMP := TBitmap.Create;
  891.   WorkspaceBMP.Width := Screen.Width;
  892.   WorkSpaceBMP.Height := Screen.Height;
  893.   BitBlt( WorkspaceBMP.Canvas.Handle , 0 , 0 , Screen.Width , Screen.Height ,
  894.    GlobalDC , 0 , 0 , SrcCopy );
  895.   BackgroundBMP := TBitmap.Create;
  896.   BackgroundBMP.Width := 33;
  897.   BackgroundBMP.Height := 33;
  898.   New_X := TheX;
  899.   New_Y := TheY;
  900.   StoredCursor := Screen.Cursor;
  901.   Screen.Cursor := CR_NULL;
  902.   {Grab the background image}
  903.   WorkingPoint1.X := New_X - 16;
  904.   WorkingPoint1.Y := New_Y - 16;
  905.   WorkingPoint2.X := New_X + 17;
  906.   WorkingPoint2.Y := New_Y + 17;
  907.   BackgroundBmp.Canvas.CopyRect( Rect( 0 , 0 , 33 , 33 ) , WorkspaceBMP.Canvas ,
  908.      Rect( WorkingPoint1.X , WorkingPoint1.Y , WorkingPoint2.X , WorkingPoint2.Y ));
  909.   {Put the icon onto the workspace canvas}
  910.   with WorkspaceBMP.Canvas do
  911.   begin
  912.     Draw( WorkingPoint1.X , WorkingPoint1.Y , CursorIcon );
  913.   end;
  914.   {Copy the workspace bitmap onto the visible screen}
  915.     BitBlt( GlobalDC , WorkingPoint1.X , WorkingPoint1.Y , 33 , 33 ,
  916.      WorkspaceBMP.Canvas.Handle , WorkingPoint1.X , WorkingPoint1.Y , SrcCopy );
  917.   Old_X := New_X;
  918.   Old_Y := New_Y;
  919. end;
  920.  
  921. { This procedure moves the icon cursor in response to mouse moves }
  922. procedure TMouseManager.MoveIconCursor( TheX , TheY : Integer );
  923. var StartX,
  924.     StartY,
  925.     XDiff,
  926.     YDiff : Integer;
  927.     WorkingPoint1 ,
  928.     WorkingPoint2  : TPoint;
  929. begin
  930.   New_X := TheX;
  931.   New_Y := TheY;
  932.   {Put the saved bitmap onto the workspace canvas}
  933.   WorkingPoint1.X := Old_X - 16;
  934.   WorkingPoint1.Y := Old_Y - 16;
  935.   WorkingPoint2.X := Old_X + 17;
  936.   WorkingPoint2.Y := Old_Y + 17;
  937.   with WorkspaceBMP.Canvas do
  938.   begin
  939.     CopyMode := cmSrcCopy;
  940.     CopyRect( Rect( WorkingPoint1.X , WorkingPoint1.Y , WorkingPoint2.X , WorkingPoint2.Y ),
  941.       BackgroundBMP.Canvas , Rect( 0 , 0 , 33 , 33 ));
  942.   end;
  943.   {Grab the background image}
  944.   WorkingPoint1.X := New_X - 16;
  945.   WorkingPoint1.Y := New_Y - 16;
  946.   WorkingPoint2.X := New_X + 17;
  947.   WorkingPoint2.Y := New_Y + 17;
  948.   BackgroundBMP.Canvas.CopyRect( Rect( 0 , 0 , 33 , 33 ) , WorkspaceBMP.Canvas ,
  949.      Rect( WorkingPoint1.X , WorkingPoint1.Y , WorkingPoint2.X , WorkingPoint2.Y ));
  950.   {Put the icon onto the workspace canvas}
  951.   with WorkspaceBMP.Canvas do
  952.   begin
  953.     Draw( WorkingPoint1.X , WorkingPoint1.Y , CursorIcon );
  954.   end;
  955.   {Copy the workspace bitmap onto the visible screen}
  956.     if New_X > Old_X then StartX := Old_X else StartX := New_X;
  957.     if New_Y > Old_Y then StartY := Old_Y else StartY := New_Y;
  958.     XDiff := Abs( Old_X - New_X );
  959.     YDiff := Abs( Old_Y - New_Y );
  960.     {Grab the background image}
  961.     WorkingPoint1.X := StartX - 16;
  962.     WorkingPoint1.Y := StartY - 16;
  963.     BitBlt( GlobalDC , WorkingPoint1.X , WorkingPoint1.Y , 33 + XDiff , 33 + YDiff ,
  964.      WorkspaceBMP.Canvas.Handle , WorkingPoint1.X , WorkingPoint1.Y , SrcCopy );
  965.   Old_X := New_X;
  966.   Old_Y := New_Y;
  967. end;
  968.  
  969. { This procedure ends the icon cursor movement and frees its DCs }
  970. procedure TMouseManager.EndIconCursor( TheX , TheY : Integer );
  971. var WorkingPoint1 ,
  972.     WorkingPoint2 : TPoint;
  973. begin
  974.   IconCursor := false;
  975.   WorkingPoint1.X := Old_X - 16;
  976.   WorkingPoint1.Y := Old_Y - 16;
  977.   WorkingPoint2.X := Old_X + 17;
  978.   WorkingPoint2.Y := Old_Y + 17;
  979.   {Put the saved bitmap onto the workspace canvas}
  980.   with WorkspaceBMP.Canvas do
  981.   begin
  982.     CopyMode := cmSrcCopy;
  983.     CopyRect( Rect( WorkingPoint1.X , WorkingPoint1.Y , WorkingPoint2.X , WorkingPoint2.Y ),
  984.        BackGroundBMP.Canvas , Rect( 0 , 0 , 33 ,  33 ));
  985.   end;
  986.   {Copy the workspace bitmap onto the visible screen}
  987.   BitBlt( GlobalDC , WorkingPoint1.X , WorkingPoint1.Y , 33 , 33 ,
  988.    WorkspaceBMP.Canvas.handle , WorkingPoint1.X , WorkingPoint1.Y , SrcCopy );
  989.   ReleaseDC( 0 , GlobalDC );
  990.   Screen.Cursor := StoredCursor;
  991. end;
  992.  
  993. { This procedure starts the animated icon cursor }
  994. procedure TMouseManager.StartAnimatedIconCursor( TheX , TheY : Integer );
  995. begin
  996.   StartIconCursor( TheX , TheY );
  997.   TheTimer.Enabled := true;
  998.   CurrentAnimationPointer := 1;
  999. end;
  1000.  
  1001. { This procedue ends the animated icon cursor }
  1002. procedure TMouseManager.EndAnimatedIconCursor( TheX , TheY : Integer );
  1003. begin
  1004.   EndIconCursor( TheX , TheY );
  1005.   TheTimer.Enabled := false;
  1006.   CursorIcon := TIcon( TheAnimationList[ 0 ] );
  1007. end;
  1008.  
  1009. { This procedure moves the animated icon cursor }
  1010. procedure TMouseManager.MoveAnimatedIconCursor( TheX , TheY : Integer );
  1011. begin
  1012.   MoveIconCursor( TheX , TheY );
  1013. end;
  1014.  
  1015. { This procedure switches icons on timer events and prompts a redraw }
  1016. procedure TMouseManager.TimerAction( Sender : TObject );
  1017. begin
  1018.   Inc( CurrentAnimationPointer );     
  1019.   if CurrentAnimationPointer > TheAnimationList.Count then
  1020.    CurrentAnimationPointer := 1;
  1021.   CursorIcon := TIcon( TheAnimationList[ CurrentAnimationPointer - 1 ] );
  1022.   MoveIconCursor( Old_X , Old_Y );
  1023. end;
  1024.  
  1025. { This function returns true if CAPSLOCK is down }
  1026. function TIoManager.IsCapsLockDown : Boolean;
  1027. begin
  1028.   if CLState then result := true else result := false;
  1029. end;
  1030.  
  1031. { This function returns true if NUMLOCK is down }
  1032. function TIoManager.ISNumLockDown : Boolean;
  1033. begin
  1034.   if NLState then result := true else result := false;
  1035. end;
  1036.  
  1037. { This function returns true if SCROLLLOCK is down }
  1038. function TIoManager.IsScrollLockDown : Boolean;
  1039. begin
  1040.   if SLState then result := true else result := false;
  1041. end;
  1042.  
  1043. { this function gets the values for CLState, NLState, and SLState }
  1044. procedure TIoManager.InitLocks;
  1045. var TheKeys : TKeyboardState;
  1046. begin
  1047.   GetKeyBoardState( TheKeys );
  1048.   CLState := (( TheKeys[ VK_Capital ] mod 2 ) = 1 );
  1049.   NLState := (( TheKeys[ VK_Numlock ] mod 2 ) = 1 );
  1050.   CLState := (( TheKeys[ VK_Scroll ] mod 2 ) = 1 );
  1051. end;
  1052.  
  1053. { This procedure returns the state of the three lock variables }
  1054. procedure TIoManager.ReadLocks( var TheCL , TheNL , TheSL : Boolean );
  1055. begin
  1056.   TheCL := CLState;
  1057.   TheNL := NLState;
  1058.   TheSL := SLState;
  1059. end;
  1060.  
  1061. { This procedure sets the state of the three lock variables to the imported vals }
  1062. procedure TIoManager.SetLocks( TheCL , TheNL , TheSL : Boolean );
  1063. var TheKeys : TKeyBoardState;
  1064. begin
  1065.   GetKeyBoardState( TheKeys );
  1066.   CLState := TheCL;
  1067.   NLState := TheNL;
  1068.   SLState := TheSL;
  1069.   if ClState then TheKeys[ VK_Capital ] := 1 else
  1070.    TheKeys[ VK_Capital ] := 0;
  1071.   if NLState then TheKeys[ VK_Numlock ] := 1 else
  1072.    TheKeys[ VK_Numlock ] := 0;
  1073.   if SLState then TheKeys[ VK_Scroll ] := 1 else
  1074.    TheKeys[ VK_Scroll ] := 0;
  1075.   SetKeyBoardState( TheKeys );
  1076. end;
  1077.  
  1078. { This procedure handles pressing of F1 for CCFileManagerForm }
  1079. procedure TIoManager.OnF1Pressed(Sender: TObject; var Key: Word;
  1080.   Shift: TShiftState);
  1081. begin
  1082.   MessageDlg( 'Help not implemented!' , mtInformation,[mbok],0);
  1083. end;
  1084.  
  1085. { This procedure handles pressing of F2 for CCFileManagerForm }
  1086. procedure TIoManager.OnF2Pressed(Sender: TObject; var Key: Word;
  1087.   Shift: TShiftState);
  1088. begin
  1089.   TCCFileMgrForm( Parent ).BitBtn1Click( Sender );
  1090. end;
  1091.  
  1092. { This procedure handles pressing of F3 for CCFileManagerForm }
  1093. procedure TIoManager.OnF3Pressed(Sender: TObject; var Key: Word;
  1094.   Shift: TShiftState);
  1095. begin
  1096.   TCCFileMgrForm( Parent ).BitBtn2Click( Sender );
  1097. end;
  1098.  
  1099. { This procedure handles pressing of F4 for CCFileManagerForm }
  1100. procedure TIoManager.OnF4Pressed(Sender: TObject; var Key: Word;
  1101.   Shift: TShiftState);
  1102. begin
  1103.   TCCFileMgrForm( Parent ).BitBtn3Click( Sender );
  1104. end;
  1105.  
  1106. { This procedure handles pressing of F5 for CCFileManagerForm }
  1107. procedure TIoManager.OnF5Pressed(Sender: TObject; var Key: Word;
  1108.   Shift: TShiftState);
  1109. begin
  1110.   TCCFileMgrForm( Parent ).BitBtn4Click( Sender );
  1111. end;
  1112.  
  1113. { This procedure handles pressing of F6 for CCFileManagerForm }
  1114. procedure TIoManager.OnF6Pressed(Sender: TObject; var Key: Word;
  1115.   Shift: TShiftState);
  1116. begin
  1117.   TCCFileMgrForm( Parent ).BitBtn5Click( Sender );
  1118. end;
  1119.  
  1120. { This procedure handles pressing of F7 for CCFileManagerForm }
  1121. procedure TIoManager.OnF7Pressed(Sender: TObject; var Key: Word;
  1122.   Shift: TShiftState);
  1123. begin
  1124.   TCCFileMgrForm( Parent ).BitBtn9Click( Sender );
  1125. end;
  1126.  
  1127. { This procedure handles pressing of F8 for CCFileManagerForm }
  1128. procedure TIoManager.OnF8Pressed(Sender: TObject; var Key: Word;
  1129.   Shift: TShiftState);
  1130. begin
  1131.   TCCFileMgrForm( Parent ).BitBtn6Click( Sender );
  1132. end;
  1133.  
  1134. { This procedure handles pressing of F9 for CCFileManagerForm }
  1135. procedure TIoManager.OnF9Pressed(Sender: TObject; var Key: Word;
  1136.   Shift: TShiftState);
  1137. begin
  1138.   TCCFileMgrForm( Parent ).BitBtn11Click( Sender );
  1139. end;
  1140.  
  1141. { This procedure handles pressing of F10 for CCFileManagerForm }
  1142. procedure TIoManager.OnF10Pressed(Sender: TObject; var Key: Word;
  1143.   Shift: TShiftState);
  1144. begin
  1145.   TCCFileMgrForm( Parent ).BitBtn7Click( Sender );
  1146. end;
  1147.  
  1148. { This procedure handles pressing of F11 for CCFileManagerForm }
  1149. procedure TIoManager.OnF11Pressed(Sender: TObject; var Key: Word;
  1150.   Shift: TShiftState);
  1151. begin
  1152.   TCCFileMgrForm( Parent ).BitBtn8Click( Sender );
  1153. end;
  1154.  
  1155. { This procedure handles pressing of F12 for CCFileManagerForm }
  1156. procedure TIoManager.OnF12Pressed(Sender: TObject; var Key: Word;
  1157.   Shift: TShiftState);
  1158. begin
  1159.   TCCFileMgrForm( Parent ).BitBtn10Click( Sender );
  1160. end;
  1161.  
  1162. { Returns True if the Left Button was pressed in the last mouse operation }
  1163. function TIOManager.WasLeftPressed : Boolean;
  1164. begin
  1165.   if ( mbLeft = WhichButton ) then WasLeftPressed := true else
  1166.    WasLeftPressed := false;
  1167. end;
  1168.  
  1169. { Returns true if the Right Button was pressed in the last mouse operation }
  1170. function TIOManager.WasRightPressed : Boolean;
  1171. begin
  1172.   if mbRight = WhichButton then WasRightPressed := true else
  1173.    WasRightPressed := false;
  1174. end;
  1175.  
  1176. { Returns true if the Middle Button was pressed in the last mouse operation }
  1177. function TIOManager.WasMiddlePressed : Boolean;
  1178. begin
  1179.   if mbMiddle = WhichButton then WasMiddlePressed := true else
  1180.    WasMiddlePressed := false;
  1181. end;
  1182.  
  1183. { Returns true if the ALT key was down during the last IO operation }
  1184. function TIOManager.WasALTPressed : Boolean;
  1185. begin
  1186.   if ssAlt in WhichState then WasALTPressed := true else
  1187.    WasALTPressed := false;
  1188. end;
  1189.  
  1190. { Returns true if either SHIFT key was down during the last IO operation }
  1191. function TIOManager.WasSHIFTPressed : Boolean;
  1192. begin
  1193.   if ssShift in WhichState then WasSHIFTPressed := true else
  1194.    WasSHIFTPressed := false;
  1195. end;
  1196.  
  1197. { Returns true if the Control Key was down during the last IO operation }
  1198. function TIOManager.WasCTRLPressed : Boolean;
  1199. begin
  1200.   if ssCtrl in WhichState then WasCTRLPressed := true else
  1201.    WasCTRLPressed := false;
  1202. end;
  1203.  
  1204.  
  1205. { This procedure does a fully error-trapped change directory }
  1206. procedure TFileWorkBench.ChangeTheDirectory( NewPath : String );
  1207. var CurrentDirectory : String;
  1208. begin
  1209.   if NewPath = '..' then
  1210.   begin { Back up one level }
  1211.     {$I+}
  1212.     try
  1213.       { Find the current directory }
  1214.       GetDir( 0 , CurrentDirectory );
  1215.       { Use EFP to move up one level }
  1216.       CurrentDirectory := ExtractFilePath( CurrentDirectory );
  1217.       { Strip trailing \ if not root }
  1218.       CurrentDirectory := StripNonRootTrailingBackSlash( CurrentDirectory );
  1219.       { Try the change to the New drive }
  1220.       ChDir( CurrentDirectory );
  1221.     except
  1222.       { if any exception occurs instantiate exception and show }
  1223.       On E:EInOutError do
  1224.       begin
  1225.         { Call custom error display/lookup procedure }
  1226.         HandleIOException( EOC_CHANGEDIR , CurrentDirectory ,
  1227.          E.Message , E.ErrorCode );
  1228.       end;
  1229.     end;
  1230.   end
  1231.   else
  1232.   begin { Change to explicit path }
  1233.     {$I+}
  1234.     try
  1235.       { Get target directory path }
  1236.       CurrentDirectory := NewPath;
  1237.       { Strip trailing \ if not root }
  1238.       CurrentDirectory := StripNonRootTrailingBackSlash( CurrentDirectory );
  1239.       { Try the change to the New drive }
  1240.       ChDir( CurrentDirectory );
  1241.     except
  1242.       { if any exception occurs instantiate exception and show }
  1243.       On E:EInOutError do
  1244.       begin
  1245.         { Call custom error display/lookup procedure }
  1246.         HandleIOException( EOC_CHANGEDIR , CurrentDirectory ,
  1247.          E.Message , E.ErrorCode );
  1248.       end;
  1249.     end;
  1250.   end;
  1251. end;
  1252.  
  1253. { This procedure does a fully error-trapped change directory }
  1254. procedure TFileWorkBench.ChangeTheDriveAndDirectory( NewDrive : Integer );
  1255. var CurrentDirectory : String;
  1256. begin
  1257.   {$I+}
  1258.   try
  1259.     { Find the working directory on New drive }
  1260.     GetDir( NewDrive , CurrentDirectory );
  1261.     { Try the change to the New drive }
  1262.     ChDir( CurrentDirectory );
  1263.   except
  1264.     { if any exception occurs instantiate exception and show }
  1265.     On E:EInOutError do
  1266.     begin
  1267.       { Call custom error display/lookup procedure }
  1268.       HandleIOException( EOC_CHANGEDIR , CurrentDirectory ,
  1269.        E.Message , E.ErrorCode );
  1270.     end;
  1271.   end;
  1272. end;
  1273.  
  1274. { This procedure copies a single file with error trapping }
  1275. procedure TFileWorkBench.CopyTheFile( OldPath , NewPath : String );
  1276. var AResult : Boolean; { Internal data flag }
  1277. begin
  1278.   { If Copyfile returns false an error occurred }
  1279.   AResult := CopyFile( OldPath , NewPath +
  1280.    ExtractFileName( OldPath ));
  1281.   { Display meaningful error message }
  1282.   if not AResult then HandleDOSError( GlobalErrorType , OldPath, GlobalError );
  1283. end;
  1284.  
  1285. { This procedure moves a file by copying and delete it }
  1286. procedure TFileWorkBench.MoveTheFile( OldPath , NewPath : String );
  1287. var AResult : Boolean; { Internal data flag }
  1288.     TheFile : File;    { Use to get errors  }
  1289. begin
  1290.   { If Copyfile returns false an error occurred }
  1291.   AResult := CopyFile( OldPath , NewPath +
  1292.     ExtractFileName( OldPath ));
  1293.   { Display meaningful error message }
  1294.   if not AResult then HandleDOSError( GlobalErrorType ,
  1295.     OldPath , GlobalError );
  1296.   { After valid copying, delete source file }
  1297.   {$I+}
  1298.   if AResult then try
  1299.     { Use this trick to get valid exception handling }
  1300.     AssignFile( TheFile , OldPath );
  1301.     { Use erase because Deletefile doesn't give exceptions! }
  1302.     Erase( TheFile );
  1303.   except
  1304.     { if any exception occurs instantiate exception and show }
  1305.     On E:EInOutError do
  1306.     begin
  1307.       { Call custom error display/lookup procedure }
  1308.       HandleIOException( EOC_DELETEFILE , OldPath ,
  1309.        E.Message , E.ErrorCode );
  1310.     end;
  1311.   end;
  1312. end;
  1313.  
  1314. { This procedure safely deletes a single file }
  1315. procedure TFileWorkBench.DeleteTheFile( ThePath : String );
  1316. var TheFile : File; { Internal file handle }
  1317. begin
  1318.   {$I+}
  1319.   try
  1320.     { Use this trick to get valid exception handling }
  1321.     AssignFile( TheFile , ThePath );
  1322.     { Use erase because Deletefile doesn't give exceptions! }
  1323.     Erase( TheFile );
  1324.   except
  1325.     { if any exception occurs instantiate exception and show }
  1326.     On E:EInOutError do
  1327.     begin
  1328.       { Call custom error display/lookup procedure }
  1329.       HandleIOException( EOC_DELETEFILE , ThePath ,
  1330.        E.Message , E.ErrorCode );
  1331.     end;
  1332.   end;
  1333. end;
  1334.  
  1335. { This procedure renames a file with full error trapping }
  1336. procedure TFileWorkBench.RenameTheFile( OldPath , NewName : String );
  1337. var TheFile : File; { Internal file handle }
  1338. begin
  1339.   {$I+}
  1340.   try
  1341.     { Use this trick to get valid exception handling }
  1342.     AssignFile( TheFile , OldPath );
  1343.     { Use this because RenameFile doesn't give exceptions! }
  1344.     Rename( TheFile , NewName );
  1345.   except
  1346.     { if any exception occurs instantiate exception and show }
  1347.     On E:EInOutError do
  1348.     begin
  1349.       { Call custom error display/lookup procedure }
  1350.       HandleIOException( EOC_RENAMEFILE , OldPath  ,
  1351.        E.Message , E.ErrorCode );
  1352.     end;
  1353.   end;
  1354. end;
  1355.  
  1356. { This procedure creates a New directory with full error trapping }
  1357. procedure TFileWorkBench.CreateNewDirectory( NewPath : String );
  1358. begin
  1359.   {$I+}
  1360.   try
  1361.     Mkdir( NewPath );
  1362.   except
  1363.     { if any exception occurs instantiate exception and show }
  1364.     On E:EInOutError do
  1365.     begin
  1366.       { Call custom error display/lookup procedure }
  1367.       HandleIOException( EOC_MAKEDIR , NewPath  ,
  1368.        E.Message , E.ErrorCode );
  1369.     end;
  1370.   end;
  1371. end;
  1372.  
  1373. { This procedure remove a directory with full error trapping }
  1374. procedure TFileWorkBench.RemoveDirectory( ThePath : String );
  1375. begin
  1376.   {$I+}
  1377.   try
  1378.     Rmdir( ThePath );
  1379.   except
  1380.     { if any exception occurs instantiate exception and show }
  1381.     On E:EInOutError do
  1382.     begin
  1383.       { Call custom error display/lookup procedure }
  1384.       HandleIOException( EOC_DELETEDIR , ThePath  ,
  1385.        E.Message , E.ErrorCode );
  1386.     end;
  1387.   end;
  1388. end;
  1389.  
  1390. { Use this to set the attributes of a file with error trapping }
  1391. procedure TFileWorkBench.SetFileAttributes( TheFile  : String;
  1392.            TheAttributes : Integer );
  1393. var TheResult : Integer; { Holds error code if any }
  1394. begin
  1395.   { Attempt to set the attributes }
  1396.   TheResult := FileSetAttr( TheFile , TheAttributes );
  1397.   { if negative number error, so signal }
  1398.   if TheResult < 0 then
  1399.    HandleDOSError( EOC_SETATTR , TheFile , -TheResult );
  1400. end;
  1401.  
  1402. { This procedure recursively copies a directory to a New path }
  1403. procedure TFileWorkBench.RecursivelyCopyDirectory( OldPath , NewPath : String );
  1404. var TheDir : String; { Holds source directory }
  1405. begin
  1406.   { Get the source directory to copy }
  1407.   TheDir := ExtractFileName( OldPath );
  1408.   { Force a backslash to the Newpath variable }
  1409.   NewPath := ForceTrailingBackSlash( NewPath );
  1410.   { Add the source directory to the target path }
  1411.   NewPath := NewPath + TheDir;
  1412.   { Create a New directory with the New name }
  1413.   CreateNewDirectory( NewPath );
  1414.   { Force a backslash for compatibility }
  1415.   NewPath := FOrcetrailingBackSlash( NewPath );
  1416.   { Do the recursive call }
  1417.   HandleRecursiveAction( OldPath , NewPath , FAC_COPY );
  1418. end;
  1419.  
  1420. { This procedure recursively moves a directory tree }
  1421. procedure TFileWorkBench.RecursivelyMoveDirectory( OldPath , NewPath : String );
  1422. var TheDir    : String; { Holds source directory  }
  1423.     SavedPath : String; { Holds saved dir to kill }
  1424. begin
  1425.   { Get the source directory to move }
  1426.   TheDir := ExtractFileName( OldPath );
  1427.   { Force a backslash to the Newpath variable }
  1428.   NewPath := ForceTrailingBackSlash( NewPath );
  1429.   { Save the starting path just in case }
  1430.   SavedPath := OldPath;
  1431.   { Add the source directory to the target path }
  1432.   NewPath := NewPath + TheDir;
  1433.   { Create a New directory with the New name }
  1434.   CreateNewDirectory( NewPath );
  1435.   { Force a backslash for compatibility }
  1436.   NewPath := FOrcetrailingBackSlash( NewPath );
  1437.   { Do the recursive call }
  1438.   HandleRecursiveAction( OldPath , NewPath , FAC_MOVE );
  1439.   { Remove the source directory }
  1440.   RemoveDirectory( SavedPath );
  1441. end;
  1442.  
  1443. { This procedure handles recursively deleting an entire directory tree }
  1444. procedure TFileWorkBench.RecursivelyDeleteDirectory( ThePath : String );
  1445. begin
  1446.   HandleRecursiveAction( ThePath , '' , FAC_DELETE );
  1447. end;
  1448.  
  1449.  
  1450. { This is the generic routine to copy, move, and delete whole directory trees }
  1451. procedure TFileWorkBench.HandleRecursiveAction( StartingPath , NewPath : String;
  1452.            ActionCode : Integer );
  1453. { VITAL!!! These variables MUST be local for recursrion to work! }
  1454. var
  1455.     Finished        : Boolean;         { Loop flag              }
  1456.     TheSR           : TSearchRec;      { Searchrecord for FF/FN }
  1457.     TheResult       : Integer;         { return variable        }
  1458.     TargetPath ,
  1459.     FileMask   ,
  1460.     TheWorkingDirectory ,
  1461.     TheStoredWorkingDirectory ,
  1462.     ModifiedDirectory  : String;       { path for FF/FN         }
  1463.     TheFIP          : TFileIconPanel;  { generic FIP holder     }
  1464.     ButtonColor   ,                    { main panel color       }
  1465.     ButtonHLColor ,                    { bright panel color     }
  1466.     ButtonSColor  ,                    { dark panel color       }
  1467.     Textcolor       : TColor;          { label text color       }
  1468.     TheFile         : File;
  1469.  
  1470. begin
  1471.   { Set up the initial variables }
  1472.   Finished := false;
  1473.   TheWorkingDirectory := StartingPath;
  1474.   TheStoredWorkingDirectory := TheWorkingDirectory;
  1475.   TheWorkingDirectory := TheWorkingDirectory + '\*.*';
  1476.   TargetPath := ExtractFilePath( TheWorkingDirectory );
  1477.   { Make the call to FindFirst set to get any file }
  1478.   TheResult := FindFirst( TheWorkingDirectory , faAnyFile , TheSR );
  1479.   { loop through all files in the directory and delete them }
  1480.   while not Finished do
  1481.   begin
  1482.     { Make call to FindNext, using only SearchRecord from FindFirst }
  1483.     TheResult := FindNext( TheSR );
  1484.     { A -1 result means no more files so exit }
  1485.     if TheResult < 0 then finished := true else
  1486.     begin
  1487.       if (( FileGetAttr( TargetPath + TheSR.Name ) and faDirectory )
  1488.        <> faDirectory ) then
  1489.       begin { A File }
  1490.         case ActionCode of
  1491.           FAC_COPY :
  1492.               begin
  1493.                 CopyTheFile( TargetPath + TheSR.Name , NewPath );
  1494.               end;
  1495.           FAC_MOVE :
  1496.               begin
  1497.                 MoveTheFile( TargetPath + TheSR.Name , NewPath );
  1498.               end;
  1499.           FAC_DELETE :
  1500.               begin { Delete }
  1501.                 if MessageDlg( 'Delete file ' + TargetPath + TheSR.Name + '?',
  1502.                    mtConfirmation , mbYesNoCancel , 0 ) = mrYes then
  1503.                     DeleteTheFile( TargetPath + TheSR.Name );
  1504.               end;
  1505.         end;
  1506.       end;
  1507.     end;
  1508.   end;
  1509.   { Call FindClose for Windows NT/Windows 95 compatibility }
  1510.   FindClose( TheSR );
  1511.   { Set up the variables to do recursive calls on all directories}
  1512.   Finished := false;
  1513.   ModifiedDirectory := TheStoredWorkingdirectory + '\*.*';
  1514.   { Make the call to FindFirst set to get any file, ignore result }
  1515.   TheResult := FindFirst( ModifiedDirectory , faDirectory , TheSR );
  1516.   while not Finished do
  1517.   begin
  1518.     { Make call to FindNext, using only SearchRecord from FindFirst }
  1519.     TheResult := FindNext( TheSR );
  1520.     { A -1 result means no more files so exit }
  1521.     if TheResult < 0 then
  1522.       finished := true
  1523.     else
  1524.     begin
  1525.       if TheSR.Name <> '..' then { Ignore backup in this case }
  1526.       begin
  1527.         if (( FileGetAttr( TargetPath + TheSR.Name ) and faDirectory )
  1528.          = faDirectory ) then
  1529.         begin
  1530.           { Send in the New directory name }
  1531.           ModifiedDirectory := TheStoredWorkingDirectory  + '\' +
  1532.            TheSR.Name;
  1533.           { Reproduce directory structure for recursion in copy/move }
  1534.           NewPath := NewPath + TheSR.Name;
  1535.           case ActionCode of
  1536.             FAC_COPY , FAC_MOVE :
  1537.                begin { Create ahead for move and copy }
  1538.                  { Make the New directory for moving and copying }
  1539.                  CreateNewDirectory( NewPath );
  1540.                  { Force a backslash for compatibility }
  1541.                  NewPath := ForceTrailingBackSlash( NewPath );
  1542.                end;
  1543.             FAC_DELETE :
  1544.                begin  { No prior action needed for Delete }
  1545.                end;
  1546.           end;
  1547.           { Do the recursive call }
  1548.           HandleRecursiveAction( ModifiedDirectory , NewPath , ActionCode );
  1549.           case ActionCode of
  1550.             FAC_COPY :
  1551.                begin { no action for copy }
  1552.                end;
  1553.             FAC_MOVE , FAC_DELETE :
  1554.                begin  { Delete }
  1555.                  { Get a confirmation }
  1556.                  if MessageDlg( 'Remove Directory ' + TargetPath + TheSR.Name
  1557.                   + '?', mtConfirmation , mbYesNoCancel , 0 ) = mrYes then
  1558.                    RemoveDirectory( TargetPath + TheSR.Name );
  1559.                end;
  1560.           end;
  1561.         end;
  1562.       end;
  1563.     end;
  1564.   end;
  1565. end;
  1566.  
  1567. { This is a generic copy routine taken from Delphi sample code }
  1568. { This function calls the sample Copy code and handles errors }
  1569. function TFileWorkBench.CopyFile( TargetPath ,
  1570.           DestinationPath : String ) : Boolean;
  1571. begin
  1572.   { Set global error value to no error }
  1573.   GlobalError := 0;
  1574.   { Call the sample procedure to do the copy }
  1575.   FMXUCopyFile( TargetPath, DestinationPath , GlobalErrorType , GlobalError );
  1576.   { If no error return true else return false }
  1577.   if GlobalError < 0 then CopyFile := false else
  1578.    CopyFile := true;
  1579. end;
  1580.  
  1581. { This procedure handles displaying a user-friendly Dialog box with a }
  1582. { Message for Delphi IO exception errors.                             }
  1583. procedure TFileWorkBench.HandleIOException( TheOpCode : Integer;
  1584.            ThePath : String; TheMessage : String; TheCode : Integer );
  1585. var ErrorMessageString : String;  { Holds internal data }
  1586.     OperationString    : String;  { Holds internal data }
  1587. begin
  1588.   { clear to check for unrecognized code }
  1589.   ErrorMessageString := '';
  1590.   { Check against imported code }
  1591.   case TheCode of
  1592.     2    : ErrorMessageString := 'File not found';
  1593.     3    : ErrorMessageString := 'Path not found';
  1594.     4    : ErrorMessageString := 'Too many open files';
  1595.     5    : ErrorMessageString := 'File access denied';
  1596.     6    : ErrorMessageString := 'Invalid file handle';
  1597.     12    : ErrorMessageString := 'Invalid file access code';
  1598.     15    : ErrorMessageString := 'Invalid drive number';
  1599.     16  : ErrorMessageString := 'Cannot remove current directory';
  1600.     17    : ErrorMessageString := 'Cannot rename across drives';
  1601.     100    : ErrorMessageString := 'Disk read error';
  1602.     101    : ErrorMessageString := 'Disk write error';
  1603.     102    : ErrorMessageString := 'File not assigned';
  1604.     103    : ErrorMessageString := 'File not open';
  1605.     104    : ErrorMessageString := 'File not open for input';
  1606.     105    : ErrorMessageString := 'File not open for output';
  1607.   end;
  1608.   case TheOpCode of
  1609.     EOC_CHANGEDIR : OperationString := 'Unable to Change Directory due to ';
  1610.     EOC_SOURCECOPY : OperationString := 'Unable to Copy due to Source File ';
  1611.     EOC_DESTCOPY : OperationString := 'Unable to Copy due to Destination File ';
  1612.     EOC_DELETEFILE : OperationString := 'Unable to Delete File due to ';
  1613.     EOC_DELETEDIR : OperationString := 'Unable to Delete Directory due to ';
  1614.     EOC_RENAMEFILE : OperationString := 'Unable to Rename File due to ';
  1615.     EOC_MAKEDIR : OperationString := 'Unable to Create New Directory due to ';
  1616.     EOC_SETATTR : OperationString := 'Unable to Set File Attributes due to ';
  1617.   end;
  1618.   { If not recognized use message; not a DOS error; reset cursor for neatness }
  1619.   if ErrorMessageString = '' then
  1620.   begin
  1621.     Screen.Cursor := crDefault;
  1622.     MessageDlg( OperationString + ExtractFileName( ThePath ) + ' ' +
  1623.      TheMessage , mtError , [mbOK],0);
  1624.   end
  1625.   else
  1626.   begin
  1627.     { Recognized DOS exception, reset cursor for neatness }
  1628.     Screen.Cursor := crDefault;
  1629.     MessageDlg( OperationString + ExtractFileName( ThePath ) + ' ' +
  1630.      ErrorMessageString , mtError , [mbOK], 0 );
  1631.   end;
  1632. end;
  1633.  
  1634. { This procedure handles displaying a user-friendly Dialog box with a }
  1635. { Message for DOS error codes.                                        }
  1636. procedure TFileWorkBench.HandleDOSError( TheOpCode : Integer;
  1637.            ThePath : String;  TheCode : Integer );
  1638. var ErrorMessageString : String;  { internal message holder }
  1639.     OperationString : String;     { internal message holder }
  1640. begin
  1641.   { clear the message holder to check for unrecognized code }
  1642.   ErrorMessageString := '';
  1643.   { Negate the code back to normal number and check to set string }
  1644.   case -TheCode of
  1645.     2    : ErrorMessageString := 'File not found';
  1646.     3    : ErrorMessageString := 'Path not found';
  1647.     4    : ErrorMessageString := 'Too many open files';
  1648.     5    : ErrorMessageString := 'File access denied';
  1649.     6    : ErrorMessageString := 'Invalid file handle';
  1650.     12    : ErrorMessageString := 'Invalid file access code';
  1651.     15    : ErrorMessageString := 'Invalid drive number';
  1652.     16  : ErrorMessageString := 'Cannot remove current directory';
  1653.     17    : ErrorMessageString := 'Cannot rename across drives';
  1654.     100    : ErrorMessageString := 'Disk read error';
  1655.     101    : ErrorMessageString := 'Disk write error';
  1656.     102    : ErrorMessageString := 'File not assigned';
  1657.     103    : ErrorMessageString := 'File not open';
  1658.     104    : ErrorMessageString := 'File not open for input';
  1659.     105    : ErrorMessageString := 'File not open for output';
  1660.     157 : ErrormessageString := 'Could not open Source File';
  1661.     159 : ErrormessageString := 'Could not open Target File';
  1662.   end;
  1663.   case TheOpCode of
  1664.     EOC_CHANGEDIR : OperationString := 'Unable to Change Directory due to ';
  1665.     EOC_SOURCECOPY : OperationString := 'Unable to Copy due to Source File ';
  1666.     EOC_DESTCOPY : OperationString := 'Unable to Copy due to Destination File ';
  1667.     EOC_DELETEFILE : OperationString := 'Unable to Delete File due to ';
  1668.     EOC_DELETEDIR : OperationString := 'Unable to Delete Directory due to ';
  1669.     EOC_RENAMEFILE : OperationString := 'Unable to Rename File due to ';
  1670.     EOC_MAKEDIR : OperationString := 'Unable to Create New Directory due to ';
  1671.     EOC_SETATTR : OperationString := 'Unable to Set File Attributes due to ';
  1672.   end;
  1673.   { If the string is empty an unrecognized code was sent in }
  1674.   if ErrorMessageString = '' then
  1675.   begin
  1676.     { Sent up db based on source or target error; reset cursor for neatness }
  1677.     Screen.Cursor := crDefault;
  1678.     MessageDlg( OperationString + ExtractFileName( ThePath ) + ' Error Code: ' +
  1679.      IntToStr( TheCode ) , mtError , [mbOK],0);
  1680.   end
  1681.   else  { Code is recognized, use message from case statement }
  1682.   begin
  1683.     { Format the output for source or target error }
  1684.     Screen.Cursor := crDefault;
  1685.     MessageDlg( OperationString + ExtractFileName( ThePath ) + ' ' +
  1686.      ErrorMessageString , mtError , [mbOK], 0 );
  1687.   end;
  1688. end;
  1689.  
  1690. { This procedure sets the imported booleans to the file's attributes }
  1691. procedure TFileWorkBench.GetFileAttributes( TheFile : String; var IsDirectory ,
  1692.            IsArchive , IsVolumeID , IsHidden , IsReadOnly ,
  1693.             IsSysFile : Boolean );
  1694. var TheResult : Integer; { Traps for error code on VolumeID }
  1695. begin
  1696.   { Clear the imported flags for default }
  1697.   IsDirectory := false;
  1698.   IsArchive := false;
  1699.   IsVolumeID := false;
  1700.   IsHidden := False;
  1701.   IsReadOnly := false;
  1702.   IsSysFile := false;
  1703.   { Make the Dos call }
  1704.   TheResult := FileGetAttr( TheFile );
  1705.   if TheResult < 0 then
  1706.   begin
  1707.     { Volume ID returns -2 (?) }
  1708.     IsVolumeID := true;
  1709.     { It has no other properties }
  1710.     exit;
  1711.   end;
  1712.   { Use AND test to set all other properties }
  1713.   if (( TheResult and faDirectory ) = faDirectory ) then IsDirectory := true;
  1714.   if (( TheResult and faArchive ) = faArchive ) then IsArchive := true;
  1715.   if (( TheResult and faVolumeID ) = faVolumeID ) then IsVolumeID := true;
  1716.   if (( TheResult and faReadOnly ) = faReadOnly ) then IsReadOnly := true;
  1717.   if (( TheResult and faHidden ) = faHidden ) then IsHidden := true;
  1718.   if (( TheResult and faSysFile ) = faSysFile ) then IsSysFile := true;
  1719. end;
  1720.  
  1721. { This function makes sure a pathname has a trailing \ }
  1722. function TFileWorkBench.ForceTrailingBackSlash(
  1723.           const TheFileName : String ) : String;
  1724. var TempString : String;  { Used to hold function result }
  1725. begin
  1726.   { If no trailing \ add one (root will already have one.) }
  1727.   if TheFileName[ Length( TheFileName ) ] <> '\' then
  1728.    TempString := TheFileName + '\' else TempString := TheFileName;
  1729.   { Return modified or non-modified string }
  1730.   ForceTrailingBackslash := TempString;
  1731. end;
  1732.  
  1733. { This function makes sure a non-root dir has no trailing \ }
  1734. function TFileWorkBench.StripNonRootTrailingBackSlash(
  1735.           const TheFileName : String ) : String;
  1736. var TempString : String ; { Used to hold function result }
  1737. begin
  1738.   { Default is no change }
  1739.   TempString := TheFileName;
  1740.   { If not root then }
  1741.   if Length( TheFileName ) > 3 then
  1742.   begin
  1743.     { If has a trailing backslash remove it }
  1744.     if TheFileName[ Length( TheFileName )] = '\' then
  1745.     begin
  1746.       TempString := Copy( TheFileName , 1 ,
  1747.        Length( TheFileName ) - 1 );
  1748.     end;
  1749.   end;
  1750.   { Export the final result }
  1751.   StripNonRootTrailingBackSlash := TempString;
  1752. end;
  1753.  
  1754. { This gets the next selected listbox item }
  1755. function TIconFileListBox.GetNextSelection( SourceDirectory : String;
  1756.           var CurrentItem : Integer ): String;
  1757. var TheResult : String;  { Internal storage }
  1758.     finished  : boolean; { Loop flag        }
  1759. begin
  1760.   { If out of items to check signal and exit }
  1761.   if CurrentItem > Items.Count then TheResult := '' else
  1762.   begin
  1763.     { Otherwise scan from current position till match or end }
  1764.     finished := false;
  1765.     while not finished do
  1766.     begin
  1767.       { Check against selected property }
  1768.       if Selected[ CurrentItem - 1 ] then
  1769.       begin
  1770.         { If selected then return it and abort loop }
  1771.         TheResult := SourceDirectory + Items[ CurrentItem - 1 ];
  1772.         finished := true;
  1773.         { Increment current position }
  1774.         CurrentItem := CurrentItem + 1;
  1775.      end
  1776.       else
  1777.       begin
  1778.         { Increment current position }
  1779.         CurrentItem := CurrentItem + 1;
  1780.         { Otherwise check for end of data and abort if out of entries }
  1781.         if CurrentItem > Items.Count then
  1782.         begin
  1783.           TheResult := '';
  1784.           finished := true;
  1785.         end;
  1786.       end;
  1787.     end;
  1788.   end;
  1789.   { Return stored result }
  1790.   GetNextSelection := TheResult;
  1791. end;
  1792.  
  1793. { Modified from VCL Source Copyright 1995 }
  1794. { Borland International, Inc.             }
  1795. { Use this to override display with icons }
  1796. procedure TIconFileListBox.ReadFileNames;
  1797. var
  1798.   AttrIndex   : TFileAttr;
  1799.   i           : Integer;
  1800.   FileExt     : string;
  1801.   MaskPtr     : PChar;
  1802.   Ptr         : PChar;
  1803.   AttrWord    : Word;
  1804.   TempPicture : TPicture;
  1805.   TempBmp     : TBitmap;
  1806.   TempIcon    : TIcon;
  1807. const
  1808.   Attributes: array[TFileAttr] of Word =
  1809.   ( DDL_READONLY , DDL_HIDDEN , DDL_SYSTEM , $0008 , DDL_DIRECTORY ,
  1810.     DDL_ARCHIVE  , DDL_EXCLUSIVE );
  1811. begin
  1812.   { if no handle allocated yet, this call will force         }
  1813.   { one to be allocated incorrectly (i.e. at the wrong time. }
  1814.   { In due time, one will be allocated appropriately.        }
  1815.   AttrWord := DDL_READWRITE;
  1816.   if HandleAllocated then
  1817.   begin
  1818.     { Set attribute flags based on values in FileType }
  1819.     for AttrIndex := ftReadOnly to ftArchive do
  1820.      if AttrIndex in FileType then
  1821.       AttrWord := AttrWord or Attributes[ AttrIndex ];
  1822.  
  1823.     { Use Exclusive bit to exclude normal files }
  1824.     if not ( ftNormal in FileType ) then
  1825.       AttrWord := AttrWord or DDL_EXCLUSIVE;
  1826.  
  1827.     ChDir( FDirectory ); { go to the directory we want }
  1828.     Clear;               { clear the list }
  1829.  
  1830.     MaskPtr := FMask;
  1831.     while MaskPtr <> nil do
  1832.     begin
  1833.       Ptr := StrScan ( MaskPtr , ';' );
  1834.       if Ptr <> nil then  Ptr^ := #0;
  1835.       { build the list }
  1836.       SendMessage( Handle , LB_DIR , AttrWord , Longint( MaskPtr ));
  1837.       if Ptr <> nil then
  1838.       begin
  1839.         Ptr^ := ';';
  1840.         Inc ( Ptr );
  1841.       end;
  1842.       MaskPtr := Ptr;
  1843.     end;
  1844.     { Now add the bitmaps }
  1845.     {---------------------------- begin custom code --------------------------}
  1846.     { Create the TPicture for exchange purposes }
  1847.     TempPicture := TPicture.Create;
  1848.     { Set it to icon widths }
  1849.     TempPicture.Bitmap.Width := 32;
  1850.     TempPicture.Bitmap.Height := 32;
  1851.     { Run down the list }
  1852.     for i := 0 to Items.Count - 1 do
  1853.     begin
  1854.       { Create a New temporary icon }
  1855.       TempIcon := TIcon.Create;
  1856.       { Call the custom DRWS routine to get icon for a file }
  1857.       GetIconForFile( Items[ i ] , TempIcon );
  1858.       { Put the icon on the bitmap for the picture via draw }
  1859.       { Note 1 , 1 due to bug in Draw?                      }
  1860.       TempPicture.Bitmap.Canvas.Draw( 1 , 1 , TempIcon );
  1861.       { Create a temporary bitmap }
  1862.       TempBmp := TBitmap.Create;
  1863.       { Set its width to those of the previous object's bitmaps }
  1864.       TempBmp.Width := 16;
  1865.       TempBmp.Height := 15;
  1866.       { Resize the icon's bitmap to the smaller size with stretchdraw }
  1867.       TempBmp.Canvas.StretchDraw( Rect( 1 , 1 , 15 , 14 ) ,
  1868.        TempPicture.Bitmap );
  1869.       { Set the Objects list to the bitmap }
  1870.       Items.Objects[ i ] := TempBmp;
  1871.       { Free the icon each iteration; don't free the TempBmp as list does }
  1872.       TempIcon.Free;
  1873.     end;
  1874.     { Free the TPicture exchange element }
  1875.     TempPicture.Free;
  1876.     {------------------------ end custom code --------------------------------}
  1877.     Change;
  1878.   end;
  1879. end;
  1880.  
  1881. { Use this to respond to dbl-clicking FLB filename }
  1882. procedure TIconFileListBox.TheDblClick(Sender: TObject);
  1883. begin
  1884.   { Call shellexec as a wrapper around ShellExecute API call }
  1885.   { False indicates failure, signal error                    }
  1886.   if not ShellExec( ExpandFileName( Items[ ItemIndex ] ), '' , '', false ,
  1887.    SW_SHOWNORMAL , false ) then MessageDlg('Could not Shell out to ' +
  1888.     Items[ ItemIndex ] , mtError, [mbOK], 0);
  1889. end;
  1890.  
  1891. { Create method for FIP                                }
  1892. constructor TIconFileListBox.Create( AOwner : TComponent );
  1893. begin
  1894.   { call inherited -- VITAL! }
  1895.   inherited Create( AOwner );
  1896.   { set the mouse method }
  1897.   OnDblClick := TheDblClick;
  1898. end;
  1899.  
  1900. { Create method for FIP                                }
  1901. constructor TFileIconPanel.Create( AOwner : TComponent );
  1902. begin
  1903.   { call inherited -- VITAL! }
  1904.   inherited Create( AOwner );
  1905.   { create icon and label components, making self owner/displayer }
  1906.   FTheIcon := TIcon.Create;
  1907.   FTheLabel := TLabel.Create( Self );
  1908.   FThelabel.Parent := Self;
  1909.   { Set own and labels mouse methods to stored methods }
  1910.   OnMouseUp := TheMouseUp;
  1911.   OnMouseDown := TheMouseDown;
  1912.   OnMouseMove := TheMouseMove;
  1913.   OnDragOver := TheDragOver;
  1914.   OnDragDrop := TheDragDrop;
  1915.   { Set alignment and autosize properties of the label }
  1916.   FTheLabel.Autosize := false;
  1917.   FTheLabel.Alignment := taCenter;
  1918.   { Set selected to false }
  1919.   Selected := false;
  1920. end;
  1921.  
  1922. procedure TFileIconPanel.WMLButtonDblClk(var Message: TWMLButtonDblClk);
  1923. var CurrentDirectory : String;    { Use to store dirs }
  1924.     TheDrive         : String;    { Get drive letter  }
  1925.     WhichDrive       : Integer;   { Get drive number  }
  1926.     ErrorCheck       : Integer;
  1927.     TheFWB           : TFileWorkBench;
  1928. begin
  1929.   { Create FileWorkBench for later use }
  1930.   TheFWB := TFileWorkBench.Create( Self );
  1931.   { Check for label or FIP sender }
  1932.   if FTheLabel.Caption = '..' then
  1933.   begin { deal with backup request }
  1934.     { Change to New directory }
  1935.     TheFWB.ChangeTheDirectory( '..' );
  1936.     { Call special method due to SendMessage problem! }
  1937.     TFileIconPanelScrollBox( Parent ).Update;
  1938.   end
  1939.   else
  1940.   begin
  1941.     { Check for DRIVE id in name }
  1942.     if Pos( 'DRIVE' , FTheName ) <> 0 then
  1943.     begin { Double Click on a Drive Icon }
  1944.       { Pull out the letter from name }
  1945.       TheDrive := Copy( FtheName , 7 , 1 );
  1946.       { Convert it to a number }
  1947.       WhichDrive := ( Ord( TheDrive[ 1 ] ) - Ord( 'A' )) + 1;
  1948.       TheFWB.ChangeTheDriveAndDirectory( WhichDrive );
  1949.       { Call special method due to SendMessage problem! }
  1950.       TFileIconPanelScrollBox( Parent ).Update;
  1951.     end
  1952.     else
  1953.     begin { Double click on a dir/file icon }
  1954.       if (( FileGetAttr( FTheName ) and faDirectory ) = faDirectory ) then
  1955.       begin { A directory, change to it }
  1956.         { Since full path in name, simply change to it! }
  1957.         TheFWB.ChangeTheDirectory( FTheName );
  1958.         { Call special method due to SendMessage problem! }
  1959.         TFileIconPanelScrollBox( Parent ).Update;
  1960.       end
  1961.       else
  1962.       begin { A file; attempt to shellexecute it }
  1963.         { Call shellexec as a wrapper around ShellExecute API call }
  1964.         { False indicates failure, signal error                    }
  1965.         if not ShellExec( FTheName , '' , '', false , SW_SHOWNORMAL , false )
  1966.          then MessageDlg('Could not Shell out to ' + FTheName , mtError,
  1967.           [mbOK], 0);
  1968.       end;
  1969.     end;
  1970.   end;
  1971.   TheFWB.Free; { This prevents resource leak }
  1972. end;
  1973.  
  1974. { Initialization method for FIP                                         }
  1975. procedure TFileIconPanel.Initialize( PanelX              ,
  1976.                                      PanelY              ,
  1977.                                      PanelWidth          ,
  1978.                                      PanelHeight         ,
  1979.                                      PanelBevelWidth     ,
  1980.                                      LabelFontSize         : Integer;
  1981.                                      PanelColor          ,
  1982.                                      PanelHighlightColor ,
  1983.                                      PanelShadowColor    ,
  1984.                                      LabelTextColor        : TColor;
  1985.                                      TheFilename         ,
  1986.                                      LabelFontName         : String;
  1987.                                      LabelFontStyle        : TFontStyles;
  1988.                                      ExtraData             : Integer );
  1989.  
  1990. var TheLabelHeight ,             { Holder for label pixel height }
  1991.     TheLabelWidth    : Integer;  { Holder for label pixel width  }
  1992.     TheOtherPChar    : PChar;    { Windows ASCIIZ string         }
  1993.     HolderBMP        : TBitmap;  { Holds working bitmap for tnail}
  1994.     HoldName         : String;
  1995.     TheBigBMP        : File_Bitmap;
  1996.     ThePCXFile       : TPCXFileObject;
  1997.     ThePChar         : PChar;
  1998.     TheBMP           : hBitmap;
  1999.     ThePalette       : hPalette;
  2000. begin
  2001.   { Set the basic properties based on imported parameters }
  2002.   Left := PanelX;
  2003.   Top := PanelY;
  2004.   Width := PanelWidth;
  2005.   Height := PanelHeight;
  2006.   Color := PanelColor;
  2007.   BevelWidth := PanelBevelWidth;
  2008.   FHighlightColor := PanelHighlightColor;
  2009.   FShadowColor := PanelShadowColor;
  2010.   FTheName := TheFilename;
  2011.   { If the ExtraData field is non-0 then a drive is being sent in }
  2012.   if ExtraData <> 0 then
  2013.   begin
  2014.     { Use the data field value to determine which icon to get from RES file }
  2015.     case ExtraData of
  2016.       1 : begin
  2017.             GetMem( TheOtherPChar , 255 );
  2018.             StrPCopy( TheOtherPChar , 'FLOPPY35' );
  2019.             FTheIcon.Handle := LoadIcon( hInstance , TheOtherPChar );
  2020.             FreeMem( TheOtherPChar , 255 );
  2021.           end;
  2022.       2 : begin
  2023.             GetMem( TheOtherPChar , 255 );
  2024.             StrPCopy( TheOtherPChar , 'FIXEDHD' );
  2025.             FTheIcon.Handle := LoadIcon( hInstance , TheOtherPChar );
  2026.             FreeMem( TheOtherPChar , 255 );
  2027.           end;
  2028.       3 : begin
  2029.             GetMem( TheOtherPChar , 255 );
  2030.             StrPCopy( TheOtherPChar , 'NETWORKHD' );
  2031.             FTheIcon.Handle := LoadIcon( hInstance , TheOtherPChar );
  2032.             FreeMem( TheOtherPChar , 255 );
  2033.           end;
  2034.       4 : begin
  2035.             GetMem( TheOtherPChar , 255 );
  2036.             StrPCopy( TheOtherPChar , 'CDROM' );
  2037.             FTheIcon.Handle := LoadIcon( hInstance , TheOtherPChar );
  2038.             FreeMem( TheOtherPChar , 255 );
  2039.           end;
  2040.       5 : begin
  2041.             GetMem( TheOtherPChar , 255 );
  2042.             StrPCopy( TheOtherPChar , 'RAM' );
  2043.             FTheIcon.Handle := LoadIcon( hInstance , TheOtherPChar );
  2044.             FreeMem( TheOtherPChar , 255 );
  2045.           end;
  2046.     end;
  2047.     { The FileNme property is already set up for the caption; use directly }
  2048.     FTheLabel.Caption := TheFilename;
  2049.     { Set up the hint for later use (make sure to set ShowHint) }
  2050.     Hint := 'Change to ' + TheFileName;
  2051.     ShowHint := true;
  2052.     { Set up all imported label properties and center it for drawing }
  2053.     with FTheLabel do
  2054.     begin
  2055.       Font.Name := LabelFontName;
  2056.       Font.Size := LabelFontSize;
  2057.       Font.Style := LabelFontStyle;
  2058.       Font.Color := LabelTextColor;
  2059.       Canvas.Brush.Color := PanelColor;
  2060.       Canvas.Font := Font;
  2061.       TheLabelHeight := Canvas.Textheight( Caption ) + 4;
  2062.       TheLabelWidth := Canvas.Textwidth( Caption ) + 4;
  2063.       Left := (( Self.Width - TheLabelWidth ) div 2 ) + 1;
  2064.       Top := ((( Round( Self.Height * 0.25 ) - 6 ) - TheLabelHeight) div 2) + 1;
  2065.       Top := Top + Round( Self.Height * 0.75 );
  2066.       Height := TheLabelHeight;
  2067.       Width := TheLabelWidth;
  2068.     end;
  2069.   end
  2070.   else
  2071.   begin
  2072.     { A file or directory has been sent in; use GetIconForFile to obtain an }
  2073.     { icon either from the file, its owner, or a RES file default.          }
  2074.     GetIconForFile( FTheName , FTheIcon );
  2075.     { Check for the Backup caption and set it specially }
  2076.     if ExtractfileName( FThename ) = '..' then
  2077.     begin
  2078.       FTheLabel.Caption := '..';
  2079.       Hint := 'Up One Level';
  2080.     end
  2081.     else
  2082.     begin
  2083.       if Uppercase( ExtractFileExt( FTheName )) = '.BMP' then
  2084.       begin
  2085.         HoldName := ExtractFileName( FTheName );
  2086.         HoldName := Copy( HoldName, 1 , Length( HoldName ) - 4 );
  2087.         HoldName := HoldName + '.THU';
  2088.         HoldName := ExpandFileName( HoldName );
  2089.         if FileExists( HoldName ) then
  2090.         begin
  2091.           FTheBMP := TBitmap.Create;
  2092.           FTheBMP.LoadFromFile( HoldName );
  2093.         end
  2094.         else
  2095.         begin
  2096.           TheBigBMP := File_Bitmap.Create;
  2097.           TheBigBMP.Initialize( FTheName );
  2098.           if TheBigBMP.Load_Bitmap_File then
  2099.           begin
  2100.             HolderBMP := TBitmap.Create;
  2101.             HolderBMP.Handle := TheBigBMP.Get_Bitmap;
  2102.             FTheBMP := CreateBitmapThumbNailFromBitmap( HolderBMP , ThumbNailWidth ,
  2103.              ThumbNailHeight );
  2104.             HolderBMP.Free;
  2105.             FTheBMP.SaveToFile( HoldName );
  2106.           end
  2107.           else
  2108.           begin
  2109.             MessageDlg( 'Unable to Load ' + FTheName + ' Due to Code ' +
  2110.              IntToStr( TheBigBMP.Get_Error_Status ),mtError,[mbok],0);
  2111.             FTheBMP := Nil;
  2112.           end;
  2113.           TheBigBMP.Free;
  2114.         end;
  2115.         FTheLabel.caption := ExtractFileName( UpperCase( FTheName ));
  2116.         Hint := FTheName;
  2117.       end
  2118.       else
  2119.       begin
  2120.         if Uppercase( ExtractFileExt( FTheName )) = '.PCX' then
  2121.         begin
  2122.           HoldName := ExtractFileName( FTheName );
  2123.           HoldName := Copy( HoldName, 1 , Length( HoldName ) - 4 );
  2124.           HoldName := HoldName + '.THU';
  2125.           HoldName := ExpandFileName( HoldName );
  2126.           if FileExists( HoldName ) then
  2127.           begin
  2128.             FTheBMP := TBitmap.Create;
  2129.             FTheBMP.LoadFromFile( HoldName );
  2130.           end
  2131.           else
  2132.           begin
  2133.             ThePCXFile := TPCXFileObject.Create;
  2134.             GetMem( ThePChar , 256 );
  2135.             StrPCopy( ThePChar , FTheName );
  2136.             ThePCXFile.Init( ThePChar );
  2137.             FreeMem( ThePChar , 256 );
  2138.             ThePCXFile.LoadPCXBitmap( TheBMP , ThePalette );
  2139.             HolderBMP := TBitmap.Create;
  2140.             HolderBMP.Handle := TheBMP;
  2141.             HolderBMP.Palette := ThePalette;
  2142.             if ThePCXFile.ErrorString = 'OK' then
  2143.             begin
  2144.               ThePCXFile.Free;
  2145.               FTheBMP := CreateBitmapThumbNailFromBitmap( HolderBMP , ThumbNailWidth ,
  2146.               ThumbNailHeight );
  2147.               HolderBMP.Free;
  2148.               FTheBMP.SaveToFile( HoldName );
  2149.             end
  2150.             else
  2151.             begin
  2152.               MessageDlg( 'Unable to Load ' + FTheName + ' Due to Code ' +
  2153.                ThePCXFile.ErrorString , mtError,[mbok],0);
  2154.               FTheBMP := Nil;
  2155.               ThePCXFile.Free;
  2156.             end;
  2157.           end;
  2158.           FTheLabel.caption := ExtractFileName( UpperCase( FTheName ));
  2159.           Hint := FTheName;
  2160.         end
  2161.         else
  2162.         begin
  2163.           { Otherwise just get the filename for the label caption }
  2164.           { And the full path for the hint (used later.)          }
  2165.           FTheLabel.caption := ExtractFileName( UpperCase( FTheName ));
  2166.           Hint := FTheName;
  2167.         end;
  2168.       end;
  2169.     end;
  2170.     { Activate showhint so hints are seen }
  2171.     ShowHint := true;
  2172.     { Set label properties with imported values and center for display }
  2173.     with FTheLabel do
  2174.     begin
  2175.       Font.Name := LabelFontName;
  2176.       Font.Size := LabelFontSize;
  2177.       Font.Style := LabelFontStyle;
  2178.       Font.Color := LabelTextColor;
  2179.       Canvas.Brush.Color := PanelColor;
  2180.       Canvas.Font := Font;
  2181.       TheLabelHeight := Canvas.Textheight( Caption ) + 4;
  2182.       TheLabelWidth := Canvas.Textwidth( Caption ) + 4;
  2183.       Left := (( Self.Width - TheLabelWidth ) div 2 ) + 1;
  2184.       Top := ((( Round( Self.Height * 0.25 ) - 6 ) - TheLabelHeight) div 2) + 1;
  2185.       Top := Top + Round( Self.Height * 0.75 );
  2186.       Height := TheLabelHeight;
  2187.       Width := TheLabelWidth;
  2188.     end;
  2189.   end;
  2190. end;
  2191.  
  2192. { Destroy method for FIP }
  2193. destructor TFileIconPanel.Destroy;
  2194. begin
  2195.   { free component resources }
  2196.   if assigned( FTheIcon ) then FTheIcon.Free;
  2197.   FTheLabel.Free;
  2198.   if Assigned( FTheBMP ) then FTheBMP.Free;
  2199.   { call inherited -- VITAL! }
  2200.   inherited Destroy;
  2201. end;
  2202.  
  2203. { Mousedown method for FIP; used to allow dragging }
  2204. procedure TFileIconPanel.TheMouseDown(Sender: TObject;
  2205.   Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
  2206. var ThePoint , TheOtherPoint : TPoint;
  2207. begin
  2208.   { Begin a conditional drag operation (false allows timer) }
  2209.   TheIOManager.WhichButton := Button;
  2210.   TheIOManager.WhichState := Shift;
  2211.   { Currently ignore drive clicks }
  2212.   if Pos( 'DRIVE' , FTheName ) > 0 then exit;
  2213.   if (( Button = mbRight ) and ( ssShift in Shift )) then
  2214.   begin
  2215.     TheTempBitmap := TBitmap.Create;
  2216.     TheTempBitmap.Width := Self.Width;
  2217.     TheTempBitmap.Height := Self.Height;
  2218.     TheTempBitmap.Canvas.Copyrect( Rect( 0 , 0 , Self.Width , Self.Height ) ,
  2219.      Self.Canvas , Rect( 0 , 0 , Self.Width , Self.Height ));
  2220.     TheMouseManager.InitializeBitmap( TheTempBitmap );
  2221.     ThePoint.X := X;
  2222.     ThePoint.Y := Y;
  2223.     TheOtherPoint := ClientToScreen( ThePoint );
  2224.     TheMouseManager.StartBitmapCursor( TheOtherPoint.X , TheOtherPoint.Y );
  2225.     BitmapDragging := true;
  2226.     GlobalSource := Self;
  2227.     exit;
  2228.   end;
  2229.   if Button = mbRight then
  2230.   begin
  2231.     TheMouseManager.InitializeIcon( FTheIcon );
  2232.     ThePoint.X := X;
  2233.     ThePoint.Y := Y;
  2234.     TheOtherPoint := ClientToScreen( ThePoint );
  2235.     TheMouseManager.StartIconCursor( TheOtherPoint.X , TheOtherPoint.Y );
  2236.     IconDragging := true;
  2237.     GlobalSource := Self;
  2238.     exit;
  2239.   end;
  2240.   BeginDrag( false );
  2241.   { Flip status of bevels }
  2242.   if BevelOuter = bvRaised then BevelOuter := bvLowered else
  2243.    BevelOuter := bvRaised;
  2244.   { Flip selected variable }
  2245.   Selected := not Selected;
  2246.   { Set redisplay }
  2247. end;
  2248.  
  2249. procedure TFileIconPanel.TheMouseMove(Sender: TObject; Shift: TShiftState;
  2250.   X, Y: Integer);
  2251. var ThePoint, TheOtherPoint : TPoint;
  2252. begin
  2253.   if IconDragging then
  2254.   begin
  2255.     ThePoint.X := X;
  2256.     ThePoint.Y := Y;
  2257.     TheOtherPoint := ClientToScreen( ThePoint );
  2258.     TheMouseManager.MoveIconCursor( TheOtherPoint.X , TheOtherPoint.Y );
  2259.     exit;
  2260.   end;
  2261.   if BitmapDragging then
  2262.   begin
  2263.     ThePoint.X := X;
  2264.     ThePoint.Y := Y;
  2265.     TheOtherPoint := ClientToScreen( ThePoint );
  2266.     TheMouseManager.MoveBitmapCursor( TheOtherPoint.X , TheOtherPoint.Y );
  2267.     exit;
  2268.   end;
  2269. end;
  2270.  
  2271. { Mouseup Method for FIP; used to allow dragging }
  2272. procedure TFileIconPanel.TheMouseUp(Sender: TObject;
  2273.   Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
  2274. begin
  2275.   if IconDragging then
  2276.   begin
  2277.     TheMouseManager.EndIconCursor( X , Y );
  2278.     IconDragging := false;
  2279.     if GlobalSource <> Self then
  2280.     begin { Right-drag onto a panel! }
  2281.       TheDragDrop( Sender , GlobalSource , X , Y );
  2282.     end;
  2283.     exit;
  2284.   end;
  2285.   if BitmapDragging then
  2286.   begin
  2287.     TheMouseManager.EndBitmapCursor( X , Y );
  2288.     BitmapDragging := false;
  2289.     if GlobalSource <> Self then
  2290.     begin { Right-drag onto a panel! }
  2291.       TheDragDrop( Sender , GlobalSource , X , Y );
  2292.     end;
  2293.     exit;
  2294.   end;
  2295.   { End a drag operation without dropping; if dragged OK }
  2296.   { already handled.                                     }
  2297.   EndDrag( false );
  2298.   { If the right button is clicked, perform magic! }
  2299.   { Redisplay on general principles }
  2300.   Invalidate;
  2301. end;
  2302.  
  2303. { Use this to generically OK DnD from FIPs }
  2304. procedure TFileIconPanel.TheDragOver(Sender, Source: TObject; X,
  2305.   Y: Integer; State: TDragState; var Accept: Boolean);
  2306. begin
  2307.   { Only accept from FileIconPanel components }
  2308.   if Source is TFileIconPanel then Accept := true else Accept := false;
  2309. end;
  2310.  
  2311. { Use this to accept Drag and Drop from other FIPs }
  2312. procedure TFileIconPanel.TheDragDrop(Sender, Source: TObject; X,
  2313.   Y: Integer);
  2314. var CurrentName ,                 { Holds work name}
  2315.     TheOldString : String;        { Holds Dir      }
  2316.     TargetDir    : String;        { target of op   }
  2317.     TheResult       : Integer;    { Modal res hold }
  2318.     SourceDirectory,
  2319.     TargetDirectory,
  2320.     CurrentDirectory : String;    { Use to store dirs }
  2321.     TheDrive         : String;    { Get drive letter  }
  2322.     WhichDrive       : Integer;   { Get drive number  }
  2323.     ErrorCheck       : Integer;
  2324.     TheFWB           : TFileWorkBench;
  2325.     ThePosition : Integer;
  2326.     Finished : Boolean;
  2327.     TheFIPSB : TFileIconPanelScrollBox;
  2328. begin
  2329.   { If drop target is .. then ignore }
  2330.   if FTheLabel.Caption = '..' then exit;
  2331.   { Likewise ignore Dnd from drive icons }
  2332.   if Pos( 'DRIVE' , TFileIconPanel( Source ).FtheName ) > 0 then exit;
  2333.   { Obtain the parent of the source FIP; may not be self }
  2334.   TheFIPSB := TFileIconPanelScrollBox( TFileIconPanel( Source ).Parent );
  2335.   { Obtain source directory either as Dir or filepath }
  2336.   if (( FileGetAttr( TFileIconPanel( Source ).FTheName )
  2337.    and faDirectory ) = faDirectory ) then
  2338.   begin  { Directory; take whole path }
  2339.     SourceDirectory := TFileIconPanel( Source ).FTheName;
  2340.   end
  2341.   else
  2342.   begin { File; get pathname }
  2343.     SourceDirectory := ExtractFilePath( TFileIconPanel( Source ).FTheName );
  2344.   end;
  2345.   Sourcedirectory := TheFIPSB.TheFWB.ForceTrailingBackSlash( SourceDirectory );
  2346.   if Pos( 'DRIVE' , FTheName ) > 0 then
  2347.   begin { Drop onto a drive icon; perform action to its default dir }
  2348.     { Pull out the letter from name }
  2349.     TheDrive := Copy( FtheName , 7 , 1 );
  2350.     { Convert it to a number }
  2351.     WhichDrive := ( Ord( TheDrive[ 1 ] ) - Ord( 'A' )) + 1;
  2352.     { Determine the target directory and drive }
  2353.     GetDir( WhichDrive , TargetDirectory );
  2354.     TargetDirectory := TheFIPSB.TheFWB.ForceTrailingbackSlash( TargetDirectory );
  2355.     { Check for shift to operate on all selections }
  2356.     if TheIOManager.WasSHIFTPressed then
  2357.     begin { Operate on all selections }
  2358.       { Obtain the parent directory of the FIP dragged over }
  2359.       SourceDirectory := ExtractFilePath( TFileIconPanel( Source ).FTheName );
  2360.       SourceDirectory := TheFIPSB.TheFWB.ForceTrailingBackslash( SourceDirectory );
  2361.       { If SourceDir subset of TargetDir then abort; recursive failure }
  2362.       if Pos( SourceDirectory , TargetDirectory ) > 0 then
  2363.       begin
  2364.         MessageDlg( 'Cannot drag to same directory!',mtError,[mbOK],0 );
  2365.         exit;
  2366.       end;
  2367.       if TargetDirectory[ 1 ] <> SourceDirectory[ 1 ] then
  2368.       begin { Copy to different drives }
  2369.         if TheIOManager.WasALTPressed then
  2370.         begin { ALT overrides and does move }
  2371.           { Set up to get all current selections }
  2372.           ThePosition := 1;
  2373.           finished := false;
  2374.           while not finished do
  2375.           begin
  2376.             CurrentName := TheFIPSB.GetNextSelection( SourceDirectory ,
  2377.                    ThePosition );
  2378.             { If returns blank string then out of selections }
  2379.             if CurrentName = '' then finished := true else
  2380.             begin
  2381.               { If a directory signal error }
  2382.               if (( FileGetAttr( CurrentName ) and faDirectory ) = faDirectory ) then
  2383.               begin
  2384.                 if MessageDlg( 'Move Directory ' + CurrentName + ' to ' +
  2385.                  TargetDirectory + '?' , mtConfirmation , mbYesNoCancel , 0 ) = mrYes then
  2386.                   TheFIPSB.TheFWB.RecursivelyMoveDirectory( CurrentName ,
  2387.                    TargetDirectory );
  2388.               end
  2389.               else
  2390.               begin
  2391.                 TheFIPSB.TheFWB.MoveTheFile( CurrentName , TargetDirectory );
  2392.               end;
  2393.             end;
  2394.             { Reset to normal cursor }
  2395.             Screen.Cursor := crDefault;
  2396.           end;
  2397.         end
  2398.         else
  2399.         begin { Default is to do copy like file manager }
  2400.           { Set up to get all current selections }
  2401.           ThePosition := 1;
  2402.           finished := false;
  2403.           while not finished do
  2404.           begin
  2405.              CurrentName := TheFIPSB.GetNextSelection( SourceDirectory ,
  2406.                    ThePosition );
  2407.             { If returns blank string then out of selections }
  2408.             if CurrentName = '' then finished := true else
  2409.             begin
  2410.               { If a directory signal error }
  2411.               if (( FileGetAttr( CurrentName ) and faDirectory ) = faDirectory ) then
  2412.               begin
  2413.                 if MessageDlg( 'Copy Directory ' + CurrentName + ' to ' +
  2414.                  TargetDirectory + '?' , mtConfirmation , mbYesNoCancel , 0 ) = mrYes then
  2415.                   TheFIPSB.TheFWB.RecursivelyCopyDirectory( CurrentName ,
  2416.                    TargetDirectory );
  2417.               end
  2418.               else
  2419.               begin
  2420.                 TheFIPSB.TheFWB.CopyTheFile( CurrentName , TargetDirectory );
  2421.               end;
  2422.             end;
  2423.             { Reset to normal cursor }
  2424.             Screen.Cursor := crDefault;
  2425.           end;
  2426.         end;
  2427.       end
  2428.       else
  2429.       begin { Copy to same drive }
  2430.         if TheIOManager.WasCTRLPressed then
  2431.         begin { CTRL overrides and does copy }
  2432.           { Set up to get all current selections }
  2433.           ThePosition := 1;
  2434.           finished := false;
  2435.           while not finished do
  2436.           begin
  2437.             CurrentName := TheFIPSB.GetNextSelection( SourceDirectory ,
  2438.                    ThePosition );
  2439.             { If returns blank string then out of selections }
  2440.             if CurrentName = '' then finished := true else
  2441.             begin
  2442.               { If a directory signal error }
  2443.               if (( FileGetAttr( CurrentName ) and faDirectory ) = faDirectory ) then
  2444.               begin
  2445.                 if MessageDlg( 'Copy Directory ' + CurrentName + ' to ' +
  2446.                  TargetDirectory + '?' , mtConfirmation , mbYesNoCancel , 0 ) = mrYes then
  2447.                   TheFIPSB.TheFWB.RecursivelyCopyDirectory( CurrentName ,
  2448.                    TargetDirectory );
  2449.               end
  2450.               else
  2451.               begin
  2452.                 TheFIPSB.TheFWB.CopyTheFile( CurrentName , TargetDirectory );
  2453.               end;
  2454.             end;
  2455.             { Reset to normal cursor }
  2456.             Screen.Cursor := crDefault;
  2457.           end;
  2458.         end
  2459.         else
  2460.         begin { Default is to do move like file manager }
  2461.           { Set up to get all current selections }
  2462.           ThePosition := 1;
  2463.           finished := false;
  2464.           while not finished do
  2465.           begin
  2466.             CurrentName := TheFIPSB.GetNextSelection( SourceDirectory ,
  2467.                    ThePosition );
  2468.             { If returns blank string then out of selections }
  2469.             if CurrentName = '' then finished := true else
  2470.             begin
  2471.               { If a directory signal error }
  2472.               if (( FileGetAttr( CurrentName ) and faDirectory ) = faDirectory ) then
  2473.               begin
  2474.                 if MessageDlg( 'Move Directory ' + CurrentName + ' to ' +
  2475.                  TargetDirectory + '?' , mtConfirmation , mbYesNoCancel , 0 ) = mrYes then
  2476.                   TheFIPSB.TheFWB.RecursivelyMoveDirectory( CurrentName ,
  2477.                    TargetDirectory );
  2478.               end
  2479.               else
  2480.               begin
  2481.                 TheFIPSB.TheFWB.MoveTheFile( CurrentName , TargetDirectory );
  2482.               end;
  2483.             end;
  2484.             { Reset to normal cursor }
  2485.             Screen.Cursor := crDefault;
  2486.           end;
  2487.         end;
  2488.       end;
  2489.     end
  2490.     else
  2491.     begin { Operate on only source }
  2492.       if TargetDirectory[ 1 ] <> SourceDirectory[ 1 ] then
  2493.       begin { Copy to different drives }
  2494.         if TheIOManager.WasALTPressed then
  2495.         begin { ALT overrides and does move }
  2496.           with Source as TFileIconPanel do
  2497.           begin
  2498.             if MessageDlg( 'Move ' + FTheName + ' to ' +
  2499.              TargetDirectory + '?' , mtConfirmation , mbYesNoCancel , 0 ) = mrYes then
  2500.               TheFIPSB.TheFWB.MoveTheFile( FTheName , TargetDirectory );
  2501.           end;
  2502.         end
  2503.         else
  2504.         begin { Default is to do copy like file manager }
  2505.           with Source as TFileIconPanel do
  2506.           begin
  2507.             if MessageDlg( 'Copy ' + FTheName + ' to ' +
  2508.              TargetDirectory + '?' , mtConfirmation , mbYesNoCancel , 0 ) = mrYes then
  2509.               TheFIPSB.TheFWB.CopyTheFile( FtheName , TargetDirectory );
  2510.           end;
  2511.         end;
  2512.       end
  2513.       else
  2514.       begin { Copy to same drive }
  2515.         if TheIOManager.WasCTRLPressed then
  2516.         begin { CTRL overrides and does copy }
  2517.           with Source as TFileIconPanel do
  2518.           begin
  2519.             if MessageDlg( 'Copy ' + FTheName + ' to ' +
  2520.              TargetDirectory + '?' , mtConfirmation , mbYesNoCancel , 0 ) = mrYes then
  2521.               TheFIPSB.TheFWB.CopyTheFile( FTheName , TargetDirectory );
  2522.           end;
  2523.         end
  2524.         else
  2525.         begin { Default is to do move like file manager }
  2526.           with Source as TFileIconPanel do
  2527.           begin
  2528.             if MessageDlg( 'Move ' + FTheName + ' to ' +
  2529.              TargetDirectory + '?' , mtConfirmation , mbYesNoCancel , 0 ) = mrYes then
  2530.              TheFIPSB.TheFWB.MoveTheFile( FtheName , TargetDirectory );
  2531.           end;
  2532.         end;
  2533.       end;
  2534.     end;
  2535.   end
  2536.   else
  2537.   begin { Drop onto dir or file icon }
  2538.     if (( FileGetAttr( FTheName ) and faDirectory ) = faDirectory ) then
  2539.     begin { Drop onto a directory; use its path as target }
  2540.       TargetDirectory := FTheName;
  2541.     end
  2542.     else
  2543.     begin { Drop onto a file; use its parent as target }
  2544.       TargetDirectory := ExtractFilePath( FTheName );
  2545.     end;
  2546.     Targetdirectory := TheFIPSB.TheFWB.ForceTrailingbackslash( TargetDirectory );
  2547.     { Check for shift to operate on all selections }
  2548.     if TheIOManager.WasSHIFTPressed then
  2549.     begin { Operate on all selections }
  2550.       { Obtain the parent directory of the FIP dragged over }
  2551.       SourceDirectory := ExtractFilePath( TFileIconPanel( Source ).FTheName );
  2552.       SourceDirectory := TheFIPSB.TheFWB.ForceTrailingBackslash( SourceDirectory );
  2553.       { If SourceDir subset of TargetDir then abort; recursive failure }
  2554.       if Pos( SourceDirectory , TargetDirectory ) > 0 then
  2555.       begin
  2556.         MessageDlg( 'Cannot drag to same directory!',mtError,[mbOK],0 );
  2557.         exit;
  2558.       end;
  2559.       if TargetDirectory[ 1 ] <> SourceDirectory[ 1 ] then
  2560.       begin { Copy to different drives }
  2561.         if TheIOManager.WasALTPressed then
  2562.         begin { ALT overrides and does move }
  2563.           { Set up to get all current selections }
  2564.           ThePosition := 1;
  2565.           finished := false;
  2566.           while not finished do
  2567.           begin
  2568.              CurrentName := TheFIPSB.GetNextSelection( SourceDirectory ,
  2569.                    ThePosition );
  2570.             { If returns blank string then out of selections }
  2571.             if CurrentName = '' then finished := true else
  2572.             begin
  2573.               { If a directory signal error }
  2574.               if (( FileGetAttr( CurrentName ) and faDirectory ) = faDirectory ) then
  2575.               begin
  2576.                 if MessageDlg( 'Move Directory ' + CurrentName + ' to ' +
  2577.                  TargetDirectory + '?' , mtConfirmation , mbYesNoCancel , 0 ) = mrYes then
  2578.                   TheFIPSB.TheFWB.RecursivelyMoveDirectory( CurrentName ,
  2579.                    TargetDirectory );
  2580.               end
  2581.               else
  2582.               begin
  2583.                 TheFIPSB.TheFWB.MoveTheFile( CurrentName , TargetDirectory );
  2584.               end;
  2585.             end;
  2586.             { Reset to normal cursor }
  2587.             Screen.Cursor := crDefault;
  2588.           end;
  2589.         end
  2590.         else
  2591.         begin { Default is to do copy like file manager }
  2592.           { Set up to get all current selections }
  2593.           ThePosition := 1;
  2594.           finished := false;
  2595.           while not finished do
  2596.           begin
  2597.             CurrentName := TheFIPSB.GetNextSelection( SourceDirectory ,
  2598.                    ThePosition );
  2599.             { If returns blank string then out of selections }
  2600.             if CurrentName = '' then finished := true else
  2601.             begin
  2602.               { If a directory signal error }
  2603.               if (( FileGetAttr( CurrentName ) and faDirectory ) = faDirectory ) then
  2604.               begin
  2605.                 if MessageDlg( 'Copy Directory ' + CurrentName + ' to ' +
  2606.                  TargetDirectory + '?' , mtConfirmation , mbYesNoCancel , 0 ) = mrYes then
  2607.                   TheFIPSB.TheFWB.RecursivelyCopyDirectory( CurrentName ,
  2608.                    TargetDirectory );
  2609.               end
  2610.               else
  2611.               begin
  2612.                 TheFIPSB.TheFWB.CopyTheFile( CurrentName , TargetDirectory );
  2613.               end;
  2614.             end;
  2615.             { Reset to normal cursor }
  2616.             Screen.Cursor := crDefault;
  2617.           end;
  2618.         end;
  2619.       end
  2620.       else
  2621.       begin { Copy to same drive }
  2622.         if TheIOManager.WasCTRLPressed then
  2623.         begin { CTRL overrides and does copy }
  2624.           { Set up to get all current selections }
  2625.           ThePosition := 1;
  2626.           finished := false;
  2627.           while not finished do
  2628.           begin
  2629.             { Call generic file getting routine based on current view}
  2630.              CurrentName := TheFIPSB.GetNextSelection( SourceDirectory ,
  2631.                    ThePosition );
  2632.             { If returns blank string then out of selections }
  2633.             if CurrentName = '' then finished := true else
  2634.             begin
  2635.               { If a directory signal error }
  2636.               if (( FileGetAttr( CurrentName ) and faDirectory ) = faDirectory ) then
  2637.               begin
  2638.                 if MessageDlg( 'Copy Directory ' + CurrentName + ' to ' +
  2639.                  TargetDirectory + '?' , mtConfirmation , mbYesNoCancel , 0 ) = mrYes then
  2640.                   TheFIPSB.TheFWB.RecursivelyCopyDirectory( CurrentName ,
  2641.                    TargetDirectory );
  2642.               end
  2643.               else
  2644.               begin
  2645.                 TheFIPSB.TheFWB.CopyTheFile( CurrentName , TargetDirectory );
  2646.               end;
  2647.             end;
  2648.             { Reset to normal cursor }
  2649.             Screen.Cursor := crDefault;
  2650.           end;
  2651.         end
  2652.         else
  2653.         begin { Default is to do move like file manager }
  2654.           { Set up to get all current selections }
  2655.           ThePosition := 1;
  2656.           finished := false;
  2657.           while not finished do
  2658.           begin
  2659.             { Call generic file getting routine based on current view}
  2660.               CurrentName := TheFIPSB.GetNextSelection( SourceDirectory ,
  2661.                    ThePosition );
  2662.             { If returns blank string then out of selections }
  2663.             if CurrentName = '' then finished := true else
  2664.             begin
  2665.               { If a directory signal error }
  2666.               if (( FileGetAttr( CurrentName ) and faDirectory ) = faDirectory ) then
  2667.               begin
  2668.                 if MessageDlg( 'Move Directory ' + CurrentName + ' to ' +
  2669.                  TargetDirectory + '?' , mtConfirmation , mbYesNoCancel , 0 ) = mrYes then
  2670.                   TheFIPSB.TheFWB.RecursivelyMoveDirectory( CurrentName ,
  2671.                    TargetDirectory );
  2672.               end
  2673.               else
  2674.               begin
  2675.                 TheFIPSB.TheFWB.MoveTheFile( CurrentName , TargetDirectory );
  2676.               end;
  2677.             end;
  2678.             { Reset to normal cursor }
  2679.             Screen.Cursor := crDefault;
  2680.           end;
  2681.         end;
  2682.       end;
  2683.     end
  2684.     else
  2685.     begin { Operate on only source }
  2686.       if TargetDirectory[ 1 ] <> SourceDirectory[ 1 ] then
  2687.       begin { Copy to different drives }
  2688.         if TheIOManager.WasALTPressed then
  2689.         begin { ALT overrides and does move }
  2690.           with Source as TFileIconPanel do
  2691.           begin
  2692.             if (( FileGetAttr( FTheName ) and faDirectory ) = faDirectory ) then
  2693.             begin
  2694.               if MessageDlg( 'Move Directory ' + FTheName + ' to ' +
  2695.                TargetDirectory + '?' , mtConfirmation , mbYesNoCancel , 0 ) = mrYes then
  2696.                 TheFIPSB.TheFWB.RecursivelyMoveDirectory( FtheName ,
  2697.                  TargetDirectory );
  2698.             end
  2699.             else
  2700.             begin
  2701.               if MessageDlg( 'Move ' + FTheName + ' to ' +
  2702.                TargetDirectory + '?' , mtConfirmation , mbYesNoCancel , 0 ) = mrYes then
  2703.                 TheFIPSB.TheFWB.MoveTheFile( FTheName , TargetDirectory );
  2704.             end;
  2705.           end;
  2706.         end
  2707.         else
  2708.         begin { Default is to do copy like file manager }
  2709.           with Source as TFileIconPanel do
  2710.           begin
  2711.             if (( FileGetAttr( FTheName ) and faDirectory ) = faDirectory ) then
  2712.             begin
  2713.               if MessageDlg( 'Copy Directory ' + FtheName + ' to ' +
  2714.                TargetDirectory + '?' , mtConfirmation , mbYesNoCancel , 0 ) = mrYes then
  2715.                 TheFIPSB.TheFWB.RecursivelyCopyDirectory( FtheName ,
  2716.                  TargetDirectory );
  2717.             end
  2718.             else
  2719.             begin
  2720.               if MessageDlg( 'Copy ' + FTheName + ' to ' +
  2721.                TargetDirectory + '?' , mtConfirmation , mbYesNoCancel , 0 ) = mrYes then
  2722.                 TheFIPSB.TheFWB.CopyTheFile( FTheName , TargetDirectory );
  2723.             end;
  2724.           end;
  2725.         end;
  2726.       end
  2727.       else
  2728.       begin { Copy to same drive }
  2729.         if TheIOManager.WasCTRLPressed then
  2730.         begin { CTRL overrides and does copy }
  2731.           with Source as TFileIconPanel do
  2732.           begin
  2733.             if (( FileGetAttr( FTheName ) and faDirectory ) = faDirectory ) then
  2734.             begin
  2735.               if MessageDlg( 'Copy Directory ' + FtheName + ' to ' +
  2736.                TargetDirectory + '?' , mtConfirmation , mbYesNoCancel , 0 ) = mrYes then
  2737.                 TheFIPSB.TheFWB.RecursivelyCopyDirectory( FtheName ,
  2738.                  TargetDirectory );
  2739.             end
  2740.             else
  2741.             begin
  2742.               if MessageDlg( 'Copy ' + FTheName + ' to ' +
  2743.                TargetDirectory + '?' , mtConfirmation , mbYesNoCancel , 0 ) = mrYes then
  2744.                 TheFIPSB.TheFWB.CopyTheFile( FTheName , TargetDirectory );
  2745.             end;
  2746.           end;
  2747.         end
  2748.         else
  2749.         begin { Default is to do move like file manager }
  2750.           with Source as TFileIconPanel do
  2751.           begin
  2752.             if (( FileGetAttr( FTheName ) and faDirectory ) = faDirectory ) then
  2753.             begin
  2754.               if MessageDlg( 'Move Directory ' + FtheName + ' to ' +
  2755.                TargetDirectory + '?' , mtConfirmation , mbYesNoCancel , 0 ) = mrYes then
  2756.                 TheFIPSB.TheFWB.RecursivelyMoveDirectory( FtheName ,
  2757.                  TargetDirectory );
  2758.             end
  2759.             else
  2760.             begin
  2761.               if MessageDlg( 'Move ' + FTheName + ' to ' +
  2762.                TargetDirectory + '?' , mtConfirmation , mbYesNoCancel , 0 ) = mrYes then
  2763.                 TheFIPSB.TheFWB.MoveTheFile( FTheName , TargetDirectory );
  2764.             end;
  2765.           end;
  2766.         end;
  2767.       end;
  2768.     end;
  2769.   end;
  2770.   { Call special method due to SendMessage problem! }
  2771.   TFileIconPanelScrollBox( TFileIconPanel( Source ).Parent ).Update;
  2772.   TFileIconPanelScrollBox( Parent ).Update;
  2773. end;
  2774.  
  2775. { Paint method for FIP; overrides normal paint }
  2776. procedure TFileIconPanel.Paint;
  2777. var
  2778.   TheOtherRect   : TRect;   { Holds clientrect   }
  2779.   TopColor     ,            { Holds bright color }
  2780.   BottomColor    : TColor;  { Holds dark color   }
  2781.  
  2782. { These methods are from Borland Intl., copyright 1995 }
  2783. procedure Frame3D(    Canvas       : TCanvas;
  2784.                   var TheRect      : TRect;
  2785.                       TopColor   ,
  2786.                       BottomColor  : TColor;
  2787.                       Width        : Integer );
  2788.  
  2789. procedure DoRect;
  2790. var
  2791.   TopRight, BottomLeft: TPoint;
  2792. begin
  2793.   with Canvas, TheRect do
  2794.   begin
  2795.     TopRight.X := Right;
  2796.     TopRight.Y := Top;
  2797.     BottomLeft.X := Left;
  2798.     BottomLeft.Y := Bottom;
  2799.     Pen.Color := TopColor;
  2800.     PolyLine([BottomLeft, TopLeft, TopRight]);
  2801.     Pen.Color := BottomColor;
  2802.     Dec(BottomLeft.X);
  2803.     PolyLine([TopRight, BottomRight, BottomLeft]);
  2804.   end;
  2805. end;
  2806.  
  2807. begin
  2808.   Canvas.Pen.Width := 1;
  2809.   Dec(TheRect.Bottom); Dec(TheRect.Right);
  2810.   while Width > 0 do
  2811.   begin
  2812.     Dec(Width);
  2813.     DoRect;
  2814.     InflateRect(TheRect, -1, -1);
  2815.   end;
  2816.   Inc(TheRect.Bottom); Inc(TheRect.Right);
  2817. end;
  2818.  
  2819. procedure AdjustColors(Bevel: TPanelBevel);
  2820. begin
  2821.   TopColor := FHighlightColor;
  2822.   if Bevel = bvLowered then TopColor := FShadowColor;
  2823.   BottomColor := FShadowColor;
  2824.   if Bevel = bvLowered then BottomColor := FHighlightColor;
  2825. end;
  2826.  
  2827. { Custom code begins here }
  2828. begin
  2829.   { Get the rectangle of the control with API/method call }
  2830.   TheOtherRect := GetClientRect;
  2831.   { draw basic rectangle with basic color }
  2832.   with Canvas do
  2833.   begin
  2834.     Brush.Color := Color;
  2835.     FillRect(TheOtherRect);
  2836.   end;
  2837.   { Set up for top "icon" frame  and draw it with frame3d }
  2838.   TheOtherRect.Right := Width;
  2839.   TheOtherRect.Bottom := Round( Height * 0.75 ) - 6 ;
  2840.   if BevelOuter <> bvNone then
  2841.   begin
  2842.     AdjustColors(BevelOuter);
  2843.     Frame3D(Canvas, TheOtherRect, TopColor, BottomColor, BevelWidth);
  2844.   end;
  2845.   Frame3D(Canvas, TheOtherRect, Color, Color, BorderWidth);
  2846.   if BevelInner <> bvNone then
  2847.   begin
  2848.     AdjustColors(BevelInner);
  2849.     Frame3D(Canvas, TheOtherRect, TopColor, BottomColor, BevelWidth);
  2850.   end;
  2851.   { Do the same for the lower "label" frame }
  2852.   TheOtherRect.Top := Round( Height * 0.75 ) - 5;
  2853.   TheOtherRect.Left := 0;
  2854.   TheOtherRect.Bottom := Height;
  2855.   TheOtherRect.Right := Width;
  2856.   if BevelOuter <> bvNone then
  2857.   begin
  2858.     AdjustColors(BevelOuter);
  2859.     Frame3D(Canvas, TheOtherRect, TopColor, BottomColor, BevelWidth);
  2860.   end;
  2861.   Frame3D(Canvas, TheOtherRect, Color, Color, BorderWidth);
  2862.   if BevelInner <> bvNone then
  2863.   begin
  2864.     AdjustColors(BevelInner);
  2865.     Frame3D(Canvas, TheOtherRect, TopColor, BottomColor, BevelWidth);
  2866.   end;
  2867.   if Assigned( FTheBMP ) then
  2868.   begin
  2869.     Canvas.BrushCopy( Rect( (( Width - ThumbNailWidth ) div 2 ) ,
  2870.                             ( (( Round( Height * 0.75 ) - 6 ) - ThumbNailHeight ) div 2 ) ,
  2871.                             ThumbNailWidth , ThumbNailHeight ) ,
  2872.                       FTheBMP ,
  2873.                       Rect( 0 , 0 , ThumbNailWidth , ThumbNailHeight ) , GlobalTransparentColor );
  2874.     {Canvas.Draw( (( Width - ThumbNailWidth ) div 2 ) ,
  2875.     ((( Round( Height * 0.75 ) - 6 ) - ThumbNailHeight ) div 2 ) , FTheBMP );}
  2876.   end
  2877.   else
  2878.   begin
  2879.     { Then draw the icon using canvas draw method }
  2880.     Canvas.Draw( (( Width - 32 ) div 2 ) + 1 ,
  2881.     ((( Round( Height * 0.75 ) - 6 ) - 32 ) div 2 ) + 1 , FTheIcon );
  2882.   end;
  2883. end;
  2884.  
  2885. { This procedure clears a scrollbox of all FileIconPanels }
  2886. procedure TFileIconPanelScrollbox.ClearTheFIPs;
  2887. var Counter_1 : Integer;
  2888.     TheComponent : TComponent;
  2889. begin
  2890.   { Note that must use while loop since component count continually }
  2891.   { decreases as removes are made!                                  }
  2892.   while ComponentCount > 0 do
  2893.   begin
  2894.     { Save the component as a generic TComponent }
  2895.     TheComponent := Components[ 0 ];
  2896.     { Call removecomponent to pull it out of the owner list for sb }
  2897.     { This avoids GPF when freeing the sb.                         }
  2898.     RemoveComponent( Components[ 0 ]);
  2899.     if ControlCount > 0 then
  2900.      RemoveControl( Controls[ 0 ] );
  2901.     { Typecast the pointer and free it to release memory and res. }
  2902.     TheParentForm.InsertComponent( TheComponent );
  2903.   end;
  2904. end;
  2905.  
  2906. { This procedure scans for drives and obtains their type and creates file }
  2907. { icon panels to represent them.                                          }
  2908. procedure TFileIconPanelScrollBox.AddDriveIcons( var XCounter ,
  2909.            YCounter : Integer );
  2910. type
  2911.   { This if from filectrl unit; reproduce here for completeness }
  2912.   TDriveType = (dtUnknown, dtNoDrive, dtFloppy, dtFixed, dtNetwork, dtCDROM,
  2913.                 dtRAM);
  2914. var
  2915.   DriveNum        : Integer;         { Used to get next drive via DOS fn   }
  2916.   IconType        : Integer;         { Used to hold icon type (defacto dt) }
  2917.   DriveChar       : Char;            { Used to hold drive letter           }
  2918.   DriveType       : TDriveType;      { Used for set-valued drive type      }
  2919.   Finished        : Boolean;         { Loop flag                           }
  2920.   TheFIP          : TFileIconPanel;  { Generic FileIconPanel variable      }
  2921.   ButtonColor   ,                    { Main panel color                    }
  2922.   ButtonHLColor ,                    { Bright panel color                  }
  2923.   ButtonSColor  ,                    { Dark panel color                    }
  2924.   Textcolor       : TColor;          { Label text color                    }
  2925.  
  2926. { This code is from the FileCtrl Unit; copyright Borland Intl 1995      }
  2927. { Check whether drive is a CD-ROM.  Returns True if MSCDEX is installed }
  2928. {  and the drive is using a CD driver                                   }
  2929.  
  2930. function IsCDROM(DriveNum: Integer): Boolean; assembler;
  2931. asm
  2932.   MOV   AX,1500h { look for MSCDEX }
  2933.   XOR   BX,BX
  2934.   INT   2fh
  2935.   OR    BX,BX
  2936.   JZ    @Finish
  2937.   MOV   AX,150Bh { check for using CD driver }
  2938.   MOV   CX,DriveNum
  2939.   INT   2fh
  2940.   OR    AX,AX
  2941.   @Finish:
  2942. end;
  2943.  
  2944. { This code is from the FileCtrl Unit; copyright Borland Intl 1995      }
  2945. { Check whether drive is a RAM drive.                                   }
  2946. function IsRAMDrive(DriveNum: Integer): Boolean; assembler;
  2947. var
  2948.   TempResult: Boolean;
  2949. asm
  2950.   MOV   TempResult,False
  2951.   PUSH  DS
  2952.   MOV   BX,SS
  2953.   MOV   DS,BX
  2954.   SUB   SP,0200h
  2955.   MOV   BX,SP
  2956.   MOV   AX,DriveNum
  2957.   MOV   CX,1
  2958.   XOR   DX,DX
  2959.   INT   25h  { read boot sector }
  2960.   ADD   SP,2
  2961.   JC    @ItsNot
  2962.   MOV   BX,SP
  2963.   CMP   BYTE PTR SS:[BX+15h],0F8h  { reverify fixed disk }
  2964.   JNE   @ItsNot
  2965.   CMP   BYTE PTR SS:[BX+10h],1  { check for single FAT }
  2966.   JNE   @ItsNot
  2967.   MOV   TempResult,True
  2968.   @ItsNot:
  2969.   ADD   SP,0200h
  2970.   POP   DS
  2971.   MOV   AL, TempResult
  2972. end;
  2973.  
  2974. { This code is from the FileCtrl Unit; copyright Borland Intl 1995      }
  2975. { Finds the type of a drive letter.                                     }
  2976. function FindDriveType(DriveNum: Integer): TDriveType;
  2977. begin
  2978.   Result := TDriveType(GetDriveType(DriveNum));
  2979.   if (Result = dtFixed) or (Result = dtNetwork) then
  2980.   begin
  2981.     if IsCDROM(DriveNum) then Result := dtCDROM
  2982.     else if (Result = dtFixed) then
  2983.     begin
  2984.         { do not check for RAMDrive under Windows NT }
  2985.       if ((GetWinFlags and $4000) = 0) and IsRAMDrive(DriveNum) then
  2986.         Result := dtRAM;
  2987.     end;
  2988.   end;
  2989. end;
  2990.  
  2991. begin
  2992.   { Set the button colors to an aquamarine color scheme for drives }
  2993.   ButtonColor := clTeal;
  2994.   ButtonHLColor := clAqua;
  2995.   ButtonSColor := clNavy;
  2996.   TextColor := clblack;
  2997.   { Set initial variables before looping for all drives }
  2998.   finished := false;
  2999.   DriveNum := 0;
  3000.   while not finished do
  3001.   begin
  3002.     { Start with no drive found }
  3003.     IconType := 0;
  3004.     { Call the Borland method to get the drive info }
  3005.     DriveType := FindDriveType(DriveNum);
  3006.     { Set its letter and make it uppercase }
  3007.     DriveChar := Chr(DriveNum + ord('a'));
  3008.     DriveChar := Upcase(DriveChar);
  3009.     { Assign an icon based on the drive type; if no drive exists type is nil }
  3010.     case DriveType of
  3011.       dtFloppy  : IconType := 1;
  3012.       dtFixed   : IconType := 2;
  3013.       dtNetwork : IconType := 3;
  3014.       dtCDROM   : IconType := 4;
  3015.       dtRAM     : IconType := 5;
  3016.     end;
  3017.     { Set to check next drive letter }
  3018.     DriveNum := DriveNum + 1;
  3019.     { But if no match then out of drives so set exit flag }
  3020.     if IconType = 0 then finished := true;
  3021.     { If drive was valid then set up the New FileIconPanel on the imported }
  3022.     { Scrollbox                                                            }
  3023.     if not finished then
  3024.     begin
  3025.       { Create the FileIconPanel and set its parent for memory mgmt and display}
  3026.       TheFIP := TFileIconPanel.Create( Self );
  3027.       TheFIP.Parent := Self;
  3028.       { Call its initialize method with imported position values and the   }
  3029.       { preset color scheme, a drive caption, and a minimum font. Note the }
  3030.       { setting of the ExtraData field to non-zero; this signals a drive   }
  3031.       { rather than a file being sent in.                                  }
  3032.       TheFIP.Initialize((( XCounter - 1 ) * TheIconSpacing ),
  3033.        (( YCounter - 1  ) * TheIconSpacing ) , TheIconSize , TheIconSize , 3 ,
  3034.         7 , ButtonColor, ButtonHLColor,
  3035.        ButtonSColor , TextColor , 'DRIVE ' + DriveChar + ':' , 'MS Serif' , [] ,
  3036.        IconType );
  3037.       { Increment the column counter; if it exceeds max move to New row      }
  3038.       { Note that these are 'var' parameters and will export final position. }
  3039.       XCounter := XCounter + 1;
  3040.       if XCounter > MaxIconsInARow then
  3041.       begin
  3042.         XCounter := 1;
  3043.         YCounter := YCounter + 1;
  3044.       end;
  3045.     end;
  3046.   end;
  3047. end;
  3048.  
  3049. { This procedure assigns colors to FIP's based on file attributes }
  3050. procedure TFileIconPanelScrollBox.GetColorsForFileIcon( TheFile : String;
  3051.            var BC , HC , SC , TC : TColor );
  3052. var AmADir      ,             { Booleans hold file attribs }
  3053.     AmAnArchive ,
  3054.     AmAVolumeId ,
  3055.     AmHidden    ,
  3056.     AmReadOnly  ,
  3057.     AmSystem      : Boolean;
  3058. begin
  3059.   { Make the call to internal fileworkbench to set attributes }
  3060.   TheFWB.GetFileAttributes( TheFile , AmADir , AmAnArchive , AmAVolumeId ,
  3061.    AmHidden , AmReadOnly , AmSystem );
  3062.   { Volume ID has no subtypes }
  3063.   if AmAVolumeID then
  3064.   begin
  3065.     BC := clOlive;
  3066.     HC := clYellow;
  3067.     SC := clBlack;
  3068.     TC := clWhite;
  3069.     exit;
  3070.   end;
  3071.   { Check all directory combinations }
  3072.   if AmADir then
  3073.   begin
  3074.     BC := clNavy;
  3075.     HC := clBlue;
  3076.     SC := clBlack;
  3077.     TC := clWhite;
  3078.     if AmHidden then
  3079.     begin
  3080.       if AmReadOnly then
  3081.       begin
  3082.         if AmSystem then
  3083.         begin { One HECK of a file! }
  3084.           BC := clBlack;
  3085.           HC := clSilver;
  3086.           SC := clGray;
  3087.           TC := clWhite;
  3088.         end
  3089.         else
  3090.         begin { Dir,RO,Hid }
  3091.           BC := clMaroon;
  3092.           HC := clFuchsia;
  3093.           SC := clGreen;
  3094.           TC := clWhite;
  3095.         end;
  3096.       end
  3097.       else
  3098.       begin { Dir,Hid }
  3099.         BC := clPurple;
  3100.         HC := clFuchsia;
  3101.         SC := clBlack;
  3102.         TC := clWhite;
  3103.       end;
  3104.     end
  3105.     else
  3106.     begin
  3107.       if AmReadOnly then
  3108.       begin
  3109.         if AmSystem then
  3110.         begin { Dir,RO,Sys }
  3111.           BC := clMaroon;
  3112.           HC := clLime;
  3113.           SC := clGreen;
  3114.           TC := clWhite;
  3115.         end
  3116.         else
  3117.         begin { Dir,RO }
  3118.           BC := clGreen;
  3119.           HC := clLime;
  3120.           SC := clBlack;
  3121.           TC := clWhite;
  3122.         end;
  3123.       end
  3124.       else
  3125.       begin
  3126.         if AmSystem then
  3127.         begin { Dir,Sys }
  3128.           BC := clMaroon;
  3129.           HC := clRed;
  3130.           SC := clBlack;
  3131.           TC := clWhite;
  3132.         end;
  3133.       end;
  3134.     end;
  3135.   end
  3136.   else { Archive Only; check all combinations }
  3137.   begin
  3138.     BC := clSilver;
  3139.     HC := clWhite;
  3140.     SC := clGray;
  3141.     TC := clBlack;
  3142.     if AmHidden then
  3143.     begin
  3144.       if AmReadOnly then
  3145.       begin
  3146.         if AmSystem then
  3147.         begin { Hid,RO,Sys }
  3148.           BC := clRed;
  3149.           HC := clLime;
  3150.           SC := clPurple;
  3151.           TC := clBlack;
  3152.         end
  3153.         else
  3154.         begin { RO,Hid }
  3155.           BC := clLime;
  3156.           HC := clFuchsia;
  3157.           SC := clMaroon;
  3158.           TC := clBlack;
  3159.         end;
  3160.       end
  3161.       else
  3162.       begin { Hid }
  3163.         BC := clFuchsia;
  3164.         HC := clWhite;
  3165.         SC := clPurple;
  3166.         TC := clBlack;
  3167.       end;
  3168.     end
  3169.     else
  3170.     begin
  3171.       if AmReadOnly then
  3172.       begin
  3173.         if AmSystem then
  3174.         begin { RO,Sys }
  3175.           BC := clRed;
  3176.           HC := clLime;
  3177.           SC := clMaroon;
  3178.           TC := clBlack;
  3179.         end
  3180.         else
  3181.         begin { RO }
  3182.           BC := clLime;
  3183.           HC := clWhite;
  3184.           SC := clGreen;
  3185.           TC := clBlack;
  3186.         end;
  3187.       end
  3188.       else
  3189.       begin
  3190.         if AmSystem then
  3191.         begin { System }
  3192.           BC := clRed;
  3193.           HC := clWhite;
  3194.           SC := clMaroon;
  3195.           TC := clBlack;
  3196.         end;
  3197.       end;
  3198.     end;
  3199.   end;
  3200. end;
  3201.  
  3202. { This procedure gets all icons for an given directory, including drives and }
  3203. { standard subdirectories. It does not get special combinations or h/ro/sys  }
  3204. procedure TFileIconPanelScrollbox.GetIconsForEntireDirectory(
  3205.             TargetPath  : String );
  3206. var Finished        : Boolean;         { Loop flag              }
  3207.     TheSR           : TSearchRec;      { Searchrecord for FF/FN }
  3208.     TheResult       : Integer;         { return variable        }
  3209.     TempPath        : String;          { path for FF/FN         }
  3210.     TheFIP          : TFileIconPanel;  { generic FIP holder     }
  3211.     RowCounter    ,                    { position in row of FIP }
  3212.     ColumnCounter   : Integer;         { position in col of FIP }
  3213.     ButtonColor   ,                    { main panel color       }
  3214.     ButtonHLColor ,                    { bright panel color     }
  3215.     ButtonSColor  ,                    { dark panel color       }
  3216.     Textcolor       : TColor;          { label text color       }
  3217.     IsADir ,                           { Variable for file attr }
  3218.     IsAnArchive ,
  3219.     IsAVolumeID,
  3220.     IsAReadOnlyFile,
  3221.     IsAHiddenFile ,
  3222.     IsASystemFile     : Boolean;
  3223.     MaxTextLength     : Integer;       { Used to safely set size}
  3224. begin
  3225.   { hide during refresh }
  3226.   Visible := false;
  3227.   { Get the icon sizes }
  3228.   TheFIP := TFileIconPanel.Create( Self );
  3229.   TheFIP.Parent := Self;
  3230.   TheFIP.FTheLabel.Canvas.Font.Name := 'MS Serif';
  3231.   TheFIP.FTheLabel.Canvas.Font.Size := 7;
  3232.   MaxTextLength := TheFIP.FTheLabel.Canvas.TextWidth( 'COMMAND.COM' );
  3233.   TheFIP.Free;
  3234.   TheIconSize := MaxTextLength + 13;
  3235.   ThumbNailWidth := TheIconSize - 10;
  3236.   ThumbNailHeight := Round( TheIconSize * 0.75 ) - 15;
  3237.   TheIconSpacing := TheIconSize + 5;
  3238.   { Set up maximum icons per row based on screen size }
  3239.   MaxIconsInARow := ( Screen.Width div TheIconSpacing );
  3240.   { Set up the position counters }
  3241.   RowCounter := 1;
  3242.   ColumnCounter := 1;
  3243.   { Get the drives for the current machine }
  3244.   AddDriveIcons( ColumnCounter , RowCounter  );
  3245.   { Set up the initial variables }
  3246.   Finished := false;
  3247.   TempPath := TargetPath + '*.*';
  3248.   { Make the call to FindFirst set to get any file; will return '.' }
  3249.   { so discard it.                                                  }
  3250.   TheResult := FindFirst( TempPath , faAnyFile , TheSR );
  3251.   { loop through all files in the directory and look for directories }
  3252.   while not Finished do
  3253.   begin
  3254.     { Make call to FindNext, using only SearchRecord from FindFirst }
  3255.     TheResult := FindNext( TheSR );
  3256.     { A -1 result means no more files so exit }
  3257.     if TheResult < 0 then finished := true else
  3258.     begin
  3259.       { Otherwise check for a directory attribute }
  3260.       if (( FileGetAttr( TargetPath + TheSR.Name ) and faDirectory ) =
  3261.        faDirectory ) then
  3262.       begin
  3263.         GetColorsForFileIcon( TargetPath + TheSR.Name , ButtonColor ,
  3264.          ButtonHLColor , ButtonSColor , TextColor );
  3265.         { If found create a New FileIconPanel on the imported scrollbox }
  3266.         { Note sending 0 ExtraData parameter to indicate file not drive }
  3267.         TheFIP := TFileIconPanel.Create( Self );
  3268.         TheFIP.Parent := Self;
  3269.         TheFIP.Initialize((( ColumnCounter - 1 ) * TheIconSpacing ),
  3270.          (( RowCounter - 1  ) * TheIconSpacing ) , TheIconSize, TheIconSize ,
  3271.           3 , 7 , ButtonColor, ButtonHLColor , ButtonSColor , TextColor ,
  3272.            TargetPath + TheSr.Name , 'MS Serif' , [] , 0 );
  3273.         { Increment column counter and move to New row if past limit }
  3274.         ColumnCounter := ColumnCounter + 1;
  3275.         if ColumnCounter > MaxIconsInARow then
  3276.         begin
  3277.           ColumnCounter := 1;
  3278.           RowCounter := RowCounter + 1;
  3279.         end;
  3280.       end;
  3281.     end;
  3282.   end;
  3283.   { Call FindClose for Windows NT/Windows 95 compatibility }
  3284.   FindClose( TheSR );
  3285.   { Set up New initialization variables }
  3286.   Finished := false;
  3287.   TempPath := TargetPath + '*.*';
  3288.   { Make needed call to FindFirst and discard '.' }
  3289.   TheResult := FindFirst( TempPath , faAnyFile , TheSR );
  3290.   while not Finished do
  3291.   begin
  3292.     { Loop through file again, this time getting only archive files }
  3293.     TheResult := FindNext( TheSR );
  3294.     { Result of -1 indicates no more files }
  3295.     if TheResult < 0 then Finished := true else
  3296.     begin
  3297.       { If faArchive file then add New FileIconPanel }
  3298.       TheFWB.GetFileAttributes(( Targetpath + TheSR.Name ) , IsADir ,
  3299.        IsAnArchive , IsAVolumeId , IsAHiddenFile , IsAReadOnlyFile ,
  3300.         IsASystemFile );
  3301.       if (( IsAnArchive ) and ( not IsADir )) then
  3302.       begin
  3303.         GetColorsForFileIcon( TargetPath + TheSR.Name , ButtonColor ,
  3304.          ButtonHLColor , ButtonSColor , TextColor );
  3305.         { Initialize New FileIconPanel and call initialize, sending 0 ED }
  3306.         TheFIP := TFileIconPanel.Create( Self );
  3307.         TheFIP.Parent := Self;
  3308.         TheFIP.Initialize((( ColumnCounter - 1 ) * TheIconSpacing ),
  3309.          (( RowCounter - 1  ) * TheIconSpacing ) , TheIconSize , TheIconSize ,
  3310.           3 , 7 , ButtonColor, ButtonHLColor , ButtonSColor , TextColor ,
  3311.            TargetPath + TheSr.Name , 'MS Serif' , [] , 0 );
  3312.         { Increment column counter and if needed row counter }
  3313.         ColumnCounter := ColumnCounter + 1;
  3314.         if ColumnCounter > MaxIconsInARow then
  3315.         begin
  3316.           ColumnCounter := 1;
  3317.           RowCounter := RowCounter + 1;
  3318.         end;
  3319.       end;
  3320.     end;
  3321.   end;
  3322.   { Call findclose for w95 and exit }
  3323.   FindClose( TheSR );
  3324.   { Reset to visible }
  3325.   Visible := true;
  3326. end;
  3327.  
  3328. { Update method for FIPscrollbox }
  3329. procedure TFileIconPanelScrollBox.Update;
  3330. begin
  3331.   IconsNeedRefreshing := true;
  3332.   { Force a repaint }
  3333.   InvalidateRect( TheStoredHandle , nil , true );
  3334. end;
  3335.  
  3336. { Create method for FIPScrollbox }
  3337. constructor TFileIconPanelScrollBox.Create( AOwner : TComponent );
  3338. begin
  3339.   inherited Create( AOwner );
  3340.   TheFWB := TFileWorkBench.Create( Self );
  3341. end;
  3342.  
  3343. { This function returns the next selected file's name }
  3344. function TFileIconPanelScrollBox.GetNextSelection( SourceDirectory : String;
  3345.                            var CurrentItem : Integer ) : String;
  3346. var TheResult    : String;      { Holds result of function }
  3347.     TheComponent : TComponent;  { Used for typecast        }
  3348.     finished     : boolean;     { Loop control variable    }
  3349.     TheComponentCount : Integer;
  3350. begin
  3351.   TheComponentCount := ComponentCount;
  3352.   { If past end of components exit with no result }
  3353.   if CurrentItem > TheComponentCount then TheResult := '' else
  3354.   begin
  3355.     { Set loop counter and run till find match or run out }
  3356.     finished := false;
  3357.     while not finished do
  3358.     begin
  3359.       { Pull component out of the list and check it }
  3360.       TheComponent := Components[ CurrentItem - 1 ];
  3361.       { Increment counter for later }
  3362.       CurrentItem := CurrentItem + 1;
  3363.       { Do the typecast with AS }
  3364.       if TheComponent is TFileIconPanel then
  3365.       with TheComponent as TFileIconPanel do
  3366.       begin
  3367.         { If its selected make sure OK }
  3368.         if Selected then
  3369.         begin
  3370.           { Don't accept backup for this level of operation }
  3371.           if FTheLabel.Caption <> '..' then
  3372.           begin
  3373.             { Otherwise return the name and abort the loop }
  3374.             TheResult := FTheName;
  3375.             finished := true;
  3376.           end;
  3377.         end
  3378.         else
  3379.         begin
  3380.           { Check to see if out of components }
  3381.           if CurrentItem > TheComponentCount then
  3382.           begin
  3383.             { If so signal error and abort }
  3384.             TheResult := '';
  3385.             finished := true;
  3386.           end;
  3387.         end;
  3388.       end;
  3389.     end;
  3390.   end;
  3391.   GetNextSelection := TheResult;
  3392. end;
  3393.  
  3394. { This procedure places a selection of files in the display based on wildcards }
  3395. procedure TFileIconPanelScrollBox.DisplayRecursiveSearchResults(
  3396.            TheStartingDirectory : String );
  3397. var XCounter ,
  3398.     YCounter   : Integer;
  3399.  
  3400. { This procedure does a recursive file search by first getting all matches (in-}
  3401. { cluding directories) and adding them to the list. Then it checks for ALL the }
  3402. { subdirectories and does the same trick on them til there are no more matches }
  3403. { and no more subdirectories, at which point it exits and recurses back up.    }
  3404. procedure RecursiveFileSearch( TheWorkingDirectory : String; var XCounter ,
  3405.                                YCounter : Integer );
  3406.  
  3407. { VITAL!!! These variables MUST be local for recursrion to work! }
  3408. var
  3409.     Finished        : Boolean;         { Loop flag              }
  3410.     TheSR           : TSearchRec;      { Searchrecord for FF/FN }
  3411.     TheResult       : Integer;         { return variable        }
  3412.     TargetPath ,
  3413.     FileMask   ,
  3414.     TheStoredWorkingDirectory ,
  3415.     ModifiedDirectory  : String;       { path for FF/FN         }
  3416.     TheFIP          : TFileIconPanel;  { generic FIP holder     }
  3417.     ButtonColor   ,                    { main panel color       }
  3418.     ButtonHLColor ,                    { bright panel color     }
  3419.     ButtonSColor  ,                    { dark panel color       }
  3420.     Textcolor       : TColor;          { label text color       }
  3421.  
  3422. begin
  3423.   { Jump out if abort pressed }
  3424.   if GlobalAbortFlag then exit;
  3425.   { Set up the initial variables }
  3426.   Finished := false;
  3427.   TheStoredWorkingDirectory := TheWorkingDirectory;
  3428.   Targetpath := ExtractFilePath( TheWorkingDirectory );
  3429.   FileMask := ExtractFileName( TheWorkingDirectory );
  3430.   { Make the call to FindFirst set to get any file }
  3431.   TheResult := FindFirst( TheWorkingDirectory , faAnyFile , TheSR );
  3432.   if TheResult < 0 then finished := true;
  3433.   if (( TheSr.Name <> '.' ) and ( TheSr.Name <> '..' ) and ( TheResult >= 0 ))
  3434.   then begin
  3435.     if (( FileGetAttr( TargetPath + TheSR.Name ) and faDirectory ) =
  3436.      faDirectory ) then
  3437.     begin { A directory }
  3438.       GetColorsForFileIcon( TargetPath + TheSR.Name , ButtonColor ,
  3439.        ButtonHLColor , ButtonSColor , TextColor );
  3440.       { If found create a New FileIconPanel on the imported scrollbox }
  3441.       { Note sending 0 ExtraData parameter to indicate file not drive }
  3442.       TheFIP := TFileIconPanel.Create( Self );
  3443.       TheFIP.Parent := Self;
  3444.       TheFIP.Initialize((( XCounter - 1 ) * TheIconSpacing ),
  3445.        (( YCounter - 1  ) * TheIconSpacing ) , TheIconSize , TheIconSize , 3 ,
  3446.         7 , ButtonColor, ButtonHLColor , ButtonSColor , TextColor , TargetPath
  3447.          + TheSr.Name , 'MS Serif' , [] , 0 );
  3448.       { Increment column counter and move to New row if past limit }
  3449.       XCounter := XCounter + 1;
  3450.       if XCounter > MaxIconsInARow then
  3451.       begin
  3452.         XCounter := 1;
  3453.         YCounter := YCounter + 1;
  3454.       end;
  3455.     end
  3456.     else
  3457.     begin { A File }
  3458.       { Set up the default color scheme for files }
  3459.       GetColorsForFileIcon( TargetPath + TheSR.Name , ButtonColor ,
  3460.        ButtonHLColor , ButtonSColor , TextColor );
  3461.       { If found create a New FileIconPanel on the imported scrollbox }
  3462.       { Note sending 0 ExtraData parameter to indicate file not drive }
  3463.       TheFIP := TFileIconPanel.Create( Self );
  3464.       TheFIP.Parent := Self;
  3465.       TheFIP.Initialize((( XCounter - 1 ) * TheIconSpacing ),
  3466.        (( YCounter - 1  ) * TheIconSpacing ) , TheIconSize, TheIconSize , 3 ,
  3467.         7 , ButtonColor, ButtonHLColor , ButtonSColor , TextColor , TargetPath
  3468.          + TheSr.Name , 'MS Serif' , [] , 0 );
  3469.       { Increment column counter and move to New row if past limit }
  3470.       XCounter := XCounter + 1;
  3471.       if XCounter > MaxIconsInARow then
  3472.       begin
  3473.         XCounter := 1;
  3474.         YCounter := YCounter + 1;
  3475.       end;
  3476.     end;
  3477.   end;
  3478.   { loop through all files in the directory and look for matches }
  3479.   while not Finished do
  3480.   begin
  3481.     { Allow keyboard processing and jump out if c-break hit }
  3482.     Application.ProcessMessages;
  3483.     if GlobalAbortFlag then exit;
  3484.     { Make call to FindNext, using only SearchRecord from FindFirst }
  3485.     TheResult := FindNext( TheSR );
  3486.     { A -1 result means no more files so exit }
  3487.     if TheResult < 0 then finished := true else
  3488.     begin
  3489.       if (( FileGetAttr( TargetPath + TheSR.Name ) and faDirectory ) =
  3490.        faDirectory ) then
  3491.       begin { A directory }
  3492.         { Set up the blue color scheme for directories }
  3493.         GetColorsForFileIcon( TargetPath + TheSR.Name , ButtonColor ,
  3494.          ButtonHLColor , ButtonSColor , TextColor );
  3495.         { If found create a New FileIconPanel on the imported scrollbox }
  3496.         { Note sending 0 ExtraData parameter to indicate file not drive }
  3497.         TheFIP := TFileIconPanel.Create( Self );
  3498.         TheFIP.Parent := Self;
  3499.         TheFIP.Initialize((( XCounter - 1 ) * TheIconSpacing ),
  3500.          (( YCounter - 1  ) * TheIconSpacing ) , TheIconSize , TheIconSize , 3 ,
  3501.            7 , ButtonColor, ButtonHLColor , ButtonSColor , TextColor ,
  3502.             TargetPath + TheSr.Name , 'MS Serif' , [] , 0 );
  3503.         { Increment column counter and move to New row if past limit }
  3504.         XCounter := XCounter + 1;
  3505.         if XCounter > MaxIconsInARow then
  3506.         begin
  3507.           XCounter := 1;
  3508.           YCounter := YCounter + 1;
  3509.         end;
  3510.       end
  3511.       else
  3512.       begin { A File }
  3513.         { Set up the default color scheme for files }
  3514.         GetColorsForFileIcon( TargetPath + TheSR.Name , ButtonColor ,
  3515.          ButtonHLColor , ButtonSColor , TextColor );
  3516.         { If found create a New FileIconPanel on the imported scrollbox }
  3517.         { Note sending 0 ExtraData parameter to indicate file not drive }
  3518.         TheFIP := TFileIconPanel.Create( Self );
  3519.         TheFIP.Parent := Self;
  3520.         TheFIP.Initialize((( XCounter - 1 ) * TheIconSpacing ),
  3521.          (( YCounter - 1  ) * TheIconSpacing ) , TheIconSize , TheIconSize , 3 ,
  3522.           7 , ButtonColor, ButtonHLColor , ButtonSColor , TextColor ,
  3523.            TargetPath + TheSr.Name , 'MS Serif' , [] , 0 );
  3524.         { Increment column counter and move to New row if past limit }
  3525.         XCounter := XCounter + 1;
  3526.         if XCounter > MaxIconsInARow then
  3527.         begin
  3528.           XCounter := 1;
  3529.           YCounter := YCounter + 1;
  3530.         end;
  3531.       end;
  3532.     end;
  3533.   end;
  3534.   { Call FindClose for Windows NT/Windows 95 compatibility }
  3535.   FindClose( TheSR );
  3536.   { Set up the variables to do recursive calls on all directories}
  3537.   Finished := false;
  3538.   ModifiedDirectory := ExtractFilePath( TheWorkingdirectory ) + '*.*';
  3539.   { Make the call to FindFirst set to get any file, ignore result }
  3540.   TheResult := FindFirst( ModifiedDirectory , faDirectory , TheSR );
  3541.   while not Finished do
  3542.   begin
  3543.     { Allow keyboard input and jump out if c-break hit }
  3544.     Application.ProcessMessages;
  3545.     if GlobalAbortFlag then exit;
  3546.     { Make call to FindNext, using only SearchRecord from FindFirst }
  3547.     TheResult := FindNext( TheSR );
  3548.     { A -1 result means no more files so exit }
  3549.     if TheResult < 0 then finished := true
  3550.     else
  3551.     begin
  3552.       if TheSR.Name <> '..' then { Ignore backup in this case }
  3553.       begin
  3554.         { Do second check due to bug in FindNext }
  3555.         if (( FileGetAttr( TargetPath + TheSR.Name ) and faDirectory )
  3556.         = faDirectory ) then
  3557.         begin
  3558.           { Set up modified directory to recurse into }
  3559.           ModifiedDirectory := ExtractFilePath( TheStoredWorkingDirectory ) +
  3560.            TheSR.Name + '\' + FileMask;
  3561.           { Perform the recursion }
  3562.           RecursiveFileSearch( ModifiedDirectory , XCounter , YCounter );
  3563.         end;
  3564.       end;
  3565.     end;
  3566.   end;
  3567. end;
  3568.  
  3569. begin
  3570.   { Keep the scrollbox from updating during refresh }
  3571.   Visible := false;
  3572.   { Make the clear call }
  3573.   ClearTheFIPs;
  3574.   XCounter := 1;
  3575.   YCounter := 1;
  3576.   { Get the drives for the current machine }
  3577.   AddDriveIcons( XCounter , YCounter );
  3578.   RecursiveFileSearch( TheStartingDirectory , XCounter , YCounter );
  3579.   { Make the scrollbox visible again }
  3580.   Visible := true;
  3581. end;
  3582.  
  3583. end.
  3584.