• 0
Sign in to follow this  
alexandrejpc10

Vba Excel -zip

Question

2 answers to this question

Recommended Posts

  • 0

Use o seguinte código:

Sub Zip_File_Or_Files()
    Dim strDate As String, DefPath As String, sFName As String
    Dim oApp As Object, iCtr As Long, I As Integer
    Dim FName, vArr, FileNameZip

    DefPath = Application.DefaultFilePath
    If Right(DefPath, 1) <> "\" Then
        DefPath = DefPath & "\"
    End If

    strDate = Format(Now, " dd-mmm-yy h-mm-ss")
    FileNameZip = DefPath & "MyFilesZip " & strDate & ".zip"

    'Selecionar o arquivo(s), use o Ctrl para selecionar mais de 1 arquivo
    FName = Application.GetOpenFilename(filefilter:="Excel Files (*.xls), *.xls", _
                                        MultiSelect:=True, Title:="Selecione os arquivos a serem zipados")
    If IsArray(FName) = False Then
        'Não faz nada
    Else
        'Criar um arquivo Zip do Windows vazio
        NewZip (FileNameZip)
        Set oApp = CreateObject("Shell.Application")
        I = 0
        For iCtr = LBound(FName) To UBound(FName)
            vArr = Split97(FName(iCtr), "\")
            sFName = vArr(UBound(vArr))
            If bIsBookOpen(sFName) Then
                MsgBox "Você não pode zipar um documento aberto!" & vbLf & _
                       "Favor fechar o arquivo e tente novamente: " & FName(iCtr)
            Else
                'Copiar o documento para o diretório zipado
                I = I + 1
                oApp.NameSpace(FileNameZip).CopyHere (FName(iCtr))
            End If
        Next iCtr

        'Manter o código aguardando até acabar de zipar
        On Error Resume Next
        Do Until oApp.NameSpace(FileNameZip).items.Count = I
            Application.Wait (Now + TimeValue("0:00:01"))
        Loop

        MsgBox "Você encontrará o arquivo zipado aqui: " & FileNameZip
        On Error GoTo 0
        Set oApp = Nothing
    End If
End Sub

Atenciosamente,

Vagner Nicolodi

Share this post


Link to post
Share on other sites
  • 0

Amigo Vagner,

Por favor, preciso de sua ajuda.

É a respeito de sua solução : http://scriptbrasil.com.br/forum/index.php?showtopic=87072

Tentei executar porém me aparece a mensagem "Erro de compilação: 'Sub' ou 'Function' não definida", selecionando o comando NewZip onde está a linha de comando "NewZip (FileNameZip)".

Tentei resolver definindo NewZip como uma variável, etc mas não tive êxito em nenhuma tentativa.

Por isto gostaria de lhe perguntar se você está chamando NewZip de alguma DLL.

Caso seja isto, por favor você poderia me enviar esta DLL ou me informar se é necessário habilitar algum Componente em Menu/Ferramentas/Referências no VBExcel??

Desde Já, Muito Obrigado!!

Share this post


Link to post
Share on other sites
  • 0

Vagner,

bom dia!

estou acompanhando esse seu código para criar zip!

tem como substituir o " FName = Application.GetOpenFilename(filefilter:="Excel Files (*.xls), *.xls", _

MultiSelect:=True, Title:="Selecione os arquivos a serem zipados") " por uma variável onde ele pega o arquivo direto em um lugar especifico, sem selecionar?

preciso dessa ajuda obrigado!

Share this post


Link to post
Share on other sites

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

Guest
Answer this question...

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

Sign in to follow this