OUTLOOK VBA to download attachment/s to LOCAL ZIP folder

[PivotIdiot]

Hi All,

Hoping someone can help me out?

I'm trying to download all attachments from an open Outlook email to a zip file, name of my choice, to a local folder.
There's no record function on outlook and i cant compile from scratch.
I can only find stuff about downloading all attachments in an outlook folder, to another folder, my requirement is different.

Any takers / ideas?

Many thanks in advance, Piv

 

[shknbk2]

I came up with the code below from other code I've written plus some great info on creating Zip files from Ron de Bruin.

Unfortunately, Outlook doesn't have a nice FilePicker diaglog box like Excel does, so I've hard coded the folder and file names below. Change them to what you need.

Alternatively, there are examples online of creating an Excel object within the Outlook code for the purpose of using the built-in dialogs. If you want that option, let me know.

The code works with the ActiveInspector, which is the window in which the active mail has been opened into its own window (when an item is opened in its own window, it's an inspector -- the Outlook window with the list of emails, etc. is an Explorer). I've run into issues before when just looking for attachments to the open mail item. They come from images within the message also being attachments. For example, signature pictures of the sender's company is an attachment together with any of the "real" attachments. That's why the code checks to see if the HTMLBody contains the "cid" stuff. If the attachment is in the body, its name will be in the "cid" part. Therefore, checking to make sure it does not exist within the HTMLBody makes it a regular attachment.

Sub SaveAttachmentsAsZip()
    Dim m As MailItem, myInspector As Inspector, myAttachment As Attachment
    Dim ZipFileName As Variant, FolderName As Variant, ZipFile As Variant
    Dim oApp As Object, myAttachments() As String, i As Integer, j As Integer
    Dim watchdog As Integer, t As Date, ZipCount As Integer
    
    'Change these 2 variables to reflect where and what you want to save/name the zip file
    [COLOR=#ff0000]FolderName [/COLOR]= "C:\Users\Username\Documents\ExcelTesting\"
    [COLOR=#ff0000]ZipFileName [/COLOR]= "test.zip"
    
    Set myInspector = ActiveInspector
    If Not myInspector Is Nothing Then
        If TypeName(myInspector.CurrentItem) = "MailItem" Then
            Set m = myInspector.CurrentItem
            i = -1
            For Each myAttachment In m.Attachments
                If InStr(1, m.HTMLBody, "cid:" & myAttachment.FileName) < 1 Then
                    myAttachment.SaveAsFile (FolderName & myAttachment.FileName)
                    i = i + 1
                    ReDim Preserve myAttachments(i)
                    myAttachments(i) = myAttachment.FileName
                End If
            Next myAttachment
            
            If i > -1 Then
                ZipFile = FolderName & ZipFileName
                If NewZip(ZipFile) = True Then
                    Set oApp = CreateObject("Shell.Application")
                    ZipCount = 1
                    For j = 0 To i
                        watchdog = 0
                        oApp.NameSpace(ZipFile).CopyHere FolderName & myAttachments(j)
            
                        'Keep script waiting until Compressing is done
                        On Error Resume Next
                        Do Until oApp.NameSpace(ZipFile).Items.Count = ZipCount Or watchdog > 20
                            watchdog = watchdog + 1
                            t = Now + TimeValue("00:00:01")
                            Do Until Now - t > 0
                                If oApp.NameSpace(ZipFile).Items.Count = ZipCount Then Exit Do
                                DoEvents
                            Loop
                        Loop
                        On Error GoTo 0
                        If watchdog > 20 Then
                            If MsgBox("There was an error adding " & myAttachments(i) & _
                                " to the zip file. Continue?", vbYesNo, "Zip Error") = vbNo Then
                                Exit For
                            End If
                        Else
                            ZipCount = ZipCount + 1
                            Kill FolderName & myAttachments(j)
                        End If
                    Next j
                    If ZipCount = i + 2 Then
                        MsgBox "Zip complete."
                    Else
                        MsgBox "Done with some errors."
                    End If
                Else
                    MsgBox ("Move or rename " & ZipFileName & " before trying again.")
                End If
            Else
                MsgBox ("No attachments to save.")
            End If
        End If
    End If
    Set m = Nothing
    Set myInspector = Nothing
    Set oApp = Nothing
End Sub

Function NewZip(sPath) As Boolean
    If Len(Dir(sPath)) > 0 Then
        If MsgBox(sPath & " already exists. Delete it and continue?", vbYesNo, "Zip Error") = vbYes Then
            Kill sPath
        Else
            NewZip = False
            Exit Function
        End If
    End If
    NewZip = True
    Open sPath For Output As [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=1]#1[/URL] 
    Print [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=1]#1[/URL] , Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
    Close [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=1]#1[/URL] 
End Function

 

[PivotIdiot]

This works a treat, many thanks!
There are gifs and jpg files in the folder also, which if i'm reading correctly should be ignored?
Actually the files i receive that are required are PDF, and maybe an if statement could filter the others out?

Thanks again, I love this.
Previously I had to save to a location, navigate to the location, select all, zip up, then move the zip to the actual location, then delete the downloaded files.
This is so much better!

Thanks, Piv

 

[shknbk2]

You're welcome. If all you need are PDFs, then this should also work without performing the Body checking.

[COLOR=#333333]Sub SaveAttachmentsAsZip()[/COLOR]    Dim m As MailItem, myInspector As Inspector, myAttachment As Attachment
    Dim ZipFileName As Variant, FolderName As Variant, ZipFile As Variant
    Dim oApp As Object, myAttachments() As String, i As Integer, j As Integer
    Dim watchdog As Integer, t As Date, ZipCount As Integer
    
    'Change these 2 variables to reflect where and what you want to save/name the zip file
    [COLOR=#ff0000]FolderName [/COLOR]= "C:\Users\Username\Documents\ExcelTesting\"
    [COLOR=#ff0000]ZipFileName [/COLOR]= "test.zip"
    
    Set myInspector = ActiveInspector
    If Not myInspector Is Nothing Then
        If TypeName(myInspector.CurrentItem) = "MailItem" Then
            Set m = myInspector.CurrentItem
            i = -1
            For Each myAttachment In m.Attachments
                [COLOR=#008000]If InStr(1, LCase(myAttachment.FileName), ".pdf") > 0 Then[/COLOR]
                    myAttachment.SaveAsFile (FolderName & myAttachment.FileName)
                    i = i + 1
                    ReDim Preserve myAttachments(i)
                    myAttachments(i) = myAttachment.FileName
                End If
            Next myAttachment
            
            If i > -1 Then
                ZipFile = FolderName & ZipFileName
                If NewZip(ZipFile) = True Then
                    Set oApp = CreateObject("Shell.Application")
                    ZipCount = 1
                    For j = 0 To i
                        watchdog = 0
                        oApp.NameSpace(ZipFile).CopyHere FolderName & myAttachments(j)
            
                        'Keep script waiting until Compressing is done
                        On Error Resume Next
                        Do Until oApp.NameSpace(ZipFile).Items.Count = ZipCount Or watchdog > 20
                            watchdog = watchdog + 1
                            t = Now + TimeValue("00:00:01")
                            Do Until Now - t > 0
                                If oApp.NameSpace(ZipFile).Items.Count = ZipCount Then Exit Do
                                DoEvents
                            Loop
                        Loop
                        On Error GoTo 0
                        If watchdog > 20 Then
                            If MsgBox("There was an error adding " & myAttachments(i) & _
                                " to the zip file. Continue?", vbYesNo, "Zip Error") = vbNo Then
                                Exit For
                            End If
                        Else
                            ZipCount = ZipCount + 1
                            Kill FolderName & myAttachments(j)
                        End If
                    Next j
                    If ZipCount = i + 2 Then
                        MsgBox "Zip complete."
                    Else
                        MsgBox "Done with some errors."
                    End If
                Else
                    MsgBox ("Move or rename " & ZipFileName & " before trying again.")
                End If
            Else
                MsgBox ("No attachments to save.")
            End If
        End If
    End If
    Set m = Nothing
    Set myInspector = Nothing
    Set oApp = Nothing
End Sub

Function NewZip(sPath) As Boolean
    If Len(Dir(sPath)) > 0 Then
        If MsgBox(sPath & " already exists. Delete it and continue?", vbYesNo, "Zip Error") = vbYes Then
            Kill sPath
        Else
            NewZip = False
            Exit Function
        End If
    End If
    NewZip = True
    Open sPath For Output As [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=1"]#1[/URL] 
    Print [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=1"]#1[/URL] , Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
    Close [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=1"]#1[/URL]  [COLOR=#333333]End Function[/COLOR]

Well, as it turns out, the only line I changed was the green one. I guess I was expecting more. Oh, well.