Сжать папку в архив с паролем

Sub Zip_All_Files_in_Folder_Browse()
    Dim FileNameZip, FolderName, oFolder
    Dim strDate As String, DefPath As String
    Dim oApp As Object
    Dim coll As New Collection    ' заносим в коллекцию список прикрепляемых файлов
    Dim p, mail As String
    mail = Range("E8").Value
    p = Range("E5").Value '"C:\Save Server"
    On Error Resume Next
    MkDir (p)
DefPath = Range("E5").Value '"C:\Users\NepotachevA\Desktop\Лаборатория новая БД" 'путь к архиву для отправки по почте
    If Right(DefPath, 1) <> "" Then
        DefPath = DefPath & ""
    End If
 
    strDate = Format(Now, " dd-mm-yy hh/nn/ss ")
    FileNameZip = DefPath & "Сервер после закрытия " & strDate & ".zip"
 
    Set oApp = CreateObject("Shell.Application")
        NewZip (FileNameZip)
Path = Range("E2").Value '"G:\Qualitats kontrolle\Сервер" 'папка с файлами для архива
        FolderName = Path 'имя папки
        If Right(FolderName, 1) <> "" Then
            FolderName = FolderName & ""
        End If
 
        'Копия файлов для сжатия в архив
        oApp.Namespace(FileNameZip).CopyHere oApp.Namespace(FolderName).items
 
        'Временная задержка для сжатия
        On Error Resume Next
        Do Until oApp.Namespace(FileNameZip).items.Count = _
        oApp.Namespace(FolderName).items.Count
            Application.Wait (Now + TimeValue("0:00:01"))
        Loop
        On Error GoTo 0
     'coll.Add FileNameZip
   ' res = SendEmailUsingOutlook(mail, "Сервер" & strDate, "Резерв", coll)
    'If res Then Debug.Print "Письмо 3 отправлено успешно" Else Debug.Print "Ошибка отправки"
Save
End Sub
 
 
Sub NewZip(sPath)
'Create empty Zip File
    Dim oFSO As Object, arrHex(), sBin As String, i As Long
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    arrHex = Array(80, 75, 5, 6, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0)
    For i = 0 To UBound(arrHex)
        sBin = sBin & Chr(arrHex(i))
    Next
    With oFSO.CreateTextFile(sPath, True)
        .Write sBin
        .Close
    End With
End Sub

Sub Запаковать_с_паролем()
     Shell ("C:\Program Files\WinRAR\WinRAR.exe a -pPASSWORD C:\Temp2\Новый_архив.rar C:\Папка_на_архивацию")
End Sub