# Macro to zip a file then attach to Outlook email



## Marlene (Jun 8, 2009)

I am currently using the code below to attach (& send) a workbook to an Outlook email message. The Recipient asked if I could change it so that the attachment gets zipped (WinZip) before it is send. Also, it would be great if it could save a copy of the workbook to the desktop. My VBA skills are very limited, please tell me how to change the existing code to do this?
___________________________________________________________

Sub SendActiveWorkbook()
Dim mrn As String
Dim sd As String
Dim urg As String
mrn = Sheets("Coversheet").Range("d5").Value
deal = Sheets("Coversheet").Range("D13").Value
brch = Sheets("Coversheet").Range("h9").Value
'sd = Sheets("Coversheet").Range("Settlement").Value
'urg = Sheets("Coversheet").Range("Urgent").Value
ActiveWorkbook.SendMail _
Recipients:="user email address", _
Subject:="WORKBOOK" & " - " & mrn & " " & deal & " Branch# - " & brch
End Sub


----------



## Ed in Aus (Jun 8, 2009)

You may want to check out this site.

http://www.rondebruin.nl/windowsxpzip.htm

but I want to create a macro that does this so I'll post it if I get one to work.


----------



## Ed in Aus (Jun 9, 2009)

All credit to Zip file or files with the default Windows zip program (VBA)
Ron de Bruin (last update 26-May-2009)


```
Sub NewZip(sPath)
'Create empty Zip File
'Changed by keepITcool Dec-12-2005
    If Len(Dir(sPath)) > 0 Then Kill sPath
    Open sPath For Output As #1
    Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
    Close #1
End Sub


Function bIsBookOpen(ByRef szBookName As String) As Boolean
' Rob Bovey
    On Error Resume Next
    bIsBookOpen = Not (Application.Workbooks(szBookName) Is Nothing)
End Function


Function Split97(sStr As Variant, sdelim As String) As Variant
'Tom Ogilvy
    Split97 = Evaluate("{""" & _
                       Application.Substitute(sStr, sdelim, """,""") & """}")
End Function
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
'DefPath = "G:\My Documents\"
'You can use the above line if you want to name your default path for working

    '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) - 4) & strDate & ".zip"

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


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

        'Make copy of the activeworkbook
        MsgBox FileNameXls
        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 = "YOUREMAIL@EMAIL.ADDRESS" 'CHANGE TO YOUR ADDRESS TO TEST
            .CC = ""
            .BCC = ""
            .Subject = "This is the Subject line"
            .Body = strbody
            .Attachments.Add FileNameZip
            .Display   'or use .Send
        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
```


----------



## Marlene (Jun 9, 2009)

Thank you so much !


----------



## reasonablenesscheck (Jul 21, 2009)

I used this code, and it works, but it turns my txt file back into a xl file.  Is there anyway to alter the code slightly so it keeps it in txt format?


----------



## Ed in Aus (Jul 26, 2009)

I think you can change one section in it to .txt... change the parts in bold might work for you.


```
Sub NewZip(sPath)
'Create empty Zip File
'Changed by keepITcool Dec-12-2005
    If Len(Dir(sPath)) > 0 Then Kill sPath
    Open sPath For Output As #1
    Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
    Close #1
End Sub


Function bIsBookOpen(ByRef szBookName As String) As Boolean
' Rob Bovey
    On Error Resume Next
    bIsBookOpen = Not (Application.Workbooks(szBookName) Is Nothing)
End Function


Function Split97(sStr As Variant, sdelim As String) As Variant
'Tom Ogilvy
    Split97 = Evaluate("{""" & _
                       Application.Substitute(sStr, sdelim, """,""") & """}")
End Function
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

*DefPath = "G:\YOU NEED TO CHANGE THIS TO A FOLDER"

FName = "My text file.txt"*

    '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(FName, _
    Len(FName) - 4) & strDate & ".zip"

    FileNameXls = DefPath & Left(FName, _
    Len(FName) - 4) & strDate & FileExtStr


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

        'Make copy of the activeworkbook
        MsgBox FileNameXls
        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 = "YOUREMAIL@EMAIL.ADDRESS" 'CHANGE TO YOUR ADDRESS TO TEST
            .CC = ""
            .BCC = ""
            .Subject = "This is the Subject line"
            .Body = strbody
            .Attachments.Add FileNameZip
            .Display   'or use .Send
        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
```


----------



## reasonablenesscheck (Jul 28, 2009)

Thanks!  Appreciate your help.


----------



## Ed in Aus (Jul 28, 2009)

Just double checking did that work for you? I haven't tested it


----------



## CDTSBNY01 (Apr 24, 2019)

How to do macro to zip a pdf file and then attach to outlook email? Help please.Thanks


----------

