VBA 把文件夹压缩成ZIP文件

Option Explicit

Sub sbCreateEmptyZIP(prmStrFileNameZip)

    'If the file already exists then delete
    If Len(Dir(prmStrFileNameZip)) > 0 Then Kill prmStrFileNameZip
    
    'Create empty ZIP File
    Open prmStrFileNameZip For Output As #1
    Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
    Close #1
End Sub

Sub sbZIP()
    Dim strFullPath As String
    Dim strParentPath As String
    Dim strFolderName As String
    Dim strFileNameZip As Variant
    Dim objApp As Object

    'Select the folder you want to compress
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Please select a folder you want to compress."
        If .Show = True Then strFullPath = .SelectedItems(1)
    End With
    If strFullPath = "" Then Exit Sub

    'Get the parent path of the selected folder
    strParentPath = Left(strFullPath, InStrRev(strFullPath, "\"))
    'Get the folder name
    strFolderName = Mid(strFullPath, InStrRev(strFullPath, "\") + 1)

    'Set Zip file name
    strFileNameZip = strParentPath & strFolderName & Format(Now, "yyyymmddhmmss") & ".zip"
    
    'Create a new empty Zip
    Call sbCreateEmptyZIP(strFileNameZip)
    
    'Copy the files to the compressed folder
    Set objApp = CreateObject("Shell.Application")
    objApp.Namespace(strFileNameZip).CopyHere objApp.Namespace(strFullPath)
    On Error Resume Next

    MsgBox "The ZIP File has been created." & vbCrLf & strFileNameZip

End Sub