Compactando com o ZIP nativo do Windows disponível desde o Windows XP. Edite conforme necessidade
![Wink ;)](./images/smilies/wink.gif)
Código: Selecionar todos
' Backup de diretório e sub-diretórios compactados
' Não necessita nenhum software adicional pois utiliza o recurso ZIP nativo do Windows
' Retirado do fórum itbr.org
' Por Marcelo Leães - [email protected]
Option Explicit
Dim arrResult
' Edite os caminhos conforme necessidade, primeiro é ORIGEM, segundo é DESTINO
' Mantenha a função GetFormattedDate para que o arquivo de saída possua Data. Atenção para não remover aspas.
arrResult = ZipFolder( "C:\Dell\", "D:\Backup-compactado-" & GetFormattedDate & ".zip" )
' Descomente este campo para receber telas de confirmação ao concluir a tarefa
' Para modo automatizado por agendador de tarefas, manter comentado.
'If arrResult(0) = 0 Then
' If arrResult(1) = 1 Then
' WScript.Echo "Sucesso!!! 1 diretorio vazio foi ignorado."
' Else
' WScript.Echo "Sucesso!!! " & arrResult(1) & " diretorios vazios foram ignorados"
' End If
'Else
' WScript.Echo "ERRO: " & Join( arrResult, vbCrLf )
'End If
' Daqui em diante não altere mais nada no código do Script
Function GetFormattedDate
Dim strDate,StrDay,StrMonth,StrYear
strDate = CDate(Date)
strDay = DatePart("d", strDate)
strMonth = DatePart("m", strDate)
strYear = DatePart("yyyy", strDate)
If strDay < 10 Then
strDay = "0" & strDay
End If
If strMonth < 10 Then
strMonth = "0" & strMonth
End If
GetFormattedDate = strDay & "-" & strMonth & "-" & strYear
End Function
Function ZipFolder( myFolder, myZipFile )
Dim intSkipped, intSrcItems
Dim objApp, objFolder, objFSO, objItem, objTxt
Dim strSkipped
Const ForWriting = 2
intSkipped = 0
If Right( myFolder, 1 ) <> "\" Then
myFolder = myFolder & "\"
End If
On Error Resume Next
Set objFSO = CreateObject( "Scripting.FileSystemObject" )
Set objTxt = objFSO.OpenTextFile( myZipFile, ForWriting, True )
objTxt.Write "PK" & Chr(5) & Chr(6) & String( 18, Chr(0) )
objTxt.Close
Set objTxt = Nothing
If Err Then
ZipFolder = Array( Err.Number, Err.Source, Err.Description )
Err.Clear
On Error Goto 0
Exit Function
End If
Set objApp = CreateObject( "Shell.Application" )
For Each objItem in objApp.NameSpace( myFolder ).Items
If objItem.IsFolder Then
Set objFolder = objFSO.GetFolder( objItem.Path )
If objFolder.Files.Count + objFolder.SubFolders.Count = 0 Then
intSkipped = intSkipped + 1
Else
objApp.NameSpace( myZipFile ).CopyHere objItem
End If
Else
objApp.NameSpace( myZipFile ).CopyHere objItem
End If
Next
Set objFolder = Nothing
Set objFSO = Nothing
If Err Then
ZipFolder = Array( Err.Number, Err.Source, Err.Description )
Set objApp = Nothing
Err.Clear
On Error Goto 0
Exit Function
End If
intSrcItems = objApp.NameSpace( myFolder ).Items.Count
Do Until objApp.NameSpace( myZipFile ).Items.Count + intSkipped = intSrcItems
WScript.Sleep 200
Loop
Set objApp = Nothing
If Err Then
ZipFolder = Array( Err.Number, Err.Source, Err.Description )
Err.Clear
On Error Goto 0
Exit Function
End If
On Error Goto 0
If intSkipped = 0 Then
strSkipped = ""
Else
strSkipped = "diretorios vazios ignorados"
End If
ZipFolder = Array( 0, intSkipped, strSkipped )
End Function