vclzip.pas

一个delphi中压缩的组件VCLZip

  FDispose := False;
  FStorePaths := False;
  FStoreVolumes := False;
  FZipAction := zaUpdate;  {update only if newer}
  FBlockSize := 1457600;
  FRelativePaths := False;
  FStore83Names := False;
  FTempPath := '';
  Deleting := False;
  zfile := nil;
  tmpfiles := nil;
  tmpecrec := nil;
  TRInitialized := False;
  SaveNewName := '';
  {$IFDEF UNDER_DEVELOPMENT}
  FOtherVCLZip := nil;   { 10/24/99 2.20b3+ }
  {$ENDIF}
  StaticInit;
  CreatingSFX := False;
  FSkipIfArchiveBitNotSet := False; { 7/4/98 2.13 }
  FResetArchiveBitOnZip := False; { Added 4-Jun-98 SPF 2.13? }
  FExcludeList := TStringList.Create;  { 9/27/98  2.15 }
  FnoCompressList := TStringList.Create;  { 9/27/98  2.15 }
  FPreserveStubs := False; { 01/12/99  2.17 }
  FAddDirEntries := False; { 06/09/99 2.18+ }
  FFileOpenMode := fmShareDenyNone; { 10/17/99 2.18+ }  { changed back to fmShareDenyNone }
                                                        { 05/13/00 2.20+  }
end;

destructor TVCLZip.Destroy;
begin
  FMultiZipInfo.Free;
  FMultiZipInfo := nil; { 4/25/98  2.11 }
  If (FExcludeList <> nil) then
     FExcludeList.Free;  { 9/27/98  2.15 }
  If (FNoCompressList <> nil) then
     FNoCompressList.Free;  { 9/27/98  2.15 }
  inherited Destroy;
end;

procedure TVCLZip.Loaded;
begin
  inherited Loaded;
  SetCheckDiskLabels( FMultiZipInfo.CheckDiskLabels );
  SetMultiMode( FMultiZipInfo.MultiMode );
end;
procedure TVCLZip.StaticInit;
begin
  ZeroMemory( @static_ltree, SizeOf(static_ltree) );
  ZeroMemory( @static_dtree,  SizeOf(static_dtree) );
  ZeroMemory( @bl_count, SizeOf(bl_count) );
  ZeroMemory( @base_dist, SizeOf(base_dist) );
  ZeroMemory( @length_code, SizeOf(length_code) );
  ZeroMemory( @dist_code, SizeOf(dist_code) );
  ZeroMemory( @base_length, SizeOf(base_length) );
end;

procedure TVCLZip.Assign(Source: TPersistent);  { 6/27/99 2.18+ }
begin
  if source is TVCLZip then
  begin
    inherited Assign(Source);
    FPackLevel:= TVCLZip(Source).PackLevel;
    FRecurse:= TVCLZip(Source).Recurse;
    FDispose:= TVCLZip(Source).Dispose;
    FStorePaths:= TVCLZip(Source).StorePaths;
    FRelativePaths:= TVCLZip(Source).RelativePaths;
    FStoreVolumes:= TVCLZip(Source).StoreVolumes;
    FZipAction:= TVCLZip(Source).ZipAction;
    FMultiZipInfo.Assign(TVCLZip(Source).MultiZipInfo);
    FStore83Names:= TVCLZip(Source).Store83Names;
    FTempPath:= TVCLZip(Source).TempPath;  { 5/5/98  2.12 }
    FSkipIfArchiveBitNotSet:= TVCLZip(Source).SkipIfArchiveBitNotSet; {
7/4/98  2.13 }
    FResetArchiveBitOnZip:= TVCLZip(Source).ResetArchiveBitOnZip; {
Added 4-Jun-98 SPF 2.13? }
    FExcludeList.Assign(TVCLZip(Source).ExcludeList);  { 9/27/98  2.15 }

    FNoCompressList.Assign(TVCLZip(Source).NoCompressList);  { 9/27/98
2.15 }

     FPreserveStubs := TVCLZip(Source).PreserveStubs; { 01/12/99  2.17 }
     FAddDirEntries := TVCLZip(Source).AddDirEntriesOnRecurse; { 06/09/99 2.18+ }
    { Event Properties }
    FOnStartZip:= TVCLZip(Source).OnStartZip;
    FOnStartZipInfo:= TVCLZip(Source).OnStartZipInfo;
    FOnEndZip:= TVCLZip(Source).OnEndZip;
    FOnDisposeFile:= TVCLZip(Source).OnDisposeFile;
    FOnDeleteEntry:= TVCLZip(Source).OnDeleteEntry;
    FOnNoSuchFile:= TVCLZip(Source).OnNoSuchFile;
    FOnZipComplete:= TVCLZip(Source).OnZipComplete;
    FOnUpdate := TVCLZip(Source).OnUpdate;
  end
  else
    inherited Assign(Source);

end;

procedure TVClZip.SetPathname( Index: Integer; Value: TZipPathname );
var
 finfo: TZipHeaderInfo;
  tmpValue: String;
begin
 If (Index > -1) and (Index < Count) then
   begin
    finfo := sortfiles.Items[Index] as TZipHeaderInfo;
     If (Length(Value) > 0) and (Value[Length(Value)] <> '\') then
        tmpValue := Value + '\'
     Else
        tmpValue := Value;
     If tmpValue <> finfo.directory then
      begin
        finfo.directory := tmpValue;
        ecrec.Modified := True;
      end;
   end
  else
     {$IFDEF NO_RES}
      Raise EListError.CreateFmt('Index %d is out of range',[Index]);
     {$ELSE}
      Raise EListError.CreateFmt(LoadStr(IDS_INDEXOUTOFRANGE),[Index]);
     {$ENDIF}
end;

procedure TVClZip.SetFilename( Index: Integer; Value: TZipPathname );
var
 finfo: TZipHeaderInfo;
begin
 If (Index > -1) and (Index < Count) then
   begin
    finfo := sortfiles.Items[Index] as TZipHeaderInfo;
     If Value <> finfo.filename then
      begin
        finfo.filename := Value;
        ecrec.Modified := True;
      end;
   end
  else
     {$IFDEF NO_RES}
      Raise EListError.CreateFmt('Index %d is out of range',[Index]);
     {$ELSE}
      Raise EListError.CreateFmt(LoadStr(IDS_INDEXOUTOFRANGE),[Index]);
     {$ENDIF}
end;

procedure TVCLZip.SetMultiZipInfo(Value: TMultiZipInfo);
begin
  FMultiZipInfo.Assign(Value);
end;

function TVCLZip.GetMultiMode: TMultiMode;
begin
  Result := FMultiZipInfo.FMultiMode;
end;

procedure TVCLZip.SetMultiMode( Value: TMultiMode );
begin
  If FMultiZipInfo = nil then  { 4/26/98  2.11 }
     exit;  { to avoid illegal pointer operation error during Destroy method }
  If Value <> FMultiZipInfo.FMultiMode then
     FMultiZipInfo.FMultiMode := Value;
  FMultiMode := Value;
end;

function TVCLZip.GetCheckDiskLabels: Boolean;
begin
  Result := FMultiZipInfo.CheckDiskLabels;
end;

procedure TVCLZip.SetCheckDiskLabels( Value: Boolean );
begin
  If Value <> FMultiZipInfo.CheckDiskLabels then
     FMultiZipInfo.CheckDiskLabels := Value;
  FCheckDiskLabels := Value;
end;

procedure TVCLZip.SetStoreVolumes( Value: Boolean );
begin
  If Value <> FStoreVolumes then
   begin
     FStoreVolumes := Value;
     If Value = True then
        FStorePaths := True;
   end;
end;

procedure TVCLZip.SetStorePaths( Value: Boolean);
begin
  If Value <> FStorePaths then
   begin
     If Value = False then
      begin
        FStoreVolumes := False;
        FRelativePaths := False;
      end;
     FStorePaths := Value;
   end;
end;

procedure TVCLZip.SetRelativePaths( Value: Boolean );
begin
  If Value <> FRelativePaths then
   begin
     If Value = True then
      begin
        FStorePaths := True;
        FRecurse := True;
      end;
     FRelativePaths := Value;
   end;
end;

{ Added 4-Jun-98 SPF 2.13? }
procedure TVCLZip.ResetArchiveBit(AFileName: string);
begin
    FileSetAttr(AFileName, (FileGetAttr(AFileName) and not faArchive));
end;

function TVCLZip.ZipFromStream( theStream: TStream; FName: String ): Integer;
begin
  if (Trim(FName)='') or (TheStream=Nil) then
   begin
     result:=0;
     exit;
   end;
  CancelOperation := False;
  StreamZipping := True;
  ZipStream := theStream;
  ZipStream.Position := 0;
  FilesList.Clear;
  FilesList.Add( FName );
  try
     Result := Zip;
  finally
     StreamZipping := False;
     CloseZip;
  end;
end;

function TVCLZip.ZipFromBuffer( Buffer: PChar; Amount: LongInt; FName: String ): Integer;
begin
  Result := 0;
  If (Trim(FName)='') or (Amount = 0) then
     exit;
  MemBuffer := Buffer;
  CurrMem := Buffer;
  MemLen := Amount;
  MemLeft := Amount;
  MemZipping := True;
  FilesList.Clear;
  FilesList.Add(Fname);
  try
     Result := Zip;
  finally
     MemZipping := False;
     CloseZip;
  end;
end;

function TVCLZip.Zip: Integer;
begin
  Result := ProcessFiles;
  If Assigned(FOnZipComplete) then FOnZipComplete(self, Result);
end;

function TVCLZip.IsInExcludeList( N: String ): Boolean;
var
  i: Integer;
  M,M1,M2: String;  { 11/27/98  2.16+}
begin
  Result := False;
  i := 0;
  M1 := LowerCase(ExtractFilename(N));   { 10/23/98  2.16+ }
  M2 := LowerCase(N);
  While i < FExcludeList.Count do
   begin
     {If this exclude list item doesn't include path info then ignore
      path info for the file being tested too}
     If (Pos('\',FExcludeList[i]) = 0) then  { 11/27/98  2.16+}
        M := M1
     Else
        M := M2;
     If IsMatch(LowerCase(FExcludeList[i]),M) then
      begin
        Result := True;
        break;
      end;
     Inc(i);
   end;
end;

function TVCLZip.IsInNoCompressList( N: String ): Boolean;
var
  i: Integer;
  M,M1,M2: String;
begin
  Result := False;
  i := 0;
  M1 := LowerCase(ExtractFilename(N));   { 10/23/98  2.16+ }
  M2 := LowerCase(N);
  While i < FNoCompressList.Count do
   begin
     {If this exclude list item doesn't include path info then ignore
      path info for the file being tested too}
     If (Pos('\',FNoCompressList[i]) = 0) then  { 11/27/98  2.16+}
        M := M1
     Else
        M := M2;
     If IsMatch(LowerCase(FNoCompressList[i]),M) then
      begin
        Result := True;
        break;
      end;
     Inc(i);
   end;
end;

function TVCLZip.ProcessFiles: Integer;
var
  DisposeFiles: TStrings;

  procedure AddTheNewFile(i: Integer);
  begin
     Inc(Result);
     tmpecrec.num_entries := tmpecrec.num_entries + 1;
     tmpecrec.num_entries_this_disk := tmpecrec.num_entries_this_disk + 1;
     tmpfiles.AddObject( tmpfile_info );
     tmpfiles2.AddObject( tmpfile_info );
     If Dispose then
        DisposeFiles.Add(FilesList[i]);
  end;

  Procedure DisposeOfFiles;
  var
     x: Integer;
     Skip: Boolean;
  begin
     Skip := False;
     For x := 0 to DisposeFiles.Count-1 do
      begin
        If Assigned(FOnDisposeFile) then
         begin
           Skip := False;
           FOnDisposeFile( Self, DisposeFiles[x], Skip );
         end;
        If not Skip then
           SysUtils.DeleteFile(DisposeFiles[x]);
      end;
     DisposeFiles.Free;
     DisposeFiles := nil;
  end;

  function ComparePath( P: String ): String;
  { This function expects P and RootDir to include full path information
    including disk information.  Also it is assumed that if RelativePaths
    is True then the path information for P contains RootDir. }
  begin
     If StorePaths then
      begin
       Result := ExtractFilePath(P);
       If FRelativePaths then
           Delete(Result, 1, Length(FRootDir))
       Else
        begin
        { modified the following to handle UNC paths  3/26/98  2.1 }
           If (not FStoreVolumes) and (ExtractFileDrive(Result) <> '') {(Result[2] = ':')} then
           Result := RightStr(Result,Length(Result)-(Length(ExtractFileDrive(Result))+1));
           {Result := RightStr(Result,Length(Result)-3);}
        end;
      end
     Else
        Result := '';
  end;

  procedure MoveExistingFiles;