[Back to COPYMOVE SWAG index] [Back to Main SWAG index] [Original]

    {
    I found a source * COPY.PAS * (don't know where anymore or who posted it) and
    tried to Write my own move_Files Program based on it.

    The simple idea is to move the Files specified in paramstr(1) to a destination
    directory specified in paramstr(2) and create the directories that do not yet
    exist.

    On a first look it seems just to work out ok. But yet it does not.

    to help me find the failure set paramstr(1) to any path you want (For example
    D:\test\*.txt or whatever) and set paramstr(2) to a non existing path which is
    C:\A\B\C\D\E\F\G\H\..\Z\A\B\C\D\E\F\

    The directories C:\A through C:\A\B\C\D\F\..\Q\R\S will be created and than the
    Program hangs.

    Who can help me find what the mistake is?

    I Really will be grateful For any kind of help.

    The code is:
    }

    {$A+,B-,D+,E+,F-,G-,I-,L+,N-,O-,R+,S-,V+,X-}
    Program aMOVE;

    Uses
      Crt, Dos;
    Const
      BufSize = 32768;
    Var
      ioCode               : Byte;
      SrcFile, DstFile     : File;
      FileNameA,
      FileNameB            : String;
      Buffer               : Array[1..BufSize] of Byte;
      RecsRead             : Integer;
      DiskFull             : Boolean;
      CurrDir              : DirStr;        {Aktuelles Verzeichnis speichern}
      HelpList             : Boolean;       {Hilfe uber mogliche Parameter?}
      i,
      n                    : Integer;
      str                  : String[1];

      SDStr                : DirStr;        {Quellverzeichnis}
      SNStr                : NameStr;       {Quelldateiname}
      SEStr                : ExtStr;        {Quelldateierweiterung}

      DDStr                : DirStr;        {Zielverzeichnis}
      DNStr                : NameStr;       {Zieldateiname}
      DEStr                : ExtStr;        {Zieldateierweiterung}

      SrcInfo              : SearchRec;     {Liste der Quelldateien}
      SubDirStr            : Array [0..32] of DirStr;
      key                  : Char;

      Procedure SrcFileError(ioCode : Byte);
      begin
        Write(#7, 'I/O result of ', ioCode, ' (decimal) ', #26);
        Case ioCode of
          $01 : WriteLn(' Source File not found.');
          $F3 : WriteLn(' too many Files open.');
        else WriteLn(' "Reset" unknown I/O error.');
        end;
      end;

      Procedure DstFileError(ioCode : Byte);
      begin
        Write(#7, 'I/O result of ', ioCode, ' (decimal) ', #26);
        Case ioCode of
          $F0 : WriteLn(' Disk data area full.');
          $F1 : WriteLn(' Disk directory full.');
          $F3 : WriteLn(' too many Files open.');
        else WriteLn(' "ReWrite" unknown I/O error.');
        end;
      end;

    Procedure EXPAR;                      {externe Parameter abfragen} begin
      GetDir(0,CurrDir);                  {Aktuelles Verzeichnis speichern}
      if DDStr='' then DDStr:= CurrDir;   {Wenn keine Zialangabe, dann ins
                                           aktuelle Verzeichnis verschieben}
      FSplit(paramstr(1), SDStr, SNStr, SEStr);
    end;

    Procedure Copy2Dest;
    begin
      if FileNameB <> FileNameA then
        begin
          Assign(SrcFile, FileNameA);
          Assign(DstFile, FileNameB);
          {* note second parameter in "reset" and "reWrite" of UNTyped Files. *}
          {$I-} Reset(SrcFile, 1); {$I+}
          ioCode := Ioresult;
          if (ioCode <> 0) then SrcFileError(ioCode)
          else
            begin
              {$I-} ReWrite(DstFile, 1); {$I+}
              ioCode := Ioresult;
              if (ioCode <> 0) then DstFileError(ioCode)
              else
                begin
                  DiskFull := False;
                  While (not EoF(SrcFile)) and (not DiskFull) do
                    begin
                      {* note fourth parameter in "blockread". *}
                      {$I-}
                      BlockRead(SrcFile, Buffer, BufSize, RecsRead);
                      {$I+}
                      ioCode := Ioresult;
                      if ioCode <> 0 then
                        begin
                          SrcFileError(ioCode);
                          DiskFull := True
                        end
                      else
                        begin
                          {$I-}
                          BlockWrite(DstFile, Buffer, RecsRead);
                          {$I+}
                          ioCode := Ioresult;
                          if ioCode <> 0 then
                            begin
                              DstFileError(ioCode);
                              DiskFull := True
                            end
                        end
                    end;
                  if not DiskFull then WriteLn(FileNameB)
                end;
              Close(DstFile)
            end;
          Close(SrcFile)
        end
      else WriteLn(#7, 'File can not be copied onto itself.')
    end;

    Procedure ProofDest;
    begin
      if length(paramstr(2)) > 67 then begin
        Writeln;
        Writeln(#7,'Invalid destination directory specified.');
        Writeln('Program aborted.');
        Halt(1);
      end;
      FSplit(paramstr(2), DDStr, DNStr, DEStr);
      if copy(DNStr,length(DNStr),1)<>'.' then begin
        insert(DNStr,DDStr,length(DDStr)+1);
        DNStr:='';
      end;
      if copy(DDStr,length(DDStr),1)<>'\' then
        insert('\',DDSTR,length(DDStr)+1);
      SubDirStr[0]:= DDStr;
      For i:= 1 to 20 do begin
        SubDirStr[i]:=copy(DDStr,1,pos('\',DDStr));
        Delete(DDStr,1,pos('\',DDStr));
      end;
      For i:= 32 doWNto 1 do begin
        if SubDirStr[i]= '' then n:= i-1;
      end;

      DDStr:= SubDirStr[0];
      SubDirStr[0]:='';

      For i:= 1 to n do begin
        SubDirStr[0]:= SubDirStr[0]+SubDirStr[i];

        if copy(SubDirStr[0],length(SubDirStr[0]),1)='\' then
          delete(SubDirStr[0],length(SubDirStr[0]),1);

     begin
          {$I-}
          MkDir(SubDirStr[0]);
          {$I+}
          if Ioresult = 0 then
          WriteLn('New directory created: ', SubDirStr[0]);
        end;

        if copy(SubDirStr[0],length(SubDirStr[0]),1)<>'\' then
          insert('\',SubDirStr[0],length(SubDirStr[0])+1);
      end;
    end;

    Procedure HandleMove;
    begin
      FileNameA:= SDStr+SrcInfo.Name;
      FileNameB:= DDStr+SrcInfo.Name;
      Copy2Dest;
      Erase(SrcFile);
    end;

    Procedure ExeMove;
    begin
      ProofDest;
      FindFirst(paramstr(1), AnyFile, SrcInfo);
      While DosError = 0 do begin
        HandleMove;
        FindNext(SrcInfo);
      end;
    end;

    begin
      SDStr:= '';
      SNStr:= '';
      SEStr:= '';
      DDStr:= '';
      DNStr:= '';
      DEStr:= '';
      For i:=0 to 32 do SubDirStr[i]:='';
      ExPar;
      ExeMove;
    end.

[Back to COPYMOVE SWAG index] [Back to Main SWAG index] [Original]