[Resolvido]Compactar arquivo pelo Access

Pessoal

Como posso compactar um arquivo pelo access?

preciso compactar um arquivo no formato .zip que esta dentro do diretorio: "C:\ferramentas\critica caracteristicas\mail" e o nome do arquivoé: Relatorio Criticidade.xls

Espero que alguem possa me ajudar!

obrigado

Cole este código (como está) num modulo novo e salve;

http://dl.dropbox.com/u/771097/adriano.txt

Para chamar a função basta colocar no evento ao pressionar de um botão;

Call ZipaFicheiro

Atenção à referencia VBA "Microsoft Sripting Runtime" tem de estar marcada.

Ok JPaulo
Vou testar aqui!

Muito obrigado

E ae funfou ?

Perfeitamente JPaulo!!!!

Muito Obrigado mais uma vez!!!

Obrigado pelo retorno amigo, é que é a primeira vez que esse código foi utilizado para zipar Excel.

E funcionou 100%..hehe

vlw

comigo não funcionou.(access 2000)

ele cria o arquivo .zip "FileNameZip" mas não insere o arquivo indicado em "FName". o Zip fica vazio

Boa noite,

Eu utilizei o código e funcionou normalmente, porém ele trunca o nome do arquivo, caso contenha acentos.

meu arquivo chama-se planilha não alterada.xls

dentro do zip criado o arquivo fica com o nome planilha nço alterda.xls

e dentro do meu sistema, o nome do arquivo é extremamente importante....


Alguem sabe como adaptar o codigo para que ele aceite os acentos??? ou existe algo parecido que chame o winzip via windows (e nao zip por meio de codigo hex)???

valeu

Pelos testes que fiz aqui, reproduzindo um ficheiro Excel com o mesmo nome que o seu, funfou com nota 10.

Public Sub ZipaFicheiro()
'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:\SuaPasta"'Local e pasta
If Right(DefPath, 1) <> "" Then
DefPath = DefPath & ""
End If
strDate = Format(Now, "dd-mmm-yy_h-mm-ss")
FileNameZip = DefPath & strDate & ".zip"
strPrefix = "planilha não alterada" 'Nome do ficheiro
FName = "C:\SuaPasta" & strPrefix & ".xls"
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

JPaulo, obrigado pela ajuda, mas se funcionou com vc, então o problema deve ser outro, pois comigo não funcionou.

note que ele cria o zip na pasta, porém dentro do zip o nome é truncado







tem alguma ideia do que pode ser ????

vou testar em outro computador para ver se funciona....

Amigão o problema pode estar nas configurações desse PC mesmo ou nessa versão de ZIP.

Veja que no meu, ficou joia;

tenho a impressao que o problema esta nos micros aqui do trabalho mesmo.... aqui usamos um programa que se chama ZIPCENTRAL, ao inves do tradicional WInZip.

Quando eu chegar em casa testarei la pra ver se tenho melhor sorte....

depois eu dou um retorno, mas de qualquer forma, obrigado pela ajuda.

JPaulo,

Porvavelmente o problema é mesmo configuracao ou o fato de eu usar o tal ZIPCENTRAL no trabalho.

aqui em casa (onde só tenho instalado o winace), funcionou normalmente.

Vou instalar algum outro no trabalho e tentar novamente .....

valeu !!!

Prezados,

Realizei algumas modificações no código, conforme abaixo.
Agora gostaria de resolver uma outra questão:
No meu caso, o nome do arquivo muda todo o dia, permanecendo apenas "_carga_in.txt", assim sendo, preciso que a linha: Arquivo = "S:\Sistema\remessa\" & "20110317_101714_carga_in.txt" ficasse assim: Arquivo = "S:\Sistema\remessa\" & "*_carga_in.txt", porém, ao executar o código aparece erro dizendo que já existe um arquivo com essa nome.

Alguém tem alguma idéia?

OBS: Não existem outros arquivos na pasta.





Public Sub ZipaFicheiro()
'Criado pelo meu amigo e colega Raw do Canadá
'Adaptado por JPaulo ® Maximo Access

Dim oApp As Object
Dim Arquivo, NomeZip
On Error Resume Next

NomeZip = "S:\Sistema\remessa\enviar\" & "Arquivos_in_" & Format(Now, "yyyy_mm_dd") & ".zip"

Arquivo = "S:\Sistema\remessa\" & "20110317_101714_carga_in.txt"

On Error Resume Next

CriaNovoZip (NomeZip)

Set oApp = CreateObject("Shell.Application")
oApp.NameSpace(NomeZip).CopyHere Arquivo

MsgBox "Criado com Sucesso em: " & NomeZip

Set oApp = Nothing
Exit Sub
End Sub

Caros amigos

Utilizei o código aqui mencionado, alterando-o para zipar vários arquivos, ms tem algo errado, porque para vez que ele roda o loop, substitui o arquivo zipado anteriormente. Meu código ficou assim:

strDate = Format(Now, "dd-mm-yyyy")
strCaminhoBase = "C:\minha_pasta"
strCaminhoFotos = "C:\minha_pasta\fotos"

DefPath = strCaminhoFotos & "\" 'Local e pasta onde estão as fotos"

X = ScanFile(strCaminhoFotos, "*.jpg")

For r = 0 To UBound(X.FileName)
lista = X.FileName(r)

FileNameZip = strCaminhoBase & "\" & strDate & ".zip"
'strPrefix = "Relatorio Criticidade" 'Nome do ficheiro
FName = strCaminhoFotos & "\" & lista '"C:\ferramentas\critica caracteristicas\mail\" & strPrefix & ".xls"
On Error Resume Next
CriaNovoZip (FileNameZip)

Next
Set oApp = CreateObject("Shell.Application")
oApp.NameSpace(FileNameZip).CopyHere FName

MsgBox "Criado com Sucesso em: " & FileNameZip
Set oApp = Nothing
Exit Sub

Alguem pode me ajudar? (URGENTE)

Por favor, retire o Urgente do seu poste acima e leia as regras do fórum.

REGRAS DO FÓRUM

1. Tenha paciência com quem coloca aqui as suas duvidas.
2. Clareza nos títulos dos tópicos e duvidas, evite a linguagem MSN.
3. Não colocar diversas vezes a mesma dúvida.
4. Explicar detalhadamente o problema e informar a versão do seu Office + Sistema Operativo.
5. Retorne sempre se deu certo, esse retorno é muito importante.
6. Respeite toda a equipe Staff e demais membros deste fórum.
7. Use sempre o botão Busca, sempre que tiver uma dúvida e antes de abrir tópicos.
8. Não usar palavras como "Urgente". O fórum é livre e ninguém é obrigado a responder com urgência.
9. A publicidade é proíbida e só pode ser feita pelo Administrador ou depois de aprovada pelo Administrador.
10. Se o seu tópico não for respondido, tem o direito de fazer um Up ao final de 24horas!
11. A colocação de Códigos ou Exemplos, devem constar sempre os créditos de quem o elaborou.
12. Fale, não GRITE! Só letras Maiúsculas, na Internet é o mesmo que gritar!


Obrigado pela sua colaboração.

Me desculpe

To com o mesmo problema, tentando zipar a pasta.
Se alguém tiver a solução agradeço!!!

Qual o erro que apresenta ?

Na verdade, uso o seu código, mas não está pegando nenhum arquivo de minha pasta, cria o zip sem nada.

Poste aqui o codigo como está para eu ver.

Qual a versão do seu Access ?

Access 2007

Public Sub ZipaFotos()
'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

' Dim strPastaFotos As String
' strPastaFotos = DLookup("[LocalFoto]", "Tabela_configuracoes_Individuais")

' On Error Resume Next
DefPath = "C:\Sistema IEAD\Fotos\"
If right(DefPath, 1) <> "\" Then
DefPath = DefPath & "\"
End If

FileNameZip = "C:\Sistema IEAD\Fotos\" & "Fotos" & ".zip"
strPrefix = "Fotos" 'Nome do banco
FName = "C:\Sistema IEAD\Fotos\" & "*.jpg"
' 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

Não pode ter espaços nos nomes das pastas;


Public Sub ZipaFotos()
'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

' Dim strPastaFotos As String
' strPastaFotos = DLookup("[LocalFoto]", "Tabela_configuracoes_Individuais")

' On Error Resume Next
DefPath = "C:\Sistema IEAD\Fotos\"
If right(DefPath, 1) <> "\" Then
DefPath = DefPath & "\"
End If

FileNameZip = "C:\Sistema IEAD\Fotos\" & "Fotos" & ".zip"
strPrefix = "Fotos" 'Nome do banco
FName = "C:\Sistema IEAD\Fotos\" & "*.jpg"
' 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

Então, queria compactar a pasta toda, até consegui se eu informar o nome de um arquivo. Mas necessito de todos.

Então irei copiar para outra pasta no C: e tentar, já aviso se deu certo.

Nada, cria um zip vazio, o que estou errando?

'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

' Dim strPastaFotos As String
' strPastaFotos = DLookup("[LocalFoto]", "Tabela_configuracoes_Individuais")

' On Error Resume Next
DefPath = "c:\FotosSis"
If right(DefPath, 1) <> "\" Then
DefPath = DefPath & "\"
End If
FileNameZip = DefPath & "Fotos" & ".zip"
strPrefix = "Fotos" 'Nome do banco
FName = "c:\FotosSis\" & strPrefix & "*.*"
' 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

Consegui de outra maneira, mas confesso que gostaria de fazer como seu exemplo.

Com uma linha de comando utilizando o 7zip:
Shell ("C:\Arquivos de programas\7-Zip\7z.exe a c:\Fotos.zip C:\FotosSis\*.*")

Se puder dar uma olhada depois, pois o problema desse meu código é se o cliente não ter o 7zip instalado.

Aproveito este tópico para perguntar, alguém sabe me dizer como descompactar/abrir via VBA um arquivo em zip? Zipar eu sei como fazer e roda sem problemas, só não sei abrir via VBA e salvar em uma pasta....

Teste por favor;

Código:

Sub DescomprimeZIP()
    Dim FSO As Object
    Dim oApp As Object
    Dim strDiretorioFicheiro As Variant
    Dim strPastaDestino As Variant
    Dim strDriveDestino As String

    strDiretorioFicheiro = "C:\SeuFicheiro.zip"
    
    If strDiretorioFicheiro = False Then
        'Não faz nada
    Else
         'Drive de destino
        strDriveDestino = "D:"
         If Right(strDriveDestino, 1) <> "\" Then
            strDriveDestino = strDriveDestino & "\"
        End If

        'Nome para a pasta de destino
        strPastaDestino = strDriveDestino & "NovaPasta\"

            If Len(Dir(strPastaDestino, vbDirectory)) = 0 Then
                      
        'Se a pasta de destino não existir, cria uma nova
        MkDir strPastaDestino
Else
End If
        'Extraí os ficheiros do .zip na pasta de destino
        Set oApp = CreateObject("Shell.Application")

        oApp.Namespace(strPastaDestino).CopyHere oApp.Namespace(strDiretorioFicheiro).items

        MsgBox "Ficheiros depositados em " & strPastaDestino

        On Error Resume Next
        Set FSO = CreateObject("scripting.filesystemobject")
        FSO.deletefolder Environ("Temp") & "\Temporary Directory*", True
    End If
End Sub

Perfeito JPaulo!
Apenas que como vai sobrepor o arquivo existente ele apareceu a mensagem de que já existe e se quer manter... não teria como eliminar isso?

Abraço,

Dá sim mas só amanhã posso ver isso.

Teste por favor;

Código:

Sub DescomprimeZIP()
    Dim FSO As Object
    Dim oApp As Object
    Dim strDiretorioFicheiro As Variant
    Dim strPastaDestino As Variant
    Dim strDriveDestino As String

    strDiretorioFicheiro = "C:\teste.zip"
   
    If strDiretorioFicheiro = False Then
        'Não faz nada
    Else
        'Drive de destino
        strDriveDestino = "D:"
        If Right(strDriveDestino, 1) <> "\" Then
            strDriveDestino = strDriveDestino & "\"
        End If

        'Nome para a pasta de destino
        strPastaDestino = strDriveDestino & "NovaPasta\"

            If Len(Dir(strPastaDestino, vbDirectory)) = 0 Then
                     
        'Se a pasta de destino não existir, cria uma nova
        MkDir strPastaDestino
Else
End If
'Se o ficheiro a descomprimir existir, deleta-o
        If Dir("D:\NovaPasta\teste.accdb") <> "" Then
            Kill ("D:\NovaPasta\teste.accdb")
        Else
     
        'Extraí os ficheiros do .zip na pasta de destino
        Set oApp = CreateObject("Shell.Application")

        oApp.Namespace(strPastaDestino).CopyHere oApp.Namespace(strDiretorioFicheiro).items

        MsgBox "Ficheiros depositados em: " & strPastaDestino

        On Error Resume Next
        Set FSO = CreateObject("scripting.filesystemobject")
        FSO.deletefolder Environ("Temp") & "\Temporary Directory*", True
    End If
  End If
End Sub

Só um pequeno ajuste (vermelho) no código e rodou perfeitamente!
Muito obrigado mais uma vez JPaulo!

Sub DescomprimeZIP()
   Dim FSO As Object
   Dim oApp As Object
   Dim strDiretorioFicheiro As Variant
   Dim strPastaDestino As Variant
   Dim strDriveDestino As String

   strDiretorioFicheiro = "C:\teste.zip"
   
   If strDiretorioFicheiro = False Then
       'Não faz nada
   Else
        'Drive de destino
       strDriveDestino = "D:"
        If Right(strDriveDestino, 1) <> "\" Then
           strDriveDestino = strDriveDestino & "\"
       End If

       'Nome para a pasta de destino
       strPastaDestino = strDriveDestino & "NovaPasta\"

           If Len(Dir(strPastaDestino, vbDirectory)) = 0 Then
                     
       'Se a pasta de destino não existir, cria uma nova
       MkDir strPastaDestino
Else
End If
'Se o ficheiro a descomprimir existir, deleta-o
       If Dir("D:\NovaPasta\teste.accdb") <> "" Then
           Kill ("D:\NovaPasta\teste.accdb")
       End If
     
       'Extraí os ficheiros do .zip na pasta de destino
        Set oApp = CreateObject("Shell.Application")

       oApp.Namespace(strPastaDestino).CopyHere oApp.Namespace(strDiretorioFicheiro).items

       MsgBox "Ficheiros depositados em: " & strPastaDestino

       On Error Resume Next
       Set FSO = CreateObject("scripting.filesystemobject")
       FSO.deletefolder Environ("Temp") & "\Temporary Directory*", True

 End If
End Sub

Obrigado pelo retorno o forum agradece.