Jump to content

[Resolvido] Criar Ficheiro .zip com data actual


ferreira12

Recommended Posts

Boas,

Estou a tentar criar um backup de uma pasta todos os dias. Para isso estou a zipar a pasta. não estou é a conseguir colocar a data actual. deixo o codigo abaixo

Dim _sbuffer As Byte() = {80, 75, 5, 6, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0}
       FileIO.FileSystem.WriteAllBytes("C:\TESTE.zip" + System.DateTime.Now, _sbuffer, False)
       Dim sc As New Shell32.Shell
       Dim _pasta As Shell32.Folder = sc.NameSpace("C:\TESTE")
       Dim _arquivo As Shell32.Folder = sc.NameSpace("C:\TESTE.zip" + System.DateTime.Now)
       _arquivo.CopyHere(_pasta.Items, 4)

com este codigo só consigo criar o zip se ele encontrar o nome do zip igual. Como faria para ele criar uma pasta antes com a data actual?

Edited by thoga31
GeSHi
Link to comment
Share on other sites

boas

veja se é isto que necessita, se descomentar a linha comentada ele zipa apenas o ficheiro indicados, assim zipa a pasta

Private Sub CommandButton1_Click()
Call ZipaFicheiro
End Sub
Public Sub ZipaFicheiro()
Dim strDate As String, DefPath As String
Dim oApp As Object
Dim FName, FileNameZip
Dim strPrefix As String
 On Error Resume Next
DefPath = "C:\Users\xxxx\Desktop\ziparxls" 'Local e pasta onde está o ficheiro
If Right(DefPath, 1) <> "\" Then
	DefPath = DefPath & "\"
End If

strDate = Format(Now, "dd-mmm-yy_h-mm-ss")
FileNameZip = DefPath & strDate & ".zip"
'strPrefix = "Combinar.xlsm" 'Nome do ficheiro + extensão
FName = DefPath & strPrefix
	On Error Resume Next
Call CriaNovoZip(FileNameZip)
Set oApp = CreateObject("Shell.Application")
oApp.Namespace(FileNameZip).CopyHere FName
MsgBox "Criado com Sucesso em: " & FileNameZip
Set oApp = Nothing
  Exit Sub
End Sub

Public Sub CriaNovoZip(sPath)
Dim ofso, arrHex, sBin, i, Zip
On Error Resume Next
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
On Error Resume Next
With ofso.CreateTextFile(sPath, True)
	.Write sBin
	.Close
End With
  Exit Sub
End Sub

cumps

acao

Edited by acao
Link to comment
Share on other sites

Create an account or sign in to comment

You need to be a member in order to leave a comment

Create an account

Sign up for a new account in our community. It's easy!

Register a new account

Sign in

Already have an account? Sign in here.

Sign In Now
×
×
  • Create New...

Important Information

By using this site you accept our Terms of Use and Privacy Policy. We have placed cookies on your device to help make this website better. You can adjust your cookie settings, otherwise we'll assume you're okay to continue.