Não é de minha autoria, mas vou deixar aqui para futuras consultas.
É bom ressaltar que o 7Zip é um compactador free e até o último comparativo que fiz, tinha uma taxa de compressão melhor que a do WinRAR.
Option Explicit
Dim nome_zip As Variant
Dim pasta_a_zipar As Variant
Dim strDate As String
Dim Pasta_destino As String
Dim oApp As Object
Sub Zipar_tudo_com_7Zip()
'Pasta onde estará o arquivo zipado
Pasta_destino = "C:\Users\todorok\Desktop\"
'Pasta que contém os arquivos a serem zipados
pasta_a_zipar = "C:\Users\todorok\Desktop\Kaizen\"
'Arquivo zip que contém os arquivos compactados
nome_zip = Pasta_destino & "backup" & ".zip"
'Criar um arquivo zip vazio
Call Novo_zip_vazio(nome_zip)
Set oApp = CreateObject("Shell.Application")
'Copiar os arquivos para dentro do arquivo zip vazio
oApp.NameSpace(nome_zip).CopyHere oApp.NameSpace(pasta_a_zipar).Items
'Aguardar o término da compactação
On Error Resume Next
Do Until oApp.NameSpace(nome_zip).Items.Count = oApp.NameSpace(pasta_a_zipar).Items.Count
Application.Wait (Now + TimeValue("0:00:01"))
Loop
On Error GoTo 0
MsgBox "Fim!"
End Sub
Sub Novo_zip_vazio(sPath)
'Se já existir um arquivo zip, apagá-lo e criar um novo
If Len(Dir(sPath)) > 0 Then Kill sPath
Open sPath For Output As #1
Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
Close #1
End Sub
