[Resolvido]Criar ficheiro zip, ou rar

Sub ComprimePastaComWinRar()
    Dim WinRarPath As String 'Localização do WinRar.exe
    Dim RarIt As String 'Instrução de linha de comando
    Dim SourceDir As String 'O diretório de origem
    Dim DestDir As String 'O diretório de destino
    Dim DestRarName As String
    Dim Dest As String 'Caminho de destino concatenado
     
     '*** Verifica se existe instalação do WinRar ***
    WinRarPath = "C:\Program Files\WinRar\"
    If Dir(WinRarPath, vbDirectory) = "" Then
        MsgBox "O WinRar não está instaldo nesse diretorio." _
        & Chr$(13) & "Impossivel comprimir."
        Exit Sub
    End If

    SourceDir = "C:\B Cafe\"

     'Verifica se a Pasta tem espaços nos nomes
    If InStr(1, SourceDir, " ", vbTextCompare) <> 0 Then SourceDir = Chr(34) & SourceDir & Chr(34)
     
    'Letra do Drive de destino
    DestDir = "C:\"
    
    If Dir(DestDir, vbDirectory) = "" Then MkDir DestDir
    DestRarName = "ProjetoAssis.Rar"
    Dest = DestDir & "\" & DestRarName
    If InStr(1, Dest, " ", vbTextCompare) <> 0 Then Dest = Chr(34) & Dest & Chr(34)
     
    RarIt = Shell(WinRarPath & "WinRar.exe a " & Dest & " " & SourceDir, vbNormalFocus)
End Sub

Sub ComprimePastaComWinRar()
    Dim WinRarPath As String 'Localização do WinRar.exe
    Dim RarIt As String 'Instrução de linha de comando
    Dim SourceDir As String 'O diretório de origem
    Dim DestDir As String 'O diretório de destino
    Dim DestRarName As String
    Dim Dest As String 'Caminho de destino concatenado
     
     '*** Verifica se existe instalação do WinRar ***
    WinRarPath = "C:\Program Files (x86)\WinRar\"

    If Dir(WinRarPath, vbDirectory) = "" Then
        MsgBox "O WinRar não está instaldo nesse diretorio." _
        & Chr$(13) & "Impossivel comprimir."
        Exit Sub
    End If

    SourceDir = "C:\B Cafe"

     'Verifica se a Pasta tem espaços nos nomes
    If InStr(1, SourceDir, " ", vbTextCompare) <> 0 Then SourceDir = Chr(34) & SourceDir & Chr(34)
     
    'Letra do Drive de destino
    DestDir = "C:\"
    
    If Dir(DestDir, vbDirectory) = "" Then MkDir DestDir
    DestRarName = "ProjetoAssis.Rar"
    Dest = DestDir & "\" & DestRarName
    If InStr(1, Dest, " ", vbTextCompare) <> 0 Then Dest = Chr(34) & Dest & Chr(34)
     
    RarIt = Shell(WinRarPath & "WinRar.exe a " & Dest & " " & SourceDir, vbNormalFocus)
End Sub

Sub ComprimePastaComWinRar()
    Dim FSO As Object
    Dim FromPath As String
    Dim ToPath As String
    Dim WinRarPath As String 'Localização do WinRar.exe
    Dim RarIt As String 'Instrução de linha de comando
    Dim SourceDir As String 'O diretório de origem
    Dim DestDir As String 'O diretório de destino
    Dim DestRarName As String
    Dim Dest As String 'Caminho de destino concatenado

    FromPath = "c:\B Cafe"
    ToPath = "c:\BackupBCafe"
    
   'inicia a criação da pasta
       Set Fs = CreateObject("Scripting.FileSystemObject")
    'se a pasta existir, deleta
    If Dir("c:\BackupBCafe", vbDirectory) <> "" Then
    Fs.DeleteFolder "c:\BackupBCafe", True
    Else
    'se não existir, cria
    MkDir "c:\BackupBCafe"
    End If

    If Right(FromPath, 1) = "\" Then
        FromPath = Left(FromPath, Len(FromPath) - 1)
    End If
    If Right(ToPath, 1) = "\" Then
        ToPath = Left(ToPath, Len(ToPath) - 1)
    End If
    Set FSO = CreateObject("scripting.filesystemobject")
    If FSO.FolderExists(FromPath) = False Then
        MsgBox FromPath & " não existe."
        Exit Sub
    End If
    'copia
    FSO.CopyFolder Source:=FromPath, Destination:=ToPath
    

     '*** Verifica se existe instalação do WinRar ***
    WinRarPath = "C:\Program Files (x86)\WinRar\"

    If Dir(WinRarPath, vbDirectory) = "" Then
        MsgBox "O WinRar não está instaldo nesse diretorio." _
        & Chr$(13) & "Impossivel comprimir."
        Exit Sub
    End If

    SourceDir = "C:\BackupBCafe"

     'Verifica se a Pasta tem espaços nos nomes
    If InStr(1, SourceDir, " ", vbTextCompare) <> 0 Then SourceDir = Chr(34) & SourceDir & Chr(34)
     
    'Letra do Drive de destino
    DestDir = "C:\"
    
    If Dir(DestDir, vbDirectory) = "" Then MkDir DestDir
    DestRarName = "ProjetoAssis.Rar"
    Dest = DestDir & "\" & DestRarName
    If InStr(1, Dest, " ", vbTextCompare) <> 0 Then Dest = Chr(34) & Dest & Chr(34)
     
    RarIt = Shell(WinRarPath & "WinRar.exe a " & Dest & " " & SourceDir, vbNormalFocus)
    MsgBox "Backup criado com sucesso..."
    
        'deleta a pasta virtual
    If Dir("c:\BackupBCafe", vbDirectory) <> "" Then
    Fs.DeleteFolder "c:\BackupBCafe", True
    Else
    'se já não existir, não faz nada
     End If

   DoCmd.Quit
End Sub