Запаковывание в архив средствами Windows

Option Explicit
 
Private Sub Command1_Click()
 
    CreateEmptyZip "c:\testzip.zip"
    
    With CreateObject("Shell.Application")
        .NameSpace("c:\testzip.zip").CopyHere "c:\test.txt" 'используйте это для запаковывания файла
        ' .NameSpace("c:\testzip.zip").CopyHere .NameSpace(FolderName).items 'используйте это для запаковывания папки
    End With
    ' All done!
End Sub
 
 
Public Sub CreateEmptyZip(sPath)
    Dim strZIPHeader As String
    
    strZIPHeader = Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0) 'header zip файла
    With CreateObject("Scripting.FileSystemObject")
        .CreateTextFile(sPath).Write strZIPHeader 'записываем header в пустой файл
    End With
    
End Sub

Function CreateZip(SourcePath As String, ZipPath As String, ZipMode As String)
 
    CreateEmptyZip ZipPath
    
    With CreateObject("Shell.Application")
       If LCase(ZipMode) = "f" Or LCase(ZipMode) = "file" Then 'если файл, то
        .NameSpace(ZipPath).CopyHere SourcePath 'зипуем как файл
       ElseIf LCase(ZipMode) = "d" Or LCase(ZipMode) = "dir" Or LCase(ZipMode) = "directory" Then 'если папка, то
        .NameSpace(ZipPath).CopyHere .NameSpace(SourcePath).items 'зипуем как папку
       End If
    End With
    
End Function

Function CreateZip(SourcePath As String, ZipPath As String, ZipMode As String, Flags As Long, DelSource As Boolean)
 
    CreateEmptyZip ZipPath
    
    With CreateObject("Shell.Application")
       If LCase(ZipMode) = "f" Or LCase(ZipMode) = "file" Then
        If DelSource Then
         .NameSpace(CStr(ZipPath)).MoveHere CStr(SourcePath), CLng(Flags)
        ElseIf Not DelSource Then
         .NameSpace(CStr(ZipPath)).CopyHere CStr(SourcePath), CLng(Flags)
        End If
       ElseIf LCase(ZipMode) = "d" Or LCase(ZipMode) = "dir" Or LCase(ZipMode) = "directory" Then
        If DelSource Then
         .NameSpace(CStr(ZipPath)).MoveHere .NameSpace(CStr(SourcePath)).Items, CLng(Flags)
        ElseIf Not DelSource Then
         .NameSpace(CStr(ZipPath)).CopyHere .NameSpace(CStr(SourcePath)).Items, CLng(Flags)
        End If
       End If
    End With
End Function

Function CreateZip(SourcePath As String, ZipPath As String, ZipMode As String, Flags As Long, DelSource As Boolean)
    Dim Here
    CreateEmptyZip ZipPath
    
    
    With CreateObject("Shell.Application")
     If LCase(ZipMode) = "f" Or LCase(ZipMode) = "file" Then
      Here = CStr(SourcePath)
     ElseIf LCase(ZipMode) = "d" Or LCase(ZipMode) = "dir" Or LCase(ZipMode) = "directory" Then
      Here = .NameSpace(CStr(SourcePath)).Items
     End If
     
     If DelSource Then
      .NameSpace(CStr(ZipPath)).MoveHere Here, CLng(Flags)
     ElseIf Not DelSource Then
      .NameSpace(CStr(ZipPath)).CopyHere Here, CLng(Flags)
     End If
    End With
    
End Function

TypeName(CreateObject("Shell.Application").NameSpace(CStr(Любая папка)).Items)[/CODE]
 
Возвращает FolderItems3, а
 
[CODE]TypeName(Cstr(Любой путь к файлу))

<Путь> - полный путь к копируемому файлу или папке (строка) или объект FolderItem.

With CreateObject("Scripting.FileSystemObject")
  .CreateFolder Environ("Temp") & "\TestZip" 'Создаем папку
  .CreateTextFile(Environ("Temp") & "\TestZip\Bigfile.txt").Write String(2 ^ 24, 255) 'Кладем туда немаленький файл
  CreateZip Environ("Temp") & "\TestZip", Environ("Temp") & "testzip.zip", "Dir", 4 + 8 + 1024, True 'Архивируем.
 End With