Saving Outlook Email and Attachments

Mike asks:

I need code that will loop through each cell in a column and for each e-mail address search the inbox and save the e-mail and all attachments to a particular folder on a shared drive.

Then I would require the saved files and attachments to be hyperlinked in to a cell in the row for that e-mail address.

Sub ProcessRange()
    Dim rCell As Range
    Dim vaFileNames() As Variant
    Dim i As Long
    ‘Loop through column B
   For Each rCell In Intersect(Sheet1.UsedRange, Sheet1.Columns(2)).Cells
        ‘Check if it’s an email address
       If rCell.Value2 Like “*@*.*” Then
            ReDim vaFileNames(1 To 1)
            SaveEmail rCell.Value2, vaFileNames
            ‘Create hyperlinks for all files saved
           If Not IsEmpty(vaFileNames(1)) Then
                For i = LBound(vaFileNames) To UBound(vaFileNames)
                    Sheet1.Hyperlinks.Add rCell.Offset(0, i), vaFileNames(i), , , Dir(vaFileNames(i))
                Next i
            End If
        End If
    Next rCell
End Sub

Sub SaveEmail(sFrom As String, ByRef vaFileNames() As Variant)
    Dim olApp As Outlook.Application
    Dim olFldr As Outlook.MAPIFolder
    Dim olMail As Outlook.MailItem
    Dim olAtt As Outlook.Attachment
    Dim sPath As String
    Dim lFileCnt As Long
    Dim sFile As String
    sPath = Environ(“USERPROFILE”) & “My DocumentsInboxStuff”
    Set olApp = New Outlook.Application
    Set olFldr = olApp.GetNamespace(“MAPI”).GetDefaultFolder(olFolderInbox)
    For Each olMail In olFldr.Items
        If olMail.SenderEmailAddress = sFrom Then
            sFile = sPath & CleanFile(olMail.Subject) & “.txt”
            olMail.SaveAs sFile, olTXT
            AddFileToList sFile, lFileCnt, vaFileNames
            For Each olAtt In olMail.Attachments
                sFile = sPath & “” & olAtt.Filename
                olAtt.SaveAsFile sFile
                AddFileToList sFile, lFileCnt, vaFileNames
            Next olAtt
        End If
    Next olMail
    Set olFldr = Nothing
    Set olApp = Nothing
End Sub

Sub AddFileToList(sFile As String, ByRef lFileCnt As Long, ByRef vaFileNames() As Variant)
    lFileCnt = lFileCnt + 1
    ReDim Preserve vaFileNames(1 To lFileCnt)
    vaFileNames(lFileCnt) = sFile
End Sub

Function CleanFile(sFile As String) As String
    Dim i As Long
    Dim vIllegals As Variant
    Dim sReturn As String
    vIllegals = Array(“/”, “”, “:”, “*”, “?”, “< “, “>”, “|”, “”“”)
    sReturn = sFile
    For i = LBound(vIllegals) To UBound(vIllegals)
        sReturn = Replace(sReturn, vIllegals(i), “_”)
    Next i
    CleanFile = sReturn
End Function

If you want to run this code, for goodness sake make a backup of your workbook. This code writes hyperlinks into cells and doesn’t care what it deletes. Make sure you set a reference to the Microsoft Outlook Type Library (VBE – Tools – References). Other things to change: it looks in column B for email address, it looks on and writes to Sheet1. You’ll need to adjust sPath and make sure that folder exists. Adjust those factors to suit your situation.

The CleanFile function was adapted from the comments to this post. I might need something more robust to determine if a cell contains a valid email address, but what I have seems to work. The worst that would happen is that it would pick up an invalid one and not find anything.

Posted in Uncategorized

8 thoughts on “Saving Outlook Email and Attachments

  1. It may be different if manipulating email attachments from Excel but there’s a potential problem looping through multiple attachments on an email.

    In his website ( Ken Slovak (Outlook MVP) explains:

    “Use a count down loop for removing items from a collection. Otherwise, the loop counter gets confused and only every other item is removed.”

    If Item.Attachments.Count > 0 Then
    For c = Item.Attachments.Count To 1 Step -1
  2. I love this code. It’s just what I need at work. I nearly adore it!

    It works great for all emails in my inbox from external email addresses such as

    It won’t work for me for any emails from internal email addresses.

    I looked at the SenderEmailAddress property of all the emails in my inbox, which turns out to be for external messages but /O=MY COMPANY/OU=FIRST ADMINISTRATIVE GROUP/CN=RECIPIENTS/CN=JOE.BLOGGS for internal messages.

    I can’t find a way round this. Am I missing something?

  3. A life saver indeed; but experiencing same issue as auger33. It does not recognize internal email addresses…

  4. I’ve never seen email address like that. And whenever I say that, it always means Exchange Server.

    What do you guys have in column B and what would be a match in SenderEmailAddress? I think we could piece together an email out of that long string that matches. I’m not sure where that string is defined, but I’m sure it’s out there somewhere. So does always equal /O=yourcompany/OU=FIRST ADMINISTRATIVE GROUP/CN=RECIPIENTS/CN=JOE.BLOGGS

  5. Found this function while googling (credit to Ashihs). Havent tested this yet, but it seems it might solve Auger and mine little issue with exchange email addresses..

    Function SenderFromAddress(objMsg As MailItem) As String
       Dim strEntryID As String
        Dim strStoreID As String
        Dim objSession As MAPI.Session
        Dim objCDOItem As MAPI.Message

        ‘ get EntryID and StoreID for message
       strEntryID = objMsg.EntryID
        strStoreID = objMsg.Parent.StoreID

        ‘ start CDO session
       Set objSession = CreateObject(“MAPI.Session”)
        objSession.Logon , , False, False

        ‘ pass item to CDO and get sender address
       On Error Resume Next
        Set objCDOItem = objSession.GetMessage(strEntryID, strStoreID)
        SenderFromAddress = objCDOItem.Sender.Address

        ‘ Check to see if the address is a Microsoft Exchange email address
       If Left(SenderFromAddress, 3) = “/o=” Then
            ‘ Local variables
           Dim senderAddress() As String
            Dim strLength As Integer
            Dim i As Integer
            Dim username() As String
            Dim temp As Integer
            Dim sendersEmail As String
            ‘ Get length of MS Exchange string
           strLength = Len(SenderFromAddress)
            ‘ Parse thru the string and insert into array
           For i = 0 To strLength
                ReDim Preserve senderAddress(i)
                senderAddress(i) = Mid$(SenderFromAddress, i, 1)
            Next i
            ‘ Get to the username at the end of the string.
           ‘ I started from 55 because that is where the first letter of the username
           ‘ in my string started, yours might be different.
           ‘ Ubound(senderAddress) gets you to the index of the last letter in the username
           ‘ Finally extract the username and concatenate it into a string literal
           For i = 55 To UBound(senderAddress)
                Dim j As Integer
                sendersEmail = sendersEmail + senderAddress(i)
            Next i
            ‘ Create the full email address for display
           SenderFromAddress = sendersEmail + “”
            Set objSession = Nothing
            Set objCDOItem = Nothing
        End If
    End Function

  6. No problem – fixed. Thanks for finding and posting that code. I can’t say I really understand it, though. Here’s how I would do it if all my assumptions about Exchange sender strings if correct:

    Function GetSenderAddress(sSender As String) As String
        Dim lLastCn As Long
        Const sCN As String = “/CN=”
        Const sDOMAIN As String = “”
        If UCase(Left$(sSender, 3)) = “/O=” Then
            lLastCn = InStrRev(sSender, sCN)
            If lLastCn > 0 Then
                GetSenderAddress = Mid$(sSender, lLastCn + Len(sCN), Len(sSender)) & sDOMAIN
                GetSenderAddress = sSender
            End If
            GetSenderAddress = sSender
        End If
    End Function

    called like GetSenderAddress(olMail.SenderEmailAddress)

    Assumptions are: the email address is always last and it's always preceded by /CN=

Posting code? Use <pre> tags for VBA and <code> tags for inline.

Leave a Reply

Your email address will not be published.