✔ Programação GLOBAL®: PIECE OF CAKE - MS Excel - Zipando - Compactando e Enviando por e-Mail

Este código foi escrito para que estiver usando o Outlook como seu programa de e-mail.

Este código enviará a planilha recém-criada (cópia do seu Activeworkbook). Guardará o zip na pasta de trabalho antes de enviá-lo com um carimbo de data | hora. Depois que o arquivo zip for enviado, o arquivo zip e a pasta de trabalho serão excluídos.

Sub Zip_Mail_ActiveWorkbook()
    Dim strDate As String, DefPath As String, strbody As String
    Dim oApp As Object, OutApp As Object, OutMail As Object
    Dim FileNameZip, FileNameXls
    Dim FileExtStr As String

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

    'Create date/time string and the temporary xl* and zip file name
    If Val(Application.Version) < 12 Then
        FileExtStr = ".xls"
    Else
        Select Case ActiveWorkbook.FileFormat
        Case 51: FileExtStr = ".xlsx"
        Case 52: FileExtStr = ".xlsm"
        Case 56: FileExtStr = ".xls"
        Case 50: FileExtStr = ".xlsb"
        Case Else: FileExtStr = "notknown"
        End Select
        If FileExtStr = "notknown" Then
            MsgBox "Sorry unknown file format"
            Exit Sub
        End If
    End If

    strDate = Format(Now, " yyyy-mm-dd h-mm-ss")

    FileNameZip = DefPath & Left(ActiveWorkbook.Name, _
    Len(ActiveWorkbook.Name) - Len(FileExtStr)) & strDate & ".zip"

    FileNameXls = DefPath & Left(ActiveWorkbook.Name, _
    Len(ActiveWorkbook.Name) - Len(FileExtStr)) & strDate & FileExtStr


    If Dir(FileNameZip) = "" And Dir(FileNameXls) = "" Then

        'Make copy of the activeworkbook
        ActiveWorkbook.SaveCopyAs FileNameXls

        'Create empty Zip File
        NewZip (FileNameZip)

        'Copy the file in the compressed folder
        Set oApp = CreateObject("Shell.Application")
        oApp.Namespace(FileNameZip).CopyHere FileNameXls

        'Keep script waiting until Compressing is done
        On Error Resume Next
        Do Until oApp.Namespace(FileNameZip).items.Count = 1
            Application.Wait (Now + TimeValue("0:00:01"))
        Loop
        On Error GoTo 0

        'Create the mail
        Set OutApp = CreateObject("Outlook.Application")
        Set OutMail = OutApp.CreateItem(0)
        strbody = "Hi there" & vbNewLine & vbNewLine & _
                  "This is line 1" & vbNewLine & _
                  "This is line 2" & vbNewLine & _
                  "This is line 3" & vbNewLine & _
                  "This is line 4"

        On Error Resume Next
        With OutMail
            .To = "ron@debruin.nl"
            .CC = ""
            .BCC = ""
            .Subject = "This is the Subject line"
            .Body = strbody
            .Attachments.Add FileNameZip
            .Send   'or use .Display
        End With
        On Error GoTo 0

        'Delete the temporary Excel file and Zip file you send
        Kill FileNameZip
        Kill FileNameXls
    Else
        MsgBox "FileNameZip or/and FileNameXls exist"
    End If
End Sub