home *** CD-ROM | disk | FTP | other *** search
/ PC World Komputer 1998 April A / Pcwk4a98.iso / PROGRAM / DELPHI16 / Backup / BACKUP.PAS < prev    next >
Pascal/Delphi Source File  |  1996-02-19  |  30KB  |  1,102 lines
  1. {
  2.  Designer: Craig Ward, 100554.2072@compuserve.com
  3.  Date:     5/2/96
  4.  Version:  3.57
  5.  
  6.  
  7.  Function: Backup dialog DLL. Copies files from a source to a target. Will copy the
  8.            contents of a directory, or, a single file. An additional call will uncompress
  9.            the target file if the source was compressed using MS's COMPRESS.EXE
  10.  
  11.  Update:   The following enhancements have been made since the previous version:
  12.  
  13.             [1] an additional facility enables users to copy only newer files
  14.                 (this is achieved by checking file dates, and only copying those
  15.                 which are newer)
  16.             [2] as a consequence to the above I've had to make a change to the DLL
  17.                 call "HideBackupDlg". A new parameter (a bool) accomodates this
  18.                 feature.
  19.             [3] there was a bug which misreported file size\date info when overwriting
  20.                 (it was in fact reported the wrong way round!)
  21.  
  22.  
  23.  Space:    The way that the DLL works in checking size\space is the following:
  24.  
  25.             [1] it sums the size of the files to be copied
  26.             [2] it sums the size of the existing target files
  27.             [3] it finds the size of the target disk, if less than the size
  28.                 of the files being copied it aborts
  29.             [4] if the size of the target disk is okay, the next thing to check
  30.                 is the free space on the target drive. The DLL finds this figure, and
  31.                 adds to it the size of the existing target files (ie: it's expecting the
  32.                 user will overwrite these). Again, if this figure is smaller than that
  33.                 being copied it aborts.
  34.             [5] During the actual copying process the DLL will again check the free
  35.                 space on the target drive (handy for users of the CopyIndivFile call).
  36.  
  37.             (users of RAM drives beware: when the DLL checks file size, it doesn't bother
  38.             to check the maximum number of file entries allowed)
  39.  
  40.  
  41.  Calls:
  42.            procedure ShowBackupDlg(pSource,pDestination,pHelp,pCompat: pChar; bOverwritePrompt: boolean);
  43.             - opens the dialog box. This proc copies the contents of a whole directory that
  44.               conforms to the mask passed over.
  45.  
  46.            procedure HideBackupDlg(pSource,pDestination,pHelp,pCompat: pChar; bOverwritePrompt, bCopyNew: boolean);
  47.             - loads, but does not open dialog box, and executes the backup automatically, then closes.
  48.               This proc copies the contents of a whole directory that conforms to the mask passed
  49.               over.
  50.  
  51.            procedure CopyIndivFile(pSourceFile,pDestinationFile: pChar);
  52.             - copies the source file to the target file.
  53.  
  54.            procedure ExpandIndivFile(pSourceFile,pDestinationFile: pChar);
  55.             - copies the source file to the target file, and expands the file if it was
  56.               compressed (using MS-COMPRESS.EXE).
  57.  
  58.  
  59.  Extra:    Big thankyou to Dennis Passmore (71640.2464@compuserve.com), for his additions
  60.            to the unit. These consisted of expanded error checking, creation of a custom type
  61.            (the large buffer) to speed up the whole process and reduce stack usage, plus,
  62.            the neat trick of restoring the file-date of the backed-up files to reflect the
  63.            date of the source file, as opposed to that of when they were backed up.
  64.  
  65.            Also, a thankyou to Gregory Kraft (72114.3111@compuserve.com) who's enquiry
  66.            precipitated the addition of the HideBackupDlg procedure.
  67.  
  68.            And, another thank you goes to Shane Mulo (INTERNET:mulo@peg.apc.org) for
  69.            his kind words and ideas for improvement.
  70.  
  71.            Finally, I'd like to thank Philip Kapusta (74170.3550@compuserve.com) for his
  72.            diligence and patience in putting the DLL to test. His criticisms have helped
  73.            shape the whole utility.
  74.  
  75.            All criticisms, help and general advice are greatly welcomed.
  76. *********************************************************************************}
  77. unit Backup;
  78.  
  79. interface
  80.  
  81. uses
  82.   SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  83.   Forms, Dialogs, StdCtrls, Buttons, FileCtrl, Gauges, ExtCtrls;
  84.  
  85. type
  86.  {custom type to hold file information}
  87.  TFileInfo = record
  88.   Date: longint;
  89.   Size: longint;
  90.  end;
  91.  {**}
  92.   TBackupDlg = class(TForm)
  93.     DirList: TDirectoryListBox;
  94.     FList: TFileListBox;
  95.     Label1: TLabel;
  96.     lblSource: TLabel;
  97.     Label2: TLabel;
  98.     lblDestination: TLabel;
  99.     btnOK: TBitBtn;
  100.     btnCancel: TBitBtn;
  101.     BitBtn1: TBitBtn;
  102.     driveBox: TDriveComboBox;
  103.     Bevel1: TBevel;
  104.     Bevel2: TBevel;
  105.     SpeedButton1: TSpeedButton;
  106.     Bevel3: TBevel;
  107.     Bevel4: TBevel;
  108.     chkSelect: TCheckBox;
  109.     chkNew: TCheckBox;
  110.     procedure btnCancelClick(Sender: TObject);
  111.     procedure btnOKClick(Sender: TObject);
  112.     procedure BitBtn1Click(Sender: TObject);
  113.     procedure SpeedButton1Click(Sender: TObject);
  114.     procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
  115.     procedure chkSelectClick(Sender: TObject);
  116.     procedure FListClick(Sender: TObject);
  117.     procedure FListDblClick(Sender: TObject);
  118.     procedure FListKeyDown(Sender: TObject; var Key: Word;
  119.       Shift: TShiftState);
  120.     procedure chkNewClick(Sender: TObject);
  121.   private
  122.     { Private declarations }
  123.     FDir: string;                                         {stores current directory}
  124.     FOkToAll: boolean;                                    {stores initial value passed to DLL for overwrite prompt}
  125.     FNew: boolean;                                        {stores bool for determining whether to copy only newer files}
  126.     procedure CustInitialise(pSource,pDestination,pHelp,pCompat: pChar; bOverwritePrompt: boolean);
  127.     procedure SetUpFiles;
  128.     procedure CustCopyFiles(sSrce, sDest: string);
  129.     procedure CustExpandFile(pSrce, pDest: pChar);
  130.     function ChangeExt(sSrce: string): string;
  131.     function IsDir(sDrive: string): boolean;
  132.     function DiskInDrive(i: integer): boolean;
  133.     function GetFileInfo(sFile: string): TFileInfo;
  134.     function CheckDir(sDir: string): string;
  135.     function IsSpace(sDestination: string): longint;
  136.   public
  137.     { Public declarations }
  138.     FCancel: boolean;
  139.   end;
  140.  
  141. var
  142.   BackupDlg: TBackupDlg;
  143.   iErrorMode: word;
  144.   OkToAll: boolean;
  145.  
  146.  
  147.  
  148. const
  149.  iHelp: integer = 105; {help-context for SelectDirectory Dialog}
  150.  
  151.  
  152. {exported procedures}
  153. procedure ShowBackupDlg(pSource,pDestination,pHelp,pCompat: pChar; bOverwritePrompt: boolean); export;
  154. procedure HideBackupDlg(pSource,pDestination,pHelp,pCompat: pChar; bOverwritePrompt, bCopyNew: boolean); export;
  155. procedure CopyIndivFile(pSourceFile,pDestinationFile: pChar); export;
  156. procedure ExpandIndivFile(pSourceFile,pDestinationFile: pChar); export;
  157.  
  158. implementation
  159.  
  160. {$R *.DFM}
  161.  
  162. uses
  163.  LZExpand, prog;
  164.  
  165.  
  166. {***custom routines*************************************************************}
  167.  
  168. {return free space, plus size of existing file. This routine is only called
  169.  by CustCopyFiles (which it calls just before it attempts to copy the source
  170.  file)}
  171. function TBackupDlg.IsSpace(sDestination: string): longint;
  172. var
  173.  c: char;
  174.  i: integer;
  175.  li: longint;
  176.  fExists: ^TFileInfo;
  177. begin
  178.  
  179.  New(fExists);
  180.  
  181.  try
  182.  
  183.  {get drive letter}
  184.  c := sDestination[1];
  185.  
  186.  {check that drive letter is valid}
  187.  if c in ['a'..'z'] then Dec(c,($20));
  188.  if not (c in ['A'..'Z']) then
  189.   begin
  190.    messageDlg('Invalid drive ID',mtWarning,[mbOK],0);
  191.    result := 0;
  192.   end;
  193.  
  194.  {get alphabet index of character - ie: A is 1. Remember, it's now uppercase}
  195.  i := Ord(c)-$40 ;
  196.  
  197.  li := 0;
  198.  li := DiskFree(i);
  199.  
  200.  {if the file exists, then add the existing file's size from value returned by diskFree,
  201.   otherwise we would be misreporting the amount of free-space}
  202.  if FileExists(sDestination) then
  203.    begin
  204.     fExists^ := GetFileInfo(sDestination);
  205.     li := li + fExists^.size;
  206.    end;
  207.  
  208.  result := li;
  209.  
  210.  finally
  211.   dispose(fExists);
  212.  end;
  213.  
  214. end;
  215.  
  216.  
  217. {check directory - adds a colon and backslash if they're missing, and then
  218.  calls isDir to check that the directory\drive is valid}
  219. function TBackupDlg.CheckDir(sDir: string): string;
  220. begin
  221.  
  222.  case length(sDir) of
  223.  {case of sDir being just a drive letter, add ':\'}
  224.   1:
  225.    begin
  226.     if isDir(sDir) then
  227.      result := sDir + ':\'
  228.     else
  229.      result := FDir;
  230.    end;
  231.  else
  232.   begin
  233.     {text is okay, so check if directory exists}
  234.     if isDir(sDir) then
  235.      result := sDir
  236.     else
  237.      result := FDir;
  238.   end;
  239.  end;
  240.  
  241. end;
  242.  
  243.  
  244. {change file extension routine - this routine simply iterates through an
  245.  array, swapping the extension for a "full" extension}
  246. function TBackupDlg.ChangeExt(sSrce: string): string;
  247. type
  248.  {custom type - stores replacment extensions}
  249.  TRepExtensions = record
  250.   CurrExt: string;
  251.   RepExt: string;
  252. end;
  253. var
  254.  FExtensions: array[1..6] of TRepExtensions;
  255.  iInc: integer;
  256.  sExt: string[4];
  257. begin
  258.  
  259.  {extensions - note: do not include ini files or databases since the user's version will always be newer}
  260.  FExtensions[1].CurrExt := '.EX_';
  261.  FExtensions[1].RepExt := '.EXE';
  262.  
  263.  FExtensions[2].CurrExt := '.DL_';
  264.  FExtensions[2].RepExt := '.DLL';
  265.  
  266.  FExtensions[3].CurrExt := '.HL_';
  267.  FExtensions[3].RepExt := '.HLP';
  268.  
  269.  FExtensions[4].CurrExt := '.BM_';
  270.  FExtensions[4].RepExt := '.BMP';
  271.  
  272.  FExtensions[5].CurrExt := '.IC_';
  273.  FExtensions[5].RepExt := '.ICO';
  274.  
  275.  FExtensions[6].CurrExt := '.RP_';
  276.  FExtensions[6].RepExt := '.RPT';
  277.  
  278.  if sSrce[length(sSrce)] = '_' then
  279.   begin
  280.    sExt := ExtractFileExt(sSrce);
  281.    {iterate through extensions}
  282.    for iInc := 1 to 6 do
  283.     begin
  284.      if CompareText(FExtensions[iInc].CurrExt,sExt) = 0 then sExt := FExtensions[iInc].RepExt;
  285.     end;
  286.    {change extension}
  287.    sSrce := ChangeFileExt(sSrce,sExt);
  288.    result := sSrce;
  289.   end
  290.  else
  291.   result := '';
  292.  
  293. end;
  294.  
  295.  
  296. {routine returns file information - called in the case of overwrites}
  297. function TBackupDlg.GetFileInfo(sFile: string): TFileInfo;
  298. var
  299.  f: file;
  300.  fInfo: ^TFileInfo;
  301. begin
  302.  
  303.  New(fInfo);
  304.  
  305.  try
  306.  
  307.    if not FileExists(sFile) then exit;
  308.  
  309.    {Set file access mode to readonly in case file is in use.}
  310.    System.FileMode := fmOpenRead;
  311.    {assign and open files}
  312.    AssignFile(f,sFile);
  313.    {$I-}
  314.    Reset(f,1);
  315.    {$I+}
  316.   {Set file access mode back to normal default for other processes}
  317.   System.Filemode := fmOpenReadWrite;
  318.   if IOResult <> 0  then
  319.    begin
  320.     messageDlg('Could not open: '+sFile,mtWarning,[mbOK],0);
  321.     fInfo^.size := 0;
  322.     fInfo^.date := 0;
  323.    end
  324.   else
  325.    begin
  326.     fInfo^.size := FileSize(f);
  327.     fInfo^.date := FileGetDate(TFileRec(f).Handle);
  328.    end;
  329.   result := fInfo^;
  330.   system.closeFile(f);
  331.  
  332.  finally
  333.   Dispose(fInfo);
  334.  end;
  335.  
  336. end;
  337.  
  338.  
  339. {check for directory, or drive}
  340. function TBackupDlg.IsDir(sDrive: string): boolean;
  341. var
  342.  c: char;
  343.  i: integer;
  344. begin
  345.  
  346.  {get drive letter}
  347.  c := sDrive[1];
  348.  
  349.  {check that drive letter is valid}
  350.  if c in ['a'..'z'] then Dec(c,($20));
  351.  if not (c in ['A'..'Z']) then
  352.   begin
  353.    messageDlg('Invalid drive ID',mtWarning,[mbOK],0);
  354.    result := false;
  355.   end;
  356.  
  357.  {get alphabet index of character - ie: A is 1. Remember, it's now uppercase}
  358.  i := Ord(c)-$40;
  359.  
  360.  
  361.  if GetDriveType(i -1) = DRIVE_REMOVABLE then
  362.   {floppy}
  363.   begin
  364.  
  365.    {ensure floppy in drive - note that the user can cancel, in which
  366.     case the default directory will be returned}
  367.     while not DiskInDrive(i) do
  368.      begin
  369.       DiskInDrive(i);
  370.      end;
  371.  
  372.    {floppy in drive, now check for directory}
  373.    if (length(sDrive) > 3) then {where 3 would be the size of 'a:\'}
  374.     begin
  375.      {check floppy for sub-dir}
  376.      if DirectoryExists(sDrive) then
  377.       result := true
  378.      else
  379.       result := false;
  380.     end
  381.    else
  382.     {user trying to copy to root of floppy drive}
  383.     result := true
  384.   end
  385.  else
  386.   {hard disk}
  387.   begin
  388.    {first, if sDrive is less than 3 characters then the user is trying to copy to a
  389.     root, in which case DirectoryExists will fail. If the routine has reached this stage
  390.     we should be sure that the drive is legal so return true}
  391.    if length(sDrive) <= 3 then
  392.     result := true
  393.    else
  394.    if DirectoryExists(sDrive) then
  395.     result := true
  396.    else
  397.     begin
  398.      messageDlg('"'+sDrive+'" Directory not found',mtWarning,[mbOK],0);
  399.      result := false;
  400.     end;
  401.   end;
  402.  
  403.  {finally, check that drive is a legal drive}
  404.  if DiskSize(i) = -1 then Result := False;
  405.  
  406. end;
  407.  
  408.  
  409. {check for floppy disk in drive}
  410. function TBackupDlg.DiskInDrive(i: integer): boolean;
  411. begin
  412.  if DiskSize(i) = -1 then
  413.   begin
  414.    if messageDlg('Please insert a floppy disk into the floppy drive',mtInformation,[mbOK,mbCancel],0)
  415.     = mrCancel then result := true
  416.    else
  417.     result := false
  418.   end
  419.  else
  420.   result := true;
  421. end;
  422.  
  423.  
  424. {set environment}
  425. procedure TBackupDlg.CustInitialise(pSource,pDestination,pHelp,pCompat: pChar; bOverwritePrompt: boolean);
  426. var
  427.  s: ^string;
  428. begin
  429.  
  430.  New(s);
  431.  
  432.  try
  433.  
  434.   {store current dir}
  435.   GetDir(0,FDir);
  436.  
  437.   {turn off DOS error reporting}
  438.   iErrorMode := SetErrorMode(SEM_FAILCRITICALERRORS);
  439.  
  440.   {set source dir}
  441.   if Assigned(pSource) then
  442.    begin
  443.     s^ := CheckDir( StrPAS(pSource) );
  444.     lblSource.Caption := LowerCase(s^);
  445.     FList.Directory := lblSource.caption;
  446.     DirList.Directory := lblSource.Caption;
  447.     DriveBox.Drive := DirList.Drive;
  448.    end;
  449.  
  450.   {set destination dir}
  451.   if Assigned(pDestination) then
  452.    begin
  453.     s^ := CheckDir( StrPAS(pDestination) );
  454.     lblDestination.Caption := LowerCase(s^);
  455.    end;
  456.  
  457.   {set help file}
  458.   if Assigned(pHelp) then
  459.    if FileExists(StrPAS(pHelp)) then Application.HelpFile := strPAS(pHelp);
  460.  
  461.   {set file mask}
  462.   if Assigned(pCompat) then
  463.    FList.Mask := StrPAS(pCompat)
  464.   else
  465.    FList.Mask := '*.*';
  466.  
  467.   {set bools}
  468.   FCancel := false;
  469.   FOkToAll := bOverwritePrompt; {store value, since OkToAll could be set to false by SetupFiles proc}
  470.   if bOverwritePrompt then
  471.    OkToAll := false
  472.   else
  473.    OkToAll := true;
  474.  
  475.   {set list box}
  476.   chkSelectClick(self);
  477.  
  478.  finally
  479.   Dispose(s);
  480.  end;
  481.  
  482. end;
  483.  
  484.  
  485. {***Exported Procedures*********************************************************}
  486.  
  487. {calls the dialog - invisible - and copies the file}
  488. procedure CopyIndivFile(pSourceFile,pDestinationFile: pChar);
  489. begin
  490.  {create dialog}
  491.  BackupDlg := TBackupDlg.Create(application);
  492.  try
  493.   if (StrPAS(pSourceFile) <> '') and (StrPAS(pDestinationFile) <> '') then
  494.    BackupDlg.CustCopyFiles(StrPAS(pSourceFile),StrPAS(pDestinationFile));
  495.  finally
  496.   BackupDlg.Free;
  497.  end;
  498. end;
  499.  
  500. {calls the dialog - invisible - and copies the file, expanding it if compressed}
  501. procedure ExpandIndivFile(pSourceFile,pDestinationFile: pChar);
  502. begin
  503.  {create dialog}
  504.  BackupDlg := TBackupDlg.Create(application);
  505.  try
  506.   if (StrPAS(pSourceFile) <> '') and (StrPAS(pDestinationFile) <> '') then
  507.    BackupDlg.CustExpandFile(pSourceFile,pDestinationFile);
  508.  finally
  509.   BackupDlg.Free;
  510.  end;
  511. end;
  512.  
  513.  
  514. {calls the dialog - visible}
  515. procedure ShowBackupDlg(pSource,pDestination,pHelp,pCompat: pChar; bOverwritePrompt: boolean);
  516. begin
  517.  {create dialog}
  518.  BackupDlg := TBackupDlg.Create(application);
  519.  ProgressDlg := TProgressDlg.create(application);
  520.  try
  521.  
  522.   {initialise}
  523.   BackupDlg.CustInitialise(pSource,pDestination,pHelp,pCompat,bOverwritePrompt);
  524.  
  525.   {show}
  526.   BackupDlg.ShowModal;
  527.  
  528.  finally
  529.   ProgressDlg.free;
  530.   BackupDlg.Free;
  531.  end;
  532.  
  533. end;
  534.  
  535. {calls the dialog - invisible and runs backup automatically}
  536. procedure HideBackupDlg(pSource,pDestination,pHelp,pCompat: pChar; bOverwritePrompt, bCopyNew: boolean);
  537. begin
  538.  {create dialog}
  539.  BackupDlg := TBackupDlg.Create(application);
  540.  ProgressDlg := TProgressDlg.create(application);
  541.  try
  542.  
  543.   {initialise}
  544.   BackupDlg.FNew := bCopyNew;
  545.   BackupDlg.CustInitialise(pSource,pDestination,pHelp,pCompat,bOverwritePrompt);
  546.  
  547.   {execute copy proc}
  548.   BackupDlg.SetupFiles;
  549.  
  550.  finally
  551.   ProgressDlg.free;
  552.   BackupDlg.Free;
  553.  end;
  554.  
  555. end;
  556.  
  557.  
  558. {***Buttons*********************************************************************}
  559.  
  560. {help}
  561. procedure TBackupDlg.BitBtn1Click(Sender: TObject);
  562. begin
  563.  Application.HelpCommand(HELP_CONTEXT,BackupDlg.HelpContext);
  564. end;
  565.  
  566. {on double click show file info}
  567. procedure TBackupDlg.FListDblClick(Sender: TObject);
  568. var
  569.  f: ^TFileInfo;
  570.  s: ^string;
  571. begin
  572.  
  573.  New(s);
  574.  New(f);
  575.  
  576.  try
  577.  
  578.   s^ := lblSource.caption;
  579.   if s^[length(s^)] = '\' then
  580.    s^ := s^ + ExtractFileName(Flist.Items[FList.ItemIndex])
  581.   else
  582.    s^ := s^ + '\' + ExtractFileName(Flist.Items[FList.ItemIndex]);
  583.   f^ := GetFileInfo(s^);
  584.   messageDlg(''+ s^ +#13#10+#13#10+
  585.              'Size: '+IntToStr(f^.size)+' bytes  Date:'+
  586.              DateTimeToStr(FileDateToDateTime(f^.date)),
  587.              mtInformation,[mbOK],0);
  588.  finally
  589.   Dispose(s);
  590.   Dispose(f);
  591.  end;
  592.  
  593. end;
  594.  
  595. {on ALT + RETURN get info}
  596. procedure TBackupDlg.FListKeyDown(Sender: TObject; var Key: Word;
  597.   Shift: TShiftState);
  598. begin
  599.  if (shift = [ssAlt]) and (key = VK_RETURN) then FListDblClick(sender);
  600. end;
  601.  
  602.  
  603. {close}
  604. procedure TBackupDlg.btnCancelClick(Sender: TObject);
  605. begin
  606.  close;
  607. end;
  608.  
  609. {check-box}
  610. procedure TBackupDlg.chkSelectClick(Sender: TObject);
  611. var
  612.  i: integer;
  613. begin
  614.  {check for select all - if true then select all items in list box}
  615.  screen.cursor := crHourGlass;
  616.  if chkSelect.state = cbChecked then
  617.   begin
  618.    {select all}
  619.    for i:= 0 to (FList.items.count -1) do
  620.     FList.selected[i] := true;
  621.    FList.ItemIndex := 0;
  622.   end;
  623.  screen.cursor := crDefault;
  624.  
  625.  
  626. end;
  627.  
  628. {check state of check-box. Then check if the user has deselected any
  629.  items. If so, and the check-box is checked, then remove check}
  630. procedure TBackupDlg.FListClick(Sender: TObject);
  631. var
  632.  i: integer;
  633. begin
  634.  screen.cursor := crHourGlass;
  635.  if chkSelect.checked = true then
  636.   begin
  637.    for i := 0 to (FList.Items.Count -1) do
  638.     begin
  639.      if FList.selected[i] = false then
  640.       chkSelect.checked := false;
  641.     end;
  642.    FList.ItemIndex := 0;
  643.   end;
  644.  screen.cursor := crDefault;
  645. end;
  646.  
  647.  
  648. {copy}
  649. procedure TBackupDlg.btnOKClick(Sender: TObject);
  650. begin
  651.  hide;
  652.  ProgressDlg.show;
  653.   {***}
  654.   SetUpFiles;
  655.   {***}
  656.  ProgressDlg.hide;
  657.  show;
  658.  
  659.  FCancel := false;
  660. end;
  661.  
  662. {Select Directory}
  663. procedure TBackupDlg.SpeedButton1Click(Sender: TObject);
  664. var
  665.  sDir: ^string;
  666. begin
  667.  
  668.  New(sDir);
  669.  
  670.  try
  671.  
  672.   {if directory exists, then set that as default in dialog}
  673.   if DirectoryExists(lblDestination.caption) then
  674.    sDir^ := lblDestination.caption
  675.   else
  676.    sDir^ := '';
  677.   if SelectDirectory(sDir^,[sdAllowCreate,sdPerformCreate],iHelp) then
  678.    lblDestination.caption := LowerCase( CheckDir(sDir^) );
  679.  
  680.   {user could return a blank, in which case use system default dir}
  681.   if lblDestination.caption = '' then
  682.    begin
  683.     GetDir(0,sDir^);
  684.     lblDestination.caption := LowerCase(sDir^);
  685.    end;
  686.  
  687.  finally
  688.   Dispose(sDir)
  689.  end;
  690.  
  691.  
  692. end;
  693.  
  694.  
  695. {***Copy procs******************************************************************}
  696.  
  697.  
  698. {setup copying}
  699. procedure TBackupDlg.SetUpFiles;
  700. var
  701.  iNum: integer;
  702.  sSrce, sDest: ^string;
  703.  li, liFree, liGauge, liGaugeNew: longint;
  704.  f: File;
  705.  fSrce, fDest: ^TFileInfo;
  706.  i: integer;
  707.  c: char;
  708. begin
  709.  
  710.  New(sSrce);
  711.  New(sDest);
  712.  New(fSrce);
  713.  New(fDest);
  714.  
  715.  try
  716.  
  717.   {initialise}
  718.   iNum := 0;
  719.  
  720.  
  721.  {ensure that directories exists - actually, at this stage both labels should be valid}
  722.  if not isDir(lblSource.caption) then
  723.   begin
  724.    exit;
  725.   end;
  726.  if not isDir(lblDestination.caption) then
  727.   begin
  728.    exit;
  729.   end;
  730.  
  731.  {check that the user is not trying to copy over source files}
  732.  if CompareText(lblSource.Caption,lblDestination.Caption) = 0 then
  733.   begin
  734.    messageDlg('Can not overwrite source files.',mtWarning,[mbOK],0);
  735.    exit;
  736.   end;
  737.  
  738.  {ensure that there are items in the file-list box}
  739.  if (FList.Items.Count) = 0 then
  740.   begin
  741.    exit;
  742.   end;
  743.  
  744.  {remove any backslashes from the captions}
  745.  sSrce^ := lblSource.caption;
  746.  if sSrce^[length(lblSource.caption)] = '\' then
  747.   delete(sSrce^,(length(sSrce^)),1);
  748.  lblSource.caption := sSrce^;
  749.  {***}
  750.  sSrce^ := lblDestination.caption;
  751.  if sSrce^[length(lblDestination.caption)] = '\' then
  752.   delete(sSrce^,(length(sSrce^)),1);
  753.  lblDestination.caption := sSrce^;
  754.  
  755.  
  756.  {check space on target}
  757.  li := 0;
  758.  liFree := 0;
  759.  liGauge := 0;
  760.  liGaugeNew := 0;
  761.  FList.ItemIndex := 0;
  762.  {increment through file list, adding up file sizes}
  763.  for iNum := 0 to (FList.Items.Count -1) do
  764.   begin
  765.    if FList.Selected[iNum] = true then
  766.     begin
  767.      inc(liGauge); {sum selected items for gauge}
  768.      System.FileMode := fmOpenRead;
  769.      {assign and open files}
  770.      AssignFile(f, lblSource.caption +'\'+ ExtractFileName(FList.Items.Strings[iNum]));
  771.      {$I-}
  772.      Reset(f,1);
  773.      {$I+}
  774.      if IOResult = 0 then
  775.       begin
  776.        {increment var holding the total size of source files}
  777.        li := li + FileSize(f);
  778.        {if target file exists, find its size}
  779.        if FileExists(lblDestination.caption +'\' + ExtractFileName(FList.Items.Strings[iNum])) then
  780.         begin
  781.          fDest^ := GetFileInfo(lblDestination.caption +'\' + ExtractFileName(FList.Items.Strings[iNum]));
  782.          liFree := liFree + fDest^.size;
  783.  
  784.          {With reference to the FNew bool, compare existing file date to source file
  785.           date. This is performed, so that we can amend the maxValue property of the gauge,
  786.           so it increments only on newer files}
  787.          fSrce^ := GetFileInfo(lblSource.caption +'\'+ ExtractFileName(FList.Items.Strings[iNum]));
  788.          if fDest^.date < fSrce^.date then inc(liGaugeNew);
  789.  
  790.         end;
  791.        CloseFile(f);
  792.       end;
  793.      System.FileMode := fmOpenReadWrite;
  794.     end;
  795.   end;
  796.  {get drive letter}
  797.  c := lblDestination.caption[1];
  798.  if c in ['a'..'z'] then Dec(c,($20));
  799.  i :=  ord (c) -$40;
  800.  {find target disk size}
  801.  if li > DiskSize(i) then
  802.   begin
  803.    messageDlg('Insufficient space on target for all of the selected files',mtWarning,[mbOK],0);
  804.    exit;
  805.   end;
  806.  {find target free - we add, to free space, the size of the existing files since the user
  807.   is probably going to overwrite them}
  808.  liFree := liFree + DiskFree(i);
  809.  if li > liFree then
  810.   begin
  811.    messageDlg('Insufficient free space on target for selected files',mtWarning,[mbOK],0);
  812.    exit;
  813.   end;
  814.  
  815.  
  816.  {now, safe to continue with copy...}
  817.  if isWindowVisible(progressDlg.handle) then
  818.   ProgressDlg.Gauge1.MaxValue := liGauge;
  819.  
  820.  {init for loop}
  821.  for iNum := 0 to (FList.Items.Count -1) do
  822.   begin
  823.    if FCancel = true then break;
  824.    if FList.Selected[iNum] = true then
  825.     begin
  826.  
  827.      {get source file name}
  828.      sSrce^ := lblSource.caption +'\'+ ExtractFileName(FList.Items.Strings[iNum]);
  829.  
  830.      {get destination file name}
  831.      sDest^ := lblDestination.caption + '\' + (ExtractFileName(FList.Items.Strings[iNum]));
  832.  
  833.    {check to see if file exists}
  834.    if not FNew then
  835.     if not OkToAll then
  836.     begin
  837.  
  838.      {update labels}
  839.      progressDlg.lblSource.caption := sSrce^;
  840.      progressDlg.lblDestination.caption := sDest^;
  841.      application.processMessages;
  842.  
  843.      if FileExists(sDest^) then
  844.       begin
  845.  
  846.        {since file exists, we must get info of both source and target files}
  847.        fSrce^ := GetFileInfo(sSrce^);
  848.        fDest^ := GetFileInfo(sDest^);
  849.  
  850.        case messageDlg('Overwrite '+sDest^+ #13#10 +
  851.                        'Size: '+IntToStr(fDest^.size)+' bytes  Date:'
  852.                        +dateTimeToStr(FileDateToDateTime(fDest^.date))+ #13#10 + #13#10 +
  853.                        'with: '+sSrce^+ #13#10 +
  854.                        'Size: '+IntToStr(fSrce^.size)+' bytes  Date:'+
  855.                        DateTimeToStr(FileDateToDateTime(fSrce^.date))+ #13#10 + #13#10,
  856.                        mtConfirmation,[mbYes,mbAll,mbNo],0) of
  857.  
  858.         idYes:
  859.          custCopyFiles(sSrce^,sDest^);
  860.  
  861.         (idNo+1): {mrAll}
  862.          begin
  863.           OkToAll := true;
  864.           custCopyFiles(sSrce^,sDest^);
  865.          end;
  866.  
  867.         idNo:
  868.         {do nothing}
  869.  
  870.        end;
  871.       end
  872.      else
  873.      {file doesn't already exist - so copy}
  874.      custCopyFiles(sSrce^,sDest^);
  875.     end
  876.    else
  877.     {file does already exist, but overwrite is true}
  878.     custCopyFiles(sSrce^,sDest^)
  879.   else
  880.    begin
  881.     {only copy the file if the source is newer than the destination}
  882.     progressDlg.Gauge1.MaxValue := liGaugeNew;
  883.     fSrce^ := GetFileInfo(sSrce^);
  884.     fDest^ := GetFileInfo(sDest^);
  885.     if fDest^.Date < fSrce^.Date then
  886.      begin
  887.       {update labels}
  888.       progressDlg.lblSource.caption := sSrce^;
  889.       progressDlg.lblDestination.caption := sDest^;
  890.       application.processMessages;
  891.       custCopyFiles(sSrce^,sDest^);
  892.      end
  893.     else
  894.      begin
  895.       {update labels}
  896.       progressDlg.lblSource.caption := sSrce^;
  897.       progressDlg.lblDestination.caption := 'skipping...';
  898.       application.processMessages;
  899.      end;
  900.    end;
  901.  
  902.    {update gauge}
  903.    if isWindowVisible(progressDlg.handle) then
  904.     ProgressDlg.Gauge1.AddProgress(1);
  905.    Application.ProcessMessages;
  906.  
  907.   end;
  908.  end;
  909.  
  910.  {cleanup}
  911.  if isWindowVisible(progressDlg.handle) then
  912.   ProgressDlg.Gauge1.Progress := 0;
  913.  if FOkToAll then
  914.   okToAll := false
  915.  else
  916.   okToAll := true;
  917.  
  918.  finally
  919.   Dispose(sSrce);
  920.   Dispose(sDest);
  921.   Dispose(fDest);
  922.   Dispose(fSrce);
  923.  end;
  924.  
  925.  {add backslash to labels of two characters}
  926.  if length(lblSource.caption) = 2 then lblSource.caption := lblSource.caption + '\';
  927.  if length(lblDestination.caption) = 2 then lblDestination.caption := lblDestination.caption + '\';
  928.  
  929. end;
  930.  
  931.  
  932. {copy routine}
  933. procedure TBackupDlg.CustCopyFiles(sSrce,sDest: string);
  934. type
  935.   iobufPtr = ^iobufr; {allowate a LARGE buffer to speed up copies}
  936.   iobufr   = array[0..32767] of char; {MAX=65535}
  937. var
  938.  fSrce, fDest: file;
  939.  wRead, wWritten: word;
  940.  p: iobufPtr;
  941.  FDate: Longint;
  942. begin
  943.  
  944.  
  945.   {initialise}
  946.   wRead := 0;
  947.   wWritten := 0;
  948.  
  949.   {Set file access mode to readonly in case file is in use.}
  950.   System.FileMode := fmOpenRead;
  951.    {assign and open files}
  952.    AssignFile(fSrce,sSrce);
  953.    {$I-}
  954.    Reset(fSrce,1);
  955.    {$I+}
  956.   {Set file access mode back to normal default for other processes}
  957.   System.Filemode := fmOpenReadWrite;
  958.   if IOResult <> 0  then
  959.    begin
  960.     messageDlg('Could not open: '+sSrce,mtWarning,[mbOK],0);
  961.     exit;
  962.    end;
  963.   {Store file Date & Time for later use}
  964.   FDate := FileGetDate(TFileRec(fSrce).Handle);
  965.  
  966.   {before creating new file, check that there is sufficient free space}
  967.   if isSpace(sDest) > FileSize(fSrce) then
  968.    begin
  969.     {Set file access mode to allow Exclusive Creation }
  970.     System.Filemode := fmOpenWrite and fmShareExclusive;
  971.     AssignFile(fDest,sDest);
  972.     {$I-}
  973.     Rewrite(fDest, 1);
  974.     {$I+}
  975.     {Set file access mode back to normal default for other processes}
  976.     System.Filemode := fmOpenReadWrite;
  977.  
  978.     if IOResult <> 0  then
  979.      begin
  980.       {Close the Source file we already have open.}
  981.       System.CloseFile(fSrce);
  982.       messageDlg('Could not create: '+sDest,mtWarning,[mbOK],0);
  983.       exit;
  984.      end;
  985.    end
  986.   else
  987.    begin
  988.     {this message should only ever be seen if the CopyIndivFile call is used to
  989.      open the DLL}
  990.     if messageDlg('There is insufficient space on the target drive'+#13#10+
  991.                   'for: '+ sSrce +#13#10+#13#10+
  992.                   'Do you wish to cancel the copy process?',mtConfirmation,[mbYes,mbNo],0)
  993.      = mrYes then FCancel := true;
  994.     exit;
  995.    end;
  996.  
  997.  
  998.   {allocate a file iobuffer on Heap to avoid stack overflow error}
  999.   new(p);
  1000.  
  1001.   {copy loop}
  1002.    repeat
  1003.     BlockRead(fSrce, p^, SizeOf(p^), wRead);
  1004.     BlockWrite(fDest, p^, wRead, wWritten);
  1005.    until (wRead = 0) or (wWritten <> wRead);
  1006.  
  1007.    {release heap space for iobuffer }
  1008.    dispose(p);
  1009.  
  1010.    {restore Source file date & time to Destination file }
  1011.    Reset(fDest,1);
  1012.    FileSetDate(TFileRec(fDest).Handle,FDate);
  1013.    System.CloseFile(fDest);
  1014.  
  1015.    {clean up}
  1016.    System.CloseFile(fSrce);
  1017.  
  1018. end;
  1019.  
  1020.  
  1021. {expansion routine - uses LZExpand unit to expand the files}
  1022. procedure TbackupDlg.CustExpandFile(pSrce, pDest: pChar);
  1023. var
  1024.  iDest, iSrce: integer;
  1025.  tStruct: TOFStruct;
  1026.  p: pChar;
  1027. begin
  1028.  
  1029.  p := StrAlloc(256);
  1030.  
  1031.  try
  1032.  
  1033.   {change file extension}
  1034.   StrPCopy(p, ChangeExt( StrPAS(pDest) ) );
  1035.  
  1036.  {open source}
  1037.  iSrce := _lopen(pSrce,OF_SHARE_COMPAT);
  1038.  if iSrce = 0 then
  1039.   begin
  1040.    messageDlg('Could not create: '+StrPAS(pSrce),mtWarning,[mbOK],0);
  1041.    exit;
  1042.   end;
  1043.  
  1044.  {open target}
  1045.  iDest := LZOpenFile(p,tStruct,OF_CREATE);
  1046.  if iDest = 0 then
  1047.   begin
  1048.    messageDlg('Could not create: '+StrPAS(p),mtWarning,[mbOK],0);
  1049.    exit;
  1050.   end;
  1051.  
  1052.  {expand}
  1053.  if LZCopy(iSrce,iDest) < 0 then
  1054.   begin
  1055.    messageDlg('Could not expand: '+StrPAS(pSrce),mtWarning,[mbOK],0);
  1056.    exit;
  1057.   end;
  1058.  
  1059.  {close}
  1060.  if _lclose(iSrce) <> 0 then
  1061.   begin
  1062.    messageDlg('Could not close: '+StrPAS(pSrce),mtWarning,[mbOK],0);
  1063.    exit;
  1064.   end;
  1065.  
  1066.  {close}
  1067.  if _lclose(iDest) <> 0 then
  1068.   begin
  1069.    messageDlg('Could not close: '+StrPAS(p),mtWarning,[mbOK],0);
  1070.    exit;
  1071.   end;
  1072.  
  1073.  finally
  1074.   StrDispose(p);
  1075.  end;
  1076.  
  1077. end;
  1078.  
  1079.  
  1080. {***form's preferences**********************************************************}
  1081.  
  1082. {on close}
  1083. procedure TBackupDlg.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
  1084. begin
  1085.   {reset system}
  1086.   chDir(FDir);
  1087.   SetErrorMode(iErrorMode);
  1088. end;
  1089.  
  1090. {new}
  1091. procedure TBackupDlg.chkNewClick(Sender: TObject);
  1092. begin
  1093.  FNew := chkNew.checked;
  1094. end;
  1095.  
  1096.  
  1097. {}
  1098. end.
  1099.  
  1100.  
  1101.  
  1102.