[Resolvido] Criar Ficheiro .zip com data actual

[ferreira12]

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 March 1, 2013 at 08:25 PM by thoga31
GeSHi

[bioshock]

Talvez isto?

Dim arquivo As Folder = sc.Namespace("C:\TESTE[" + Datetime.Now + "].zip")

[ferreira12]

Não, porque ele não encontra a pasta com esse nome, primeiro teria que criar uma nova pasta com a data actual.

Só que eu não sei como faço para criar uma pasta.zip nova.

[bioshock]

Percebi mal o que querias.

http://stackoverflow.com/questions/906354/how-to-zip-files-in-vb-net-2005

http://dotnetzip.codeplex.com/

[acao]

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 March 3, 2013 at 10:11 PM by acao

[ferreira12]

Boas acao,

Dá me erro nas seguintes partes de código

oApp.Namespace(FileNameZip).CopyHere FName ' erro no FName

erro: Method arguments must be enclosed in parentheses.

e depois aqui dá o mesmo erro.

.Write sBin ' erro sBin

[acao]

boas

em vba funciona, não testei em vbnet mas era suposto funcionar.

elimina «& strPrefix

ficaria assim

FName = DefPath

talvez seja esse o erro, porque se a linha anterior estiver comentada a string strPrefix é vazia e pode ser esse o erro.

cumps

acao

[ferreira12]

Já consegui resolver o problema. Obrigado a todos uma vez mais