Работа с архивом

'***************************************************************
Function CreateArchive(ZipArchivePath) As Boolean
Dim Shell As Object
Dim FileSystemObject As Object
Dim ArchiveFolder As Object
 
      Set Shell = CreateObject("Shell.Application")
      Set FileSystemObject = CreateObject("Scripting.FileSystemObject")
 
      ' Проверка наличия расширения zip в полном пути-имени файла
      If UCase(FileSystemObject.GetExtensionName(ZipArchivePath)) <> "ZIP" Then
           Exit Function
      End If
      ' Создание пустого zip архива
Dim ZipFileHeader As String
      ZipFileHeader = "PK" & Chr(5) & Chr(6) & String(18, 0)
      FileSystemObject.OpenTextFile(ZipArchivePath, 2, True).Write ZipFileHeader
      Set ArchiveFolder = Shell.NameSpace((ZipArchivePath))
      ' проверка создания архива
      If Not (ArchiveFolder Is Nothing) Then CreateArchive = True
End Function
'***************************************************************

Function ZipCont(ArcName As String) As String()
Dim Fnames() As String
   ReDim Fnames(1 To 300) As String
   ZIP% = FreeFile
   Open ArcName For Binary Access Read As #ZIP%
   PZip& = 0
   ptrF% = 0
   sz% = 300
   Do
      C30$ = Space$(30)
      Get ZIP%, , C30$
      PZip& = PZip& + 30
      If Mid$(C30$, 3, 2) <> Chr$(3) + Chr$(4) Then Exit Do
      Ln% = CVI(Mid$(C30$, 27, 2))
      NameFile$ = Space$(Ln%)
      Get ZIP%, , NameFile$
      PZip& = PZip& + Ln%
      C4$ = Mid$(C30$, 19, 4)
      LL& = CVL(C4$)
      L% = Len(NameFile$)
      For ia% = L% To 1 Step -1
          If Mid$(NameFile$, ia%, 1) = "/" Then
             NameFile$ = Right$(NameFile$, (L% - ia%))
             Exit For
          End If
      Next ia%
      NAM$ = ""
      EXT$ = ""
      p% = InStr(NameFile$, ".")
      L% = Len(NameFile$)
      If p% = 0 Then
         NAM$ = NameFile$
      Else
         NAM$ = Left$(NameFile$, (p% - 1))
         EXT$ = Right$(NameFile$, (L% - p%))
      End If
      ptrF% = ptrF% + 1
      If ptrF% > sz% Then
         ReDim Preserve Fnames(1 To sz% + 300) As String
         sz% = sz% + 300
      End If
      Fnames(ptrF%) = NAM$ + "." + EXT$
      PZip& = PZip& + LL&
      Seek ZIP%, PZip& + 1
   Loop
   Close ZIP%
   ReDim Preserve Fnames(1 To ptrF% - 1) As String
   ZipCont = Fnames
End Function
 
Public Function CVI(CC As String)
Dim PP As Integer
    PP = 0
    For i% = 2 To 1 Step -1
        C1$ = Mid$(CC, i%, 1)
        PP = PP * 256 + Asc(C1$)
    Next i%
    CVI = PP
End Function
 
Public Function CVL(CC As String)
Dim PP As Long
    PP = 0
    For i% = 4 To 1 Step -1
        C1$ = Mid$(CC, i%, 1)
        PP = PP * 256 + Asc(C1$)
    Next i%
    CVL = PP
End Function
 
Sub Test()
Dim ZipArc() As String
    zipName$ = "C:\sv00.zip"
    ZipArc = ZipCont(zipName$)
    For i% = 1 To UBound(ZipArc, 1)
        Debug.Print ZipArc(i%)
    Next i%
End Sub

'***************************************************************
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
 
Sub CopyFileToArchiv(ZipName As String, FileName As String)
' ZipName - полный путь к архиву
' FileName - полный путь к архивируемому файлу
Dim ShellApp As Object
Dim DestFolder As Object
 
      Set ShellApp = CreateObject("Shell.Application")
      Set DestFolder = ShellApp.NameSpace((ZipName))
      ' копируемый выбранный файл в zip папку
      DestFolder.CopyHere (FileName)
      ' ожидаем окончание сжатия файла
      Do Until DestFolder.Items.Count = 1
           Sleep 100
      Loop
 
      Set ShellApp = Nothing
 
End Sub
'*

Public Function fnNameArchiveFile(ZipName As String, Optional i As Integer = 0, _
Optional fext As Boolean = True) As String
' ZipName - имя архива
' i - номер файла в архиве (начало с 0), по умолчанию - 0
' fext - включать расширение в имя файла, по умолчанию - true
Dim objShellApp As Object
Dim objFolder As Object
 
      Set objShellApp = CreateObject("Shell.Application")
      Set objFolder = objShellApp.NameSpace((ZipName))
      If fext Then
           fnNameArchiveFile = objFolder.Items().Item((i)).Path
      Else
           fnNameArchiveFile = objFolder.Items().Item((i)).Name
      End If
 
End Function

Public Sub UnZipFile(ZipName As String, DestPath As String)
' ZipName - полный путь к архиву
' DestPath - полный путь к папке для распаковки архива
 
Dim ShellApp As Object
 
      Set ShellApp = CreateObject("Shell.Application")
      'Copy the files in the newly created folder
      ShellApp.NameSpace((DestPath)).CopyHere ShellApp.NameSpace((ZipName)).Items
      Set ShellApp = Nothing
 
End Sub

Function ArjCont(ArcName As String) As String()
Dim Fnames() As String
   ReDim Fnames(1 To 300) As String
   sz% = 30
   Arj% = FreeFile
   Open ArcName For Binary Access Read As #Arj%
   OO& = 1
   NE% = 0
   Do
      Seek #Arj%, OO&
      Signature$ = "  "
      Get #Arj%, , Signature$
      If Signature$ <> Chr$(&H60) + Chr$(&HEA) Then
         Close #Arj%
         ReDim Fnames(1 To 1) As String
         ArjCont = Fnames
         Exit Function
      End If
      LL$ = " "
      Get #Arj%, , LL$
      LL_& = Asc(LL$)
      If LL_& = 0 Then Exit Do
      BUF$ = Space$((LL_& + 7))
      Get #Arj%, , BUF$
      NameFile$ = ""
      For i% = 32 To Len(BUF$)
          S$ = Mid$(BUF$, i%, 1)
          If S$ = Chr$(0) Then Exit For
          NameFile$ = NameFile$ + S$
      Next i%
      If NE% > 0 Then
         ptrF% = ptrF% + 1
         If ptrF% > sz% Then
            ReDim Preserve Fnames(1 To sz% + 300) As String
            sz% = sz% + 300
         End If
         Fnames(ptrF%) = NameFile$
      End If
      C4$ = Mid$(BUF$, 14, 4)
      LF& = CVL(C4$)
      If NE% = 0 Then
         OO& = OO& + (LL_& + 10)
      Else
         OO& = OO& + (LL_& + 10 + LF&)
      End If
      NE% = NE% + 1
   Loop
   Close Arj%
   ReDim Preserve Fnames(1 To ptrF%) As String
   ArjCont = Fnames
End Function

'/// Класс создания ZIP-файла средствами Windows
'/// Автор: ALX_2002
 
'/// Пример работы с классом 
Set FileSytemObject = CreateObject("Scripting.FileSystemObject") 
 
'/// Получаем путь до каталога в котором находимся 
ParentFolderName = FileSytemObject.GetParentFolderName(Wscript.ScriptFullName) 
 
'/// Строим путь для создания тестового файла 
SourceFilePath = FileSytemObject.BuildPath(ParentFolderName,"Текстовый документ.txt") 
 
'/// Создаём и заполняем файл содержимым 
FileSytemObject.OpenTextFile(SourceFilePath,2,True).write "Содержимое файла" 
 
'/// Создаём архив 
DestFilePath = FileSytemObject.BuildPath(ParentFolderName,"1.zip") 
 
'/// Создаём класс создания ZIP файла 
Set Zip = New ZipClass 
 
'/// Открываем новый архив 
Zip.CreateArchive DestFilePath 
'/// Добавляем файл в архив 
Zip.CopyFileToArchive SourceFilePath 
'/// Закрываем архив 
Zip.CloseArchive 
 
MsgBox "Архив создан",vbInformation,"ZipClass" 
 
 
'/// Код класса 
Class ZipClass 
        Private Shell 
 
        Private FileSystemObject 
 
        Private ArchiveFolder 
 
        Private ItemsCount 
        
        Private Sub Class_Initialize() 
            Set Shell = CreateObject("Shell.Application") 
            Set FileSystemObject = CreateObject("Scripting.FileSystemObject") 
        End Sub 
 
        Function CreateArchive(ZipArchivePath) 
 
            If UCase(FileSystemObject.GetExtensionName(ZipArchivePath)) <> "ZIP" Then 
                Exit Function 
            End If 
            
            Dim ZipFileHeader 
            
            ZipFileHeader = "PK" & Chr(5) & Chr(6) & String(18, 0) 
            
            FileSystemObject.OpenTextFile(ZipArchivePath, 2, True).Write ZipFileHeader 
            
            Set ArchiveFolder = Shell.NameSpace(ZipArchivePath) 
        
                if Not (ArchiveFolder is Nothing) Then CreateArchive = True 
        End Function 
 
        Function CopyFileToArchive(FilePath) 
                if (ArchiveFolder is Nothing) Then Exit Function 
            ArchiveFolder.CopyHere FilePath 
                ItemsCount = ItemsCount + 1 
        End Function 
 
        Function CopyFolderToArchive(FolderPath) 
                if (ArchiveFolder is Nothing) Then Exit Function 
            ArchiveFolder.CopyHere FolderPath 
                ItemsCount = ItemsCount + 1 
        End Function 
 
        Function CloseArchive 
                if (ArchiveFolder is Nothing) Then Exit Function 
                Set WsriptShell = CreateObject("Wscript.Shell") 
      if IsObject(Wscript) Then 
         Do 
            Wscript.Sleep 100 
                    Loop Until ArchiveFolder.Items.Count => ItemsCount 
      Else 
         ServerSleep 
      End if 
           ItemsCount = 0 
        End Function 
 
   Private Function ServerSleep 
                Set WsriptShell = CreateObject("Wscript.Shell") 
      Do 
         WsriptShell.Popup "",1,"" 
                Loop Until ArchiveFolder.Items.Count => ItemsCount 
   End Function 
 
        Function MoveFileToArchive(FilePath) 
                if (ArchiveFolder is Nothing) Then Exit Function 
            ArchiveFolder.MoveHere FilePath 
        End Function 
End Class