Talvez uma das rotinas abaixo te ajude. A primeira trata-se de uma adaptação feita pelo Kazu que eu tenho guardado em meu acervo. Observem que ele usa o 7ZIP
Ja a segunda rotina, confesso que não me recordo o autor, mas faz backup de um arquivo EXCEL zipado.
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:UserstodorokDesktop"
'Pasta que contém os arquivos a serem zipados
pasta_a_zipar = "C:UserstodorokDesktopKaizen"
'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
SEGUNDA ROTINA
Sub Zip_Folder_And_SubFolders()
Dim PathWinZip As String, FileNameZip As String, FolderName As String
Dim ShellStr As String, strDate As String, DefPath As String
PathWinZip = "C:program fileswinzip"
'This will check if this is the path where WinZip is installed.
If Dir(PathWinZip & "winzip32.exe") = "" Then
MsgBox "Please find your copy of winzip32.exe and try again"
Exit Sub
End If
' Build the date/Time string
strDate = Format(Now, "yyyy-mm-dd h-mm-ss")
' Build the path and name for the zip file
DefPath = Application.DefaultFilePath
If Right(DefPath, 1) <> "" Then
DefPath = DefPath & ""
End If
FileNameZip = DefPath & strDate & ".zip"
'Fill in the folder name
FolderName = "C:Data"
'Add a slash at the end if the user forget it
If Right(FolderName, 1) <> "" Then
FolderName = FolderName & ""
End If
'Zip the folder, -r is Include subfolders, -p is folder information
ShellStr = PathWinZip & "Winzip32 -min -a -r -p" _
& " " & Chr(34) & FileNameZip & Chr(34) _
& " " & Chr(34) & FolderName & Chr(34)
ShellAndWait ShellStr, vbHide
MsgBox "The zipfile is ready in: " & FileNameZip
End Sub
Existem mil maneiras de preparar Neston. Invente a sua!
http://www.youtube.com/ExpressoExcel
Postado : 28/01/2014 2:33 pm