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

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