[Resolvido]Zipar Banco

Bom dia a Todos,

Estou utilizando como exemplo o banco do mestre JPaulo para zipar um bd só que o arquivo zipado é criado só que não salva nada dentro do que está zipado, abaixo o código utilizado:

Public Sub Zipabanco()
'Criado pelo meu amigo e colega Raw do Canadá
'Adaptado por JPaulo ® Maximo Access
Dim strDate As String, DefPath As String
Dim oApp As Object
Dim FName, FileNameZip
Dim strPrefix As String
On Error Resume Next
DefPath = "C:\sgp" 'Local e pasta onde está o banco de backup
If Right(DefPath, 1) <> "\" Then
DefPath = DefPath & "\"
End If

strDate = Format(Now, "dd-mmm-yy_h-mm-ss")
FileNameZip = DefPath & "Backup_" & strDate & ".zip"
strPrefix = "bst" 'Nome do banco
FName = "C:\Backup\" & strPrefix & "*.mdb"
On Error Resume Next
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)
'Criado pelo meu amigo e colega Raw do Canadá
'Adaptado por JPaulo ® Maximo Access
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

Qual a versão do seu Ms Access ?

Utilize este já corrigido e depois de colar num modulo novo, leia os comentarios com atenção;

Public Sub Zipabanco()
'Criado pelo meu amigo e colega Raw do Canadá
'Adaptado por JPaulo ® Maximo Access
   Dim strDate As String, DefPath As String
   Dim oApp As Object
   Dim FName, FileNameZip
   Dim strPrefix As String
    On Error Resume Next
   
   'Caminho da pasta onde está o banco a zipar
   DefPath = "C:\PastaBanco"
   If Right(DefPath, 1) <> "\" Then
       DefPath = DefPath & "\"
   End If

   strDate = Format(Now, "dd-mmm-yy_h-mm-ss")
   FileNameZip = DefPath & "Backup_" & strDate & ".zip"
   
   'Nome correto do banco a zipar
   strPrefix = "Teste"
   
   'Caminho da pasta onde vai ficar o banco zipado.
   'Dei o exemplo de chamar a pasta de "Backups"
   'Se o seu Ms Access for anterior ao 2007,
   'deve alterar a extenção de .accdb para .mdb
       FName = "C:\Backups\" & strPrefix & ".accdb"
       On Error Resume Next
   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)
'Criado pelo meu amigo e colega Raw do Canadá
'Adaptado por JPaulo ® Maximo Access
   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

não passou apresentou o seguinte erro agora erro de compilação inválido fora de procedimento e fica grifado esse código On Error Resume Next.

estou utilizando o access 2007.

Não entendi...

Cole aqui todo o código que está a utilizar no seu banco.

esse é o código que está no modulo:


Public Sub Zipabanco()
'Criado pelo meu amigo e colega Raw do Canadá
'Adaptado por JPaulo ® Maximo Access
Dim strDate As String, DefPath As String
Dim oApp As Object
Dim FName, FileNameZip
Dim strPrefix As String
On Error Resume Next

'Caminho da pasta onde está o banco a zipar
DefPath = "C:\SGP"
If Right(DefPath, 1) <> "\" Then
DefPath = DefPath & "\"
End If

strDate = Format(Now, "dd-mmm-yy_h-mm-ss")
FileNameZip = DefPath & "Backup_" & strDate & ".zip"

'Nome correto do banco a zipar
strPrefix = "SG"

'Caminho da pasta onde vai ficar o banco zipado.
'Dei o exemplo de chamar a pasta de "Backups"
'Se o seu Ms Access for anterior ao 2007,
'deve alterar a extenção de .accdb para .mdb
FName = "C:\Backups\" & strPrefix & ".MDB"
On Error Resume Next
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)
'Criado pelo meu amigo e colega Raw do Canadá
'Adaptado por JPaulo ® Maximo Access
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

E em um botão chamo a função call zipabanco

Vamos lá ás perguntas:

1º O banco a zipar está mesmo em C:\SGP ?

2º O nome correto do seu banco a zipar é SG ?

3º Esta pasta C:\Backups existe ?

4º Você disse que era Access 2007, porque razão é que lhe dá com o ".MDB" para cima ?

Sim o banco está no diretorio C:\SGP

O nome do banco é SG
Sobre a extensão realmente estava errado é accdb mesmo mudando a pasta é criada, mais se nenhum arquivo dentro.

Todos os testes que realizei aqui no Ms Access 2007, funciona na perfeição.

Faça um Break no inicio do código e acompanhe linha a linha para ver o que se vai passando, para encontrar o erro.

Removi e instalei novamente o Winzip, ai consegui zipar.

Valew, fico feliz.

JPaulo, Obrigado pelo código.

- Este é o melhor que encontrei, (peguei o da 2ª mensagem), vai direto ao ponto e, o mais IMPORTANTE, não depende de programas de terceiros.

 - Algumas adaptações ao projeto e ficou perfeito.

 - Continue nos agraciando com este valioso conhecimento!

Obrigado pelo retorno o forum agradece.