Using VBA in outlook to automatically download Zip floders onto computer

Question

I want to use VBA in Outlook to download a series of zip files. I have coded up to the point where it successfully go through all the emails in my subfolder and download whatever attachment is inside. It tested it on an excel attachment and it worked well.

However the files that I am trying to download are Zip files.

When I run the script on emails containing Zips I get this weird looking file.

screen shot of weird looking result

below is my code. Please help!

Sub GetAttachments()
    'declaring an error statement
    On Error GoTo GetAttachments_err
        
    'Declaring my variables
    'NameSpace: Obj tha gives you access to all outlooks folders
    Dim ns As NameSpace
    'This will refer to a mail folder
    Dim Inbox As MAPIFolder
    Dim Item As Object
    'Attachment we are looking for
    Dim Atmt As Attachment
    'Used to create a name and save path for each attachment as it is saved.
    Dim FileName As String
    'Counter to log the progress of the macro
    Dim i As Integer
    'to look in the subfliter i am filtering all the exception reports to
    Dim SubFolder As MAPIFolder
    
    'setting the variables
    Set ns = GetNamespace("MAPI")
    Set Inbox = ns.GetDefaultFolder(olFolderInbox)
    Set SubFolder = Inbox.Folders("Post-Algo: Mapping Exception Reports")
    i = 0
    
    'if statment to check if there are any messages in the inbox folder and abandon search if there are none.
    If SubFolder.Items.Count = 0 Then
        MsgBox "There are no messages in the Inbox.", vbInformation, _
           "Nothing Found"
        Exit Sub
    End If
    
    'starts looking for attachments if there are items in the file
    If SubFolder.Items.Count > 0 Then
        'looks at each item in the inbox
        For Each Item In SubFolder.Items
            'looks at each attachment
            For Each Atmt In Item.Attachments
                'creates a file name by appending the fiel name
                'remember to change the path to the desired location and to creat the file path.
                FileName = "H:\exceptionDownload\" & Item.Subject & " " & i & Atmt.FileName
                'saves the file under that name.
                Atmt.SaveAsFile FileName
                'increment the log variable.
                i = i + 1
            Next Atmt
        Next Item
    End If
    
    
    If i > 0 Then
        MsgBox "I found " & i & " attached files." _
           & vbCrLf & "I have saved them into the H:\exceptionDownload\." _
           & vbCrLf & vbCrLf & "Have a nice day.", vbInformation, "Finished!"
    Else
        MsgBox "I didn't find any attached files in your mail.", vbInformation, _
        "Finished!"
    End If
    
' Clear the values of the variables
GetAttachments_exit:
   Set Atmt = Nothing
   Set Item = Nothing
   Set ns = Nothing
   Exit Sub

'error handling
GetAttachments_err:
   MsgBox "An unexpected error has occurred." _
      & vbCrLf & "Please note and report the following information." _
      & vbCrLf & "Macro Name: GetAttachments" _
      & vbCrLf & "Error Number: " & Err.Number _
      & vbCrLf & "Error Description: " & Err.Description _
      , vbCritical, "Error!"
   Resume GetAttachments_exit



End Sub

Answer 1

Here is the working code that I use. It might be a little more than what you are after, but hopefully you can adjust to suit.

It handles both zip and non-zipped files, and discards and extensions that you want to ignore. It also can automatically download any cloud based attachments that are too big to send over email. It saves the zipped attachment to a temp folder before extracting the data. Saved and unzipped attachments are also routed to their appropriate folders.

SaveAttachments Method: This is the main method is run based upon an Outlook rule. The destination folder for the attachment is set according to the email's subject (the case statement). In the example code, if the subject is 'Test', then instead of downloading the attachment, it searches for an in-text hyperlink and downloads the cloud based attachment. If the attachement is a .zip file, then it downloads it to a temp folder and calls the 'Unzip Method'.

Unzip Method: This takes in the unzipped file and unzips it to the destination folder

IsInArray Function: Looks to see if the extension of the attachment is in the array of skipped attachment (eg jpg). Returns True or False.

LaunchURL Method: Searches through every word in the email and looks for the a URL that matches the defined URL for the cloud based attachment (fuzzy match on domain name). Names the file with the current sender, date and time.

DownloadFileFromWeb Function: Launches the URL for the cloud based attachment (as defined by the LaunchURL method) and saves it to the appropriate folder

Public Sub SaveAttachments(Item As Outlook.MailItem)

Dim objAttachments As Outlook.Attachments
Dim lngCount, i As Long
Dim strFile, sFileType, destinationFolder, destinationFolderPath, username, subject, rootFolderPath, tempFolderPath, tempFolder, ext, sender As String
Dim isZipped As Boolean
Dim skippedExts() As String


'Gets username
    username = VBA.Interaction.Environ$("UserName")

'Sets the root folder ************************* EDIT THIS *******************************
    rootFolderPath = "C:\Users\" & username & "\Box Sync\Save and Unzip Test\"


'Sets the temp folder Name used to hold the zipped downloads ************************* EDIT THIS *******************************
    tempFolder = "Zip Files"

'List the extentions that you want to skip delimited by a bar '|' ************************* EDIT THIS *******************************
    skippedExts = Split("jpg|jpeg|png|gif", "|")



'Sets the destination folder is set to match it's appropiate data sources ************************* EDIT THIS *******************************
    Select Case Item.subject

        Case "Test"
            destinationFolder = "TestFolder"

         Case Else
            destinationFolder = "DefaultFolder"

    End Select

'********************************************************************************************************************************************

'Sets the root path for non-zipped files
    destinationFolderPath = rootFolderPath & destinationFolder & "\"

'Sets the temp folder path for the zip files
    tempFolderPath = rootFolderPath & tempFolderName & "\"

'Launchs another method if the sender is Convetro to download the file from the URL
    If destinationFolder = "Test" Then
        Call LaunchURL(Item, destinationFolderPath)
        Exit Sub
    End If


If Item.Attachments.Count > 0 Then

    Set objAttachments = Item.Attachments

    'Counts the number of attachments
        lngCount = objAttachments.Count


    For i = lngCount To 1 Step -1

        'Resets the Boolean
            isZipped = False

        'Get the file name of the attachment
            strFile = objAttachments.Item(i).fileName

        'Gets the file extention
            ext = Split(strFile, ".")(UBound(Split(strFile, ".")))

        'If the attachment is an image, then skip it (calls the function to check whether the ext is in the array 'skippedExts')
            If IsInArray(ext, skippedExts) = True Then
                GoTo NextAttachment
            End If

        'If the attachment is a zip, then the path is set to a temp folder.
            If ext = "zip" Then
                strFolderpath = tempFolderPath
                isZipped = True
            Else
                strFolderpath = destinationFolderPath
            End If

        'Combine with the path to the folder
            strFile = strFolderpath & strFile

        'Save the attachment as a file
            objAttachments.Item(i).SaveAsFile strFile

        'Calls the Unzip method to unzip the saved attachment
        If isZipped = True Then
            Call Unzip(strFile, destinationFolderPath)
        End If


NextAttachment:
    Next i
End If


End Sub


Sub Unzip(ByVal strFile As Variant, ByVal destinationFolderPath As String)

Dim FSO, oApp As Object
Dim destinationPath As Variant

'Sets the folderpath string as a variant
    destinationPath = destinationFolderPath

'Extract the files into the newly created folder
    Set oApp = CreateObject("Shell.Application")
    oApp.NameSpace(destinationPath).CopyHere oApp.NameSpace(strFile).Items


    On Error Resume Next
    Set FSO = CreateObject("scripting.filesystemobject")
    FSO.deletefolder Environ("Temp") & "\Temporary Directory*", True

End Sub


    Private Function IsInArray(ByVal stringToBeFound As String, ByVal arr As Variant) As Boolean
      IsInArray = (UBound(Filter(arr, stringToBeFound)) > -1)
    End Function

Private Declare PtrSafe Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
Private Declare PtrSafe Function DeleteUrlCacheEntry Lib "wininet.dll" Alias "DeleteUrlCacheEntryA" (ByVal lpszUrlName As String) As Long


Sub LaunchURL(itm As MailItem, ByVal destinationPath As String)

    Dim bodyString As String
    Dim bodyStringSplitLine
    Dim bodyStringSplitWord
    Dim splitLine
    Dim splitWord
    Dim fileName, URL As String

'Defines 'bodyString' as the body of text in the email
    bodyString = itm.Body

'Breaks the body copy into multiple lines
    bodyStringSplitLine = Split(bodyString, vbCrLf)


'Sets the desired name of the file ************ Edit here *******************
    fileName = "MySender--" & Format(Now(), "yyyy-mm-dd--hh-mm-ss") & ".csv"


'Loop to run through ever line in the email and split it into a bunch of words
    For Each splitLine In bodyStringSplitLine
        bodyStringSplitWord = Split(splitLine, " ")


        'Loop to run through ever word in the line, and test whether it's the link we are looking for
        For Each splitWord In bodyStringSplitWord

            'A test to see whther the word is the URL link that we are looking for *************************** Edit here **********************************
            If Left(splitWord, 34) = "<https://myURLtobedownloaded.com/" Then

                'Deletes the "<>" from the URL
                URL = splitWord
                URL = Replace(Replace(URL, "<", ""), ">", "")

                'If the word is the URL link, then it calls the function DownloadFileFromWeb and saves it to the destination folder
                Call DownloadFileFromWeb(URL, destinationPath & fileName)

            End If
        Next

    Next

    Set itm = Nothing

End Function


Private Function DownloadFileFromWeb(URL As String, SavePath As String) As Boolean
Dim MyLink As String
Dim Ret As Long

'First delete the file from cache:
    DeleteUrlCacheEntry URL

'Download the file and return result:
    DownloadFileFromWeb = False
    Ret = URLDownloadToFile(0, URL, SavePath, 0, 0)
    DoEvents

    If Ret = 0 Then DownloadFileFromWeb = True
End Function

Answer 2

I would try checking for the specific extension(s) you want, and ignore all others. You have a process that downloads attachments, but you have to exclude some stuff that doesn't show in the attachments because other objects, such as embedded images, are handled as attachments as well.

Try this:

For Each Item In SubFolder.Items
    For Each Atmt In Item.Attachments
        If right(Atmt.FileName, 4) = ".zip" Then
            FileName = "H:\exceptionDownload\" & Item.Subject & " " & i & Atmt.FileName
            Atmt.SaveAsFile FileName
            'increment the log variable.
            i = i + 1
        End If
    Next Atmt
Next Item

This will exclude extraneous "hidden" objects in the email.