Vba Excel -zip

[alexandrejpc10]

Bom dia pessoal estou precisando de compactar algns arquivos utilizando o winzip ou iceows a´lguém sabe como fazer isso? utilizando o VBA excel caso contrário o VB

[Vagner Nicolodi]

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

[Almir Pires]

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!!

[tpcatharino]

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!