vclzip.pas

天涯進銷存系統

     zfile.Free;
     zfile := nil;
     Inc(CurrentDisk);
     tmpZipName := ChangeFileExt(tmpZipName, '.'+Format('%3.3d',[CurrentDisk+1]));
     AmountToWrite := MultiZipInfo.BlockSize;
   end;
  zfile := TLFNFileStream.CreateFile( tmpZipName, fmCreate, FFlushFilesOnClose, BufferedStreamSize );
  AmountWritten := 0;
  tmpecrec.num_entries_this_disk := 0;
 end;
end;

function TVCLZip.AddFileToZip( FName: String ): Boolean;
var
  SavePos: LongInt;
  tmpDir: String;
  Idx: Integer;
  Skip: Boolean;
  {tempPathPStr: array [0..PATH_LEN] of char;}
  {PathSize: LongInt;}

  procedure CalcFileCRC;
  { Modified to use a PChar for cbuffer 4/12/98  2.11 }
  const
      {BLKSIZ = OUTBUFSIZ;}
      BLKSIZ = DEF_BUFSTREAMSIZE;
  var
     cbuffer: PChar;
     AmountRead: LongInt;
     AmtLeft: LongInt;
  begin
     AmtLeft := 0;
     cbuffer := nil;

     If (not MemZipping) then
      GetMem(cbuffer,BLKSIZ);
     try
        Crc32Val := $FFFFFFFF;
        If (MemZipping) then
         begin
           cbuffer := MemBuffer;
           AmountRead := kpmin(MemLen,BLKSIZ);
           AmtLeft := MemLen - AmountRead;
         end
        Else
        AmountRead := IFile.Read(cbuffer^, BLKSIZ);
        While AmountRead <> 0 do
         begin
           Update_CRC_buff(BytePtr(cbuffer), AmountRead);
           If (MemZipping) then
            begin
              Inc(cbuffer, AmountRead);
              AmountRead := kpmin(AmtLeft, BLKSIZ);
              { Inc(cbuffer, AmountRead); } { Moved up 2 lines 5/15/00 2.20++ }
              Dec(AmtLeft, AmountRead);
            end
           Else
           AmountRead := IFile.Read(cbuffer^, BLKSIZ);
         end;
         If (not MemZipping) then
         IFile.Seek(0, soFromBeginning);
     finally
         If (not MemZipping) then
         FreeMem(cbuffer,BLKSIZ);
     end;
  end;

  procedure SaveMFile;
  var
     AmtToCopy: LongInt;
     TotalAmtToCopy: LongInt;
     progressAmt: LongInt;
     progressDone: LongInt;
     progressPartition: LongInt;
     Percent: LongInt;
  const
       SPAN_BUFFER_SIZE = $4000;
  begin
     progressDone := 0;
     progressAmt := 0;
     If RoomLeft <= 0 then  { changed to <= 05/23/00  2.21PR2+ }
        NextPart;
     If Assigned(FOnFilePercentDone) then
      begin
        progressAmt := tmpfile_info.uncompressed_size + mfile.Size;
        progressDone := tmpfile_info.uncompressed_size;
      end;
     If Assigned(FOnTotalPercentDone) then {Need to adjust for the diff since guessed}
       TotalUnCompressedSize := TotalUnCompressedSize-(tmpfile_info.uncompressed_size-mfile.Size);
     mfile.Seek(0, soFromBeginning);
     TotalAmtToCopy := mfile.Size;
     AmtToCopy := kpmin( RoomLeft, TotalAmtToCopy );
     If (mfile.Size = 0) then
        AmtToCopy := 0;
     While (TotalAmtToCopy > 0) and (AmtToCopy > 0) do
      begin
        Dec(TotalAmtToCopy,AmtToCopy);
        If Assigned(FOnFilePercentDone) or Assigned(FOnTotalPercentDone) then
         begin
           While (AmtToCopy > 0) do
            begin
              progressPartition := kpmin(SPAN_BUFFER_SIZE, AmtToCopy);
              zfile.CopyFrom( mfile, progressPartition );
              Inc(progressDone, progressPartition);
              If Assigned(FOnFilePercentDone) then
               begin
                 Percent := CRate( progressAmt, progressDone );
                 OnFilePercentDone( self, Percent );
               end;
              If Assigned(FOnTotalPercentDone) then
               begin
                 TotalBytesDone := TotalBytesDone + progressPartition;
                 Percent := CBigRate( TotalUncompressedSize, TotalBytesDone );
                 OnTotalPercentDone( self, Percent );
               end;
              Dec(AmtToCopy,progressPartition);
            end;
         end
        Else
           zfile.CopyFrom( mfile, AmtToCopy );
        If (TotalAmtToCopy > 0) or (RoomLeft <= 0) then
           NextPart;
        AmtToCopy := kpmin( RoomLeft, TotalAmtToCopy );
      end;
  end;

  procedure StoreFile;
  const
     BLKSIZ = OUTBUFSIZ;
  var
     storeBuf: BytePtr;
     bytesRead: LongInt;
  begin
     GetMem(storeBuf, BLKSIZ);
     try
         bytesRead := file_read(storeBuf,BLKSIZ);
         While bytesRead > 0 do
          begin
           zfwrite(storeBuf,1,bytesRead);
           bytesRead := file_read(storeBuf,BLKSIZ);
          end;
     finally
        FreeMem(storeBuf,BLKSIZ);
     end;
  end;

var
  tmpRootDir: String;
  DrivePart:  String;
  IsDir:      Boolean;
  tmpDirName: String;
  SearchRec:  TSearchRec;
  Retry:      Boolean;

begin   { ************* AddFileToZip Procedure ***************** }
  Result := False;
  FileBytes := 0;
  IFileName := FName;
  tmpRootDir := RootDir; { 5/3/98 2.12 }
  If FName[Length(FName)] = '\' then
     IsDir := True
  Else
     IsDir := False;

  If IsDir then
   begin
     If (StreamZipping) or (MemZipping) or (not DirExists(FName)) then
        tmpfile_info.last_mod_file_date_time := DateTimeToFileDate( Now )
     Else
      begin
        tmpDirName := Copy(FName,1,Length(FName)-1);
        If FindFirst( tmpDirName, faAnyFile, SearchRec ) = 0 then
         begin
           tmpfile_info.last_mod_file_date_time := SearchRec.Time;
           FindClose(SearchRec);   { 09/14/01  2.22+ }
         end
        Else
           tmpfile_info.last_mod_file_date_time := DateTimeToFileDate( Now );
      end;
     tmpfile_info.uncompressed_size := 0;
     tmpfile_info.compressed_size := 0;
     tmpfile_info.compression_method := STORED;
     tmpfile_info.internal_file_attributes := BINARY; { assume binary if STOREing - for now. 10/18/98 }
     tmpfile_info.crc32 := 0;
     If DirExists( FName ) then
        tmpfile_info.external_file_attributes := FileGetAttr( FName );
   end
  Else If (not StreamZipping) and (not MemZipping) and (not IsDir) then
   begin
     If not FileExists( FName ) then
        exit;
     tmpfile_info.external_file_attributes := FileGetAttr( FName );
     Retry := False;
     Repeat
     try
        {IFile := TLFNFileStream.CreateFile( FName, fmOpenRead or fmShareDenyNone, False );}
        IFile := TLFNFileStream.CreateFile( FName, fmOpenRead or FFileOpenMode, False, BufferedStreamSize );
        Retry := False;
     except
        Retry := False;
        If Assigned( FOnSkippingFile ) then
           FOnSkippingFile( self, srFileOpenError, FName, -1, Retry );
        If not Retry then
           exit;
     end;
     Until (Retry = False);
     tmpfile_info.last_mod_file_date_time := FileGetDate( TLFNFileStream(IFile).Handle );
  end
  Else
   begin
     If (StreamZipping) then
        IFile := ZipStream;
     tmpfile_info.last_mod_file_date_time := DateTimeToFileDate( Now );
   end;
  mfile := nil;
 try
  If (MemZipping) and (not IsDir) then
     tmpfile_info.uncompressed_size := MemLen
  Else If (not IsDir) then
     tmpfile_info.uncompressed_size := IFile.Size;
  {$IFDEF WIN32}
  If FStore83Names then
   begin
    FName := LFN_ConvertLFName(FName,SHORTEN);
    If tmpRootDir <> '' then
     tmpRootDir := LFN_ConvertLFName(RootDir,SHORTEN);
   end;
  {$ELSE}
  {$IFNDEF NOLONGNAMES}  { 4/12/98 2.11 }
  If (not FStore83Names) and (OSVersion > 3) then
   begin
     FName := LFN_ConvertLFName(FName,LENGTHEN);
     If tmpRootDir <> '' then
        tmpRootDir := LFN_ConvertLFName(RootDir,LENGTHEN);
   end;
  {$ENDIF}
  {$ENDIF}
  if (OEMConvert) then
     OEMFilter(FName);
  If (not IsDir) then
     tmpfile_info.filename := ExtractFileName(FName)
  Else
     tmpfile_info.filename := '';

     tmpfile_info.relative_offset := zfile.Position;

     tmpfile_info.internal_file_attributes := UNKNOWN;
     tmpfile_info.disk_number_start := CurrentDisk;
  If FStorePaths then
   begin
     tmpDir := ExtractFileDir(Fname) + '\';
     If RightStr( tmpDir, 2 ) = '\\' then      {Incase it's the root directory 3/10/98 2.03}
        SetLength(tmpDir, Length(tmpDir)-1);
     If (tmpRootDir <> '') and (RelativePaths) and (AnsiCompareText(LeftStr(tmpDir,Length(tmpRootDir)),tmpRootDir)=0) then
      begin
        If (AnsiCompareText(tmpRootDir,tmpDir)=0) then
           tmpDir := ''
        Else
           Delete( tmpDir, 1, Length(tmpRootDir));
      end;
     { added the following 3/26/98 to handle UNC paths. 2.1 }
     If {(not RelativePaths) and} (not FStoreVolumes) and (tmpDir <> '') then
      begin
        DrivePart := ExtractFileDrive(tmpdir);
        if DrivePart <> '' then
           Delete(tmpdir, 1, Length(DrivePart));
        if LeftStr(tmpdir,1) = '\' then
           Delete(tmpdir,1,1);
      end;
  tmpfile_info.directory := tmpDir;
     {The filename_length now gets set automatically when setting the directory
      or filename  Nov 16, 1997 KLB }
  {tmpfile_info.filename_length := Length(tmpfile_info.directory+tmpfile_info.filename);}
  end;
   {The filename_length now gets set automatically when setting the directory
    or filename  Nov 16, 1997 KLB }
 {Else
  tmpfile_info.filename_length := Length(tmpfile_info.filename);}

  { If a file by the same name is already archived then skip this one }
  If tmpfiles.Search( Pointer(tmpfile_info), Idx ) then
   begin
     Result := False;
     { This is sort of a cludge but it works for now }
     If Assigned( FOnSkippingFile ) then
      begin
        FOnSkippingFile( self, srNoOverwrite, FName, -1, Retry );
      end;
     If (not StreamZipping) and (not MemZipping) and (not IsDir) then
      begin
        TotalUncompressedSize := TotalUncompressedSize - IFile.Size;
        IFile.Free;
        IFile := nil;
      end;
     exit;
   end;

  Skip := False;
  If Assigned( FOnStartZip ) then
     FOnStartZip( Self, FName, tmpfile_info, Skip );
  If Skip then
   begin
     If (not StreamZipping) and (not MemZipping) and (not IsDir) then
      begin
        TotalUncompressedSize := TotalUncompressedSize - IFile.Size;
        IFile.Free;
        IFile := nil;
      end;
     Result := False;
     exit;
   end;

  {Save local header for now, will update when done}
  If (MultiZipInfo.MultiMode <> mmNone) and (RoomLeft <= tmpfile_info.LocalSize) { and (not IsDir) } then
   begin                                  { 2/1/98 Changed the above from < to <= }
     NextPart;
     tmpfile_info.disk_number_start := CurrentDisk; { 2/1/98 }
     tmpfile_info.relative_offset := 0;  { Added 05/23/00 2.21PR2+ }
   end;
  If (MultiZipInfo.MultiMode <> mmNone) and (not IsDir) then
    begin
     {PathSize := GetTempPath( SizeOf(tempPathPStr), @tempPathPStr[0] );}
     { Changed to TempFilename  5/5/98  2.12 }
     mZipName := TempFilename(TemporaryPath);
     {mZipName := StrPas(tempPathPStr) + 'KPy76p09.tmp';}
     mfile := TLFNFileStream.CreateFile( mZipName, fmCreate, FFlushFilesOnClose, BufferedStreamSize );
    end
  else  { Added this else 2/5/00 2.20+ }
     tmpfile_info.SaveLocalToStream( zfile );
  {SavePos := zfile.Position;}
  If (IsDir) then
   begin
     If Assigned(FOnEndZip) then
        FOnEndZip( Self, FName, 0, 0, 0 );
     Result := True;
     exit;
   end;

  If (Password <> '') and (not IsDir) then
   begin
     CalcFileCRC;
     Crc32Val := not Crc32Val;
     tmpfile_info.crc32 := Crc32Val;
     crypthead( Password );
   end;
  Crc32Val := $FFFFFFFF;
  {$IFDEF KPDEMO}
     If not DR then
        tmpfile_info.filename := '';
  {$ENDIF}

  {*************** HERE IS THE CALL TO ZIP ************************}
  If (PackLevel = 0) or (IsInNoCompressList(tmpfile_info.filename)) then  { 10/23/98  2.16+ }
   begin
     StoreFile;
     tmpfile_info.compressed_size := tmpfile_info.uncompressed_size;
     tmpfile_info.compression_method := STORED;
     tmpfile_info.internal_file_attributes := BINARY; { assume binary if STOREing - for now. 10/18/98 }
   end
  Else
     tmpfile_info.compressed_size := Deflate;  { Compress the file!! }
  {****************************************************************}

{  Assert(  tmpfile_info.compressed_size = zfile.Seek(0, soFromCurrent) - SavePos, }
{           'Deflate returned wrong compressed size.');         }
  Crc32Val := not Crc32Val;
  SavePos := zfile.Position;
  zfile.Seek(tmpfile_info.relative_offset, soFromBeginning);
  tmpfile_info.crc32 := Crc32Val;
  If Password <> '' then
   begin  { Mark the file as encrypted and modify compressed size
            to take into account the 12 byte encryption header    }
     tmpfile_info.general_purpose_bit_flag := tmpfile_info.gene