vclunzip.pas

delphi 的压缩工具代码

      try
         OpenZip;
         theZipFile.Seek(relative_offset, soFromBeginning);
         theZipFile.Read(lrec, SizeOf(local_file_header));
         with lrec do
         begin
            theZipFile.Seek(filename_length, soFromCurrent);
            theZipFile.Read(dhTemp, SizeOf(DecryptHeaderType));
         end;
         for i := 0 to 11 do                            { added this loop 10/23/99  2.20b3+ }
         begin
            dhPtr^ := dhTemp[i];
            Inc(dhPtr);
         end;
      finally
        If (MultiMode = mmNone) then
           CloseZip;
      end;
   end;
   {$ENDIF}
end;

{$IFDEF ISDELPHI}

function TVCLUnZip.GetDecryptHeader(Index: Integer): DecryptHeaderType;
var
   finfo                 : TZipHeaderInfo;
   lrec                  : local_file_header;
   i                     : Integer;
begin
   if (Index > -1) and (Index < Count) then
   begin
      finfo := sortfiles.Items[Index] as TZipHeaderInfo;
   end
   else
      {$IFDEF NO_RES}
      raise EListError.CreateFmt('Index %d is out of range', [Index]);
   {$ELSE}
      raise EListError.CreateFmt(LoadStr(IDS_INDEXOUTOFRANGE), [Index]);
   {$ENDIF}
   if (IsEncrypted[Index]) then
      with finfo do
      begin
         try
            OpenZip;
            theZipFile.Seek(relative_offset, soFromBeginning);
            theZipFile.Read(lrec, SizeOf(local_file_header));
            with lrec do
            begin
               theZipFile.Seek(filename_length, soFromCurrent);
               theZipFile.Read(Result, SizeOf(DecryptHeaderType));
            end;
         finally
           If (MultiMode = mmNone) then
              CloseZip;
         end
      end
   else
      for i := 0 to 11 do
         Result[i] := 0;
end;
{$ENDIF}

function TVCLUnZip.GetZipSize: LongInt;
begin
   Result := 0;
   if FZipName <> '' then
   begin
      OpenZip;
      try
         Result := theZipFile.Size;
      finally
        If (MultiMode = mmNone) then
           CloseZip;
      end;
   end;
end;

procedure TVCLUnZip.WriteNumDisks(NumberOfDisks: Integer);
begin
   FNumDisks := NumberOfDisks;
end;

{ Added these so that they could be overriden in VCLZip 3/11/98  2.03 }

function TVCLUnZip.GetCheckDiskLabels: Boolean;
begin
   Result := FCheckDiskLabels;
end;

procedure TVCLUnZip.SetCheckDiskLabels(Value: Boolean);
begin
   FCheckDiskLabels := Value;
end;

function TVCLUnZip.UnZip: Integer;
begin
   FBusy := True;
   CancelOperation := False;
   Result := 0;
   try
      if DestDir <> '?' then
      begin
         { Following Changed from OpenZip which was being bypassed. 03/15/01  2.21+ }
         ReadZip;
         OpenZip;  { Make sure it's open because ReadZip closes it again }
         Result := UnzipFiles(theZipFile);
         CloseZip;
      end;
   finally
      FBusy := False;
      CancelOperation := False;
   end;
end;

function TVCLUnZip.UnZipSelected: Integer;
begin
   UnZippingSelected := True;
   Result := UnZip;
   UnZippingSelected := False;
end;

procedure TVCLUnZip.ClearSelected;
var
   i                     : Integer;
begin
   for i := 0 to Count - 1 do
      Selected[i] := False;
   FNumSelected := 0;
end;

function TVCLUnZip.UnZipToStream(theStream: TStream; FName: string): Integer;
begin
   Result := 0;
   if (Trim(FName) = '') or (theStream = nil) then
      exit;
   FBusy := True;
   ZipStream := theStream;
   CancelOperation := False;
   StreamZipping := True;
   OpenZip;
   FilesList.Clear;
   FilesList.Add(FName);
   try
      Result := UnzipFiles(theZipFile);
   finally
      StreamZipping := False;
      CloseZip;
      FBusy := False;
      CancelOperation := False;
   end;
end;

function TVCLUnZip.UnZipToStreamByIndex(theStream: TStream; Index: Integer): Integer;
begin
   Result := 0;
   if (theStream = nil) then
      exit;
   FBusy := True;
   ZipStream := theStream;
   CancelOperation := False;
   StreamZipping := True;
   OpenZip;
   FilesList.Clear;
   try
      Selected[Index] := True;
      UnZippingSelected := True;
      Result := UnzipFiles(theZipFile);
   finally
      StreamZipping := False;
      CloseZip;
      FBusy := False;
      CancelOperation := False;
      UnZippingSelected := False;
   end;
end;

function TVCLUnZip.UnZipToBuffer(var Buffer: PChar; FName: string): Integer;
begin
   Result := 0;
   if (Trim(FName) = '') then
      exit;
   FBusy := True;
   MemZipping := True;
   OpenZip;                                             { 12/4/98  2.17P+ }
   FilesList.Clear;
   FilesList.Add(FName);
   if (Buffer = nil) then
      MemBuffer := nil
   else
      MemBuffer := Buffer;
   try
      Result := UnzipFiles(theZipFile);
      if (Buffer = nil) then
         Buffer := MemBuffer;
   finally
      MemZipping := False;
      CloseZip;
      FBusy := False;
      CancelOperation := False;
      MemBuffer := nil;
   end;
end;

function TVCLUnZip.UnZipToBufferByIndex(var Buffer: PChar; Index: Integer): Integer;
begin
   FBusy := True;
   MemZipping := True;
   OpenZip;                                             { 12/4/98  2.17P+ }
   FilesList.Clear;
   if (Buffer = nil) then
      MemBuffer := nil
   else
      MemBuffer := Buffer;
   try
      if Index > -1 then
         Selected[Index] := True;
      if not DoAll then
         UnZippingSelected := True;
      Result := UnzipFiles(theZipFile);
      if (Buffer = nil) then
         Buffer := MemBuffer;
   finally
      MemZipping := False;
      CloseZip;
      FBusy := False;
      CancelOperation := False;
      MemBuffer := nil;
      UnZippingSelected := False;
   end;
end;

procedure TVCLUnZip.OpenZip;
{$IFDEF KPDEMO}
{$IFNDEF NO_RES}
var
   tmpMStr2              : string;
   {$ENDIF}
   {$ENDIF}
begin
   {$IFDEF KPDEMO}
   if not (csDesigning in ComponentState) then
   begin
      if not DelphiIsRunning then
      begin
         {$IFDEF NO_RES}
         MessageBox(0,
            'This unregistered verion of VCLZip will only run while the Delphi IDE is running',
            'Warning', mb_OK);
         {$ELSE}
         tmpMStr := LoadStr(IDS_NOTREGISTERED);
         tmpMStr2 := LoadStr(IDS_WARNING);
         MessageBox(0, StringAsPChar(tmpMStr), StringAsPChar(tmpMStr2), mb_OK);
         {$ENDIF}
         Abort;
      end;
   end;
   {$ENDIF}
   if theZipFile = nil then
      theZipFile := TLFNFileStream.CreateFile(FZipName, fmOpenRead or fmShareDenyWrite,
         FFlushFilesOnClose, BufferedStreamSize);
   if files = nil then
      GetFileInfo(theZipFile)
   else
      if (not ArchiveIsStream) and
         (FileDateToDateTime(FileGetDate(TLFNFileStream(theZipFile).Handle)) <> filesDate) then
         GetFileInfo(theZipFile);
end;

procedure TVCLUnZip.CloseZip;
begin
   if not FKeepZipOpen then
   begin
      theZipFile.Free;
      theZipFile := nil;
   end;
end;

procedure TVCLUnZip.AskForNewDisk(NewDisk: Integer);
begin
   SwapDisk(NewDisk);
end;

function TVCLUnZip.SwapDisk(NewDisk: Integer): TStream;
{ NewDisk is the disk number that the user sees. Starts with 1 }
var
   tmpZipName            : string;

   function CurrentDiskLabel(NewDisk: Integer): Boolean;
   var
      VolName            : string[11];
      Disk               : string;
   begin
      {Need to check disk label here}
      if MultiMode = mmSpan then
      begin
         Disk := UpperCase(LeftStr(FZipName, 3));
         VolName := GetVolumeLabel(Disk);
         if RightStr(VolName, 3) = Format('%3.3d', [NewDisk]) then
            Result := True
         else
            Result := False;
      end
      else
         Result := True;
   end;

begin
   theZipFile.Free;
   theZipFile := nil; {1/27/98 to avoid GPF when Freeing file in CloseZip. v2.00+}
   tmpZipName := FZipName;
   repeat
      repeat
         FOnGetNextDisk(Self, NewDisk, tmpZipName);
      until (not CheckDiskLabels) or (tmpZipName = '') or (CurrentDiskLabel(NewDisk));
      if tmpZipName = '' then
         raise EUserCanceled.Create('User canceled loading new disk.');
   until FileExists(tmpZipName); {1/29/98 To avoid problem if file doesn't exist}
   theZipFile := TLFNFileStream.CreateFile(tmpZipName, fmOpenRead, False, BufferedStreamSize);
   CurrentDisk := NewDisk - 1;                          { CurrentDisk starts with 0 }
   filesDate := FileDateToDateTime(FileGetDate(TLFNFileStream(theZipFile).Handle));
   FZipName := tmpZipName;
   Result := theZipFile;
end;

procedure TVCLUnZip.NewDiskEvent(Sender: TObject; var S: TStream);
begin
   SwapDisk(CurrentDisk + 2);
   S := theZipFile;
end;

procedure TVCLUnZip.ClearZip;
var
   SaveKeepZipOpen       : Boolean;
begin
   SaveKeepZipOpen := FKeepZipOpen;
   FKeepZipOpen := False;
   CloseZip;
   FKeepZipOpen := SaveKeepZipOpen;
   if (sortfiles <> nil) and (sortfiles <> files) then
      sortfiles.Free;
   files.Free;
   files := nil;
   sortfiles := nil;
   ecrec.Clear;
   ZipIsBad := False;
   filesDate := 0;
   FNumDisks := 1;
   MultiMode := mmNone;
   if not ArchiveIsStream then
      FZipName := '';
end;

procedure TVCLUnZip.ReadZip;
var
   TryAgain              : Boolean;
   RememberKeepZipOpen   : Boolean;
begin
   CancelOperation := False;
   FImproperZip := False;
   repeat
      {$IFNDEF KPSMALL}
      Screen.Cursor := crHourGlass;
      {$ENDIF}
      TryAgain := False;
      try
         OpenZip;
      except
         on EIncompleteZip do
         begin
            {$IFNDEF KPSMALL}
            Screen.Cursor := crDefault;
            {$ENDIF}
            { zip file must be closed in this case  1/25/00 2.20+  }
            RememberKeepZipOpen := KeepZipOpen;
            KeepZipOpen := False;
            CloseZip;
            KeepZipOpen := RememberKeepZipOpen;
            if Assigned(FOnIncompleteZip) then
               tryagain := True;
         end;
      else
         begin
            ClearZip;
            {$IFNDEF KPSMALL}
            Screen.Cursor := crDefault;
            {$ENDIF}
            raise; { raise the exception so the application knows }
         end;
      end;
   until (TryAgain = False);
   CloseZip;
   {$IFNDEF KPSMALL}
   Screen.Cursor := crDefault;
   {$ENDIF}