none
Anyway To Export Email To Folder Including Attachments? RRS feed

  • Question

  • I have a system I have created overtime that puts email data onto an Excel spreadsheet. This is great but what I would also like to do after this has run is extract the emails including any attachments from Outlook into a new folder on my Windows PC.

    When the email is on the Excel spreadsheet, and then the email and attachments are extracted to a folder on my PC I would like a unique ID (maybe the date of the email, or just a random number) to be added to the email which will then auto send a link address back to the spreadsheet beside the email that has been extracted and also add the unique ID to the spreadsheet. Sounds a bit confusing and I hope this makes sense (Is this possible?)

    People will reply to the emails, and I would also like the reply emails to an original one (that should have the unique ID listed above) uses the same ID it gave the original email. Again sorry if this sounds confusing, happy to go into more detail if need be. 

    Kind of new to stuff like this so any help would be great. 


    Here is the code I have written so far;

    Sub Download_Outlook_Mail_To_Excel()
        'Add Tools->References->"Microsoft Outlook nn.n Object Library"
        'nn.n varies as per our Outlook Installation
        Dim Folder As Outlook.MAPIFolder
        Dim sFolders As Outlook.MAPIFolder
        Dim iRow As Integer, oRow As Integer
        Dim MailBoxName As String, Pst_Folder_Name  As String
        
        'Mailbox or PST Main Folder Name (As how it is displayed in your Outlook Session)
        MailBoxName = "neo_segauk@hotmail.com"
     
        'Mailbox Folder or PST Folder Name (As how it is displayed in your Outlook Session)
        Pst_Folder_Name = "Inbox" 'Sample "Inbox" or "Sent Items"
     
        'To directly a Folder at a high level
        'Set Folder = Outlook.Session.Folders(MailBoxName).Folders(Pst_Folder_Name)
        
        'To access a main folder or a subfolder (level-1)
        For Each Folder In Outlook.Session.Folders(MailBoxName).Folders
            If VBA.UCase(Folder.Name) = VBA.UCase(Pst_Folder_Name) Then GoTo Label_Folder_Found
            For Each sFolders In Folder.Folders
                If VBA.UCase(sFolders.Name) = VBA.UCase(Pst_Folder_Name) Then
                    Set Folder = sFolders
                    GoTo Label_Folder_Found
                End If
            Next sFolders
        Next Folder
     
    Label_Folder_Found:
         If Folder.Name = "" Then
            MsgBox "Invalid Data in Input"
            GoTo End_Lbl1:
        End If
     
        'Read Through each Mail and export the details to Excel for Email Archival
        ThisWorkbook.Sheets(1).Activate
        Folder.Items.Sort "Received"
        
        'Insert Column Headers
        ThisWorkbook.Sheets(1).Cells(1, 1) = "Sender"
        ThisWorkbook.Sheets(1).Cells(1, 2) = "Subject"
        ThisWorkbook.Sheets(1).Cells(1, 3) = "Date"
        'ThisWorkbook.Sheets(1).Cells(1, 4) = "Size"
        ThisWorkbook.Sheets(1).Cells(1, 5) = "EmailID"
        ThisWorkbook.Sheets(1).Cells(1, 6) = "Body"
        
        'Export eMail Data from PST Folder
        oRow = 1
        For iRow = 1 To Folder.Items.Count
            'If condition to import mails received in last 60 days
            'To import all emails, comment or remove this IF condition
            'If VBA.DateValue(VBA.Now) - VBA.DateValue(Folder.Items.Item(iRow).ReceivedTime) <= 60 Then
               oRow = oRow + 1
               ThisWorkbook.Sheets(1).Cells(oRow, 1).Select
               ThisWorkbook.Sheets(1).Cells(oRow, 1) = Folder.Items.Item(iRow).SenderName
               ThisWorkbook.Sheets(1).Cells(oRow, 2) = Folder.Items.Item(iRow).Subject
               ThisWorkbook.Sheets(1).Cells(oRow, 3) = Folder.Items.Item(iRow).ReceivedTime
               'ThisWorkbook.Sheets(1).Cells(oRow, 4) = Folder.Items.Item(iRow).Size
               ThisWorkbook.Sheets(1).Cells(oRow, 5) = Folder.Items.Item(iRow).SenderEmailAddress
               ThisWorkbook.Sheets(1).Cells(oRow, 6) = Folder.Items.Item(iRow).Body
            'End If
        Next iRow
        MsgBox "Outlook Mails Extracted to Excel"
        Set Folder = Nothing
        Set sFolders = Nothing
        
    End_Lbl1:
    End Sub

    Saturday, August 15, 2015 7:58 PM

All replies

  • You don't need a reference to Outlook, but you do need to create or open an Outlook instance. The following will save the messages in the path indicated (which it will create if not present) c/w any attachments. I would caution against putting the message bodies in the worksheet as they can be very large and include graphics which are likely to be an issue. The macro (in the Personal workbook) uses a couple of functions to ensure that messages that happen to have the same names are not overwritten. I think you should be able to work with this.

    Option Explicit
    Const fPath As String = "C:\Path\Reports\" 'The path to save the messages
    
    Sub Download_Outlook_Mail_To_Excel()
    Dim olApp As Object
    Dim olFolder As Object
    Dim olNS As Object
    Dim xlBook As Workbook
    Dim xlSheet As Worksheet
    Dim NextRow As Long
    Dim i As Long
    Dim olItem As Object
        Set xlBook = Workbooks.Add
        Set xlSheet = xlBook.Sheets(1)
        On Error Resume Next
        Set olApp = GetObject(, "Outlook.Application")
        If Err <> 0 Then
            Set olApp = CreateObject("Outlook.Application")
        End If
        On Error GoTo 0
        With xlSheet
            .Cells(1, 1) = "Sender"
            .Cells(1, 2) = "Subject"
            .Cells(1, 3) = "Date"
            '.Cells(1, 4) = "Size"
            .Cells(1, 5) = "EmailID"
            .Cells(1, 6) = "Body"
            CreateFolders fPath
            Set olNS = olApp.GetNamespace("MAPI")
            Set olFolder = olNS.PickFolder
            For Each olItem In olFolder.Items
                NextRow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
                If olItem.Class = 43 Then
                    .Cells(NextRow, 1) = olItem.Sender
                    .Cells(NextRow, 2) = olItem.Subject
                    .Cells(NextRow, 3) = olItem.SentOn
                    '.Cells(NextRow, 4) =
                    .Cells(NextRow, 5) = SaveMessage(olItem)
                    '.Cells(NextRow, 6) = olItem.Body 'Are you sure?
                End If
            Next olItem
        End With
         MsgBox "Outlook Mails Extracted to Excel"
    lbl_Exit:
        Set olApp = Nothing
        Set olFolder = Nothing
        Set olItem = Nothing
        Set xlBook = Nothing
        Set xlSheet = Nothing
        Exit Sub
    End Sub
    
    Function SaveMessage(olItem As Object) As String
    Dim Fname As String
        Fname = Format(olItem.ReceivedTime, "yyyymmdd") & Chr(32) & _
                Format(olItem.ReceivedTime, "HH.MM") & Chr(32) & olItem.sendername & " - " & olItem.Subject
        Fname = Replace(Fname, Chr(58) & Chr(41), "")
        Fname = Replace(Fname, Chr(58) & Chr(40), "")
        Fname = Replace(Fname, Chr(34), "-")
        Fname = Replace(Fname, Chr(42), "-")
        Fname = Replace(Fname, Chr(47), "-")
        Fname = Replace(Fname, Chr(58), "-")
        Fname = Replace(Fname, Chr(60), "-")
        Fname = Replace(Fname, Chr(62), "-")
        Fname = Replace(Fname, Chr(63), "-")
        Fname = Replace(Fname, Chr(124), "-")
        SaveMessage = SaveUnique(olItem, fPath, Fname)
    lbl_Exit:
        Exit Function
    End Function
    
    Private Function SaveUnique(oItem As Object, _
                                strPath As String, _
                                strFileName As String) As String
    Dim lngF As Long
    Dim lngName As Long
        lngF = 1
        lngName = Len(strFileName)
        Do While FileExists(strPath & strFileName & ".msg") = True
            strFileName = Left(strFileName, lngName) & "(" & lngF & ")"
            lngF = lngF + 1
        Loop
        oItem.SaveAs strPath & strFileName & ".msg"
        SaveUnique = strPath & strFileName & ".msg"
    lbl_Exit:
        Exit Function
    End Function
    
    Private Sub CreateFolders(strPath As String)
    Dim strTempPath As String
    Dim iPath As Long
    Dim vPath As Variant
        vPath = Split(strPath, "\")
        strPath = vPath(0) & "\"
        For iPath = 1 To UBound(vPath)
            strPath = strPath & vPath(iPath) & "\"
            If Not FolderExists(strPath) Then MkDir strPath
        Next iPath
    End Sub
    
    Private Function FolderExists(ByVal PathName As String) As Boolean
       Dim nAttr As Long
       On Error GoTo NoFolder
       nAttr = GetAttr(PathName)
       If (nAttr And vbDirectory) = vbDirectory Then
          FolderExists = True
       End If
    NoFolder:
    End Function
    
    Private Function FileExists(filespec) As Boolean
    Dim fso As Object
        Set fso = CreateObject("Scripting.FileSystemObject")
        If fso.FileExists(filespec) Then
            FileExists = True
        Else
            FileExists = False
        End If
    lbl_Exit:
        Exit Function
    End Function
    
    
    




    Graham Mayor - Word MVP
    www.gmayor.com

    • Proposed as answer by ryguy72 Tuesday, December 22, 2015 2:55 AM
    Sunday, August 16, 2015 4:55 AM
  • Hi Graham,

    It runs and then asks me to select a folder. Then says Permission Denied.

    Any idea why it says this?

    Sunday, August 16, 2015 10:31 AM
  • Hmmm. You could try logging on to olNS e.g. by adding a line as shown

    Set olNS = olApp.GetNamespace("MAPI")
    olNS.Logon

    The other thing to try is to change the line

    Set olFolder = olNS.PickFolder
    to address a specific folder, instead of trying to pick one.  I have retested here and it Works with Excel 2010/Outlook 2010.


    Graham Mayor - Word MVP
    www.gmayor.com

    Sunday, August 16, 2015 11:50 AM
  • Hi Graham,

    Thanks for the fast reply. I really like the idea of being able to select a folder (may come in useful for other extracts in the future).

    So I changed the code to this below

    Set olNS = olApp.GetNamespace("MAPI")
    olNS.Logon
    Set olFolder = olNS.PickFolder

    Still coming up with the same error. Run Time Error 70 Permission Denied. Also every time I try and run the code and get to the folder selection section it creates a new workbook. Can I make it allways import into the original workbook?

    You have been a big help so far :)

    Not sure if this causes an issue but I am using Excel 2013 and Outlook 2013
    Sunday, August 16, 2015 12:13 PM
  • Not sure why you are getting permission errors, but the code to use the same workbook is as follows (the additional functions would be the same)

    Option Explicit
    Const fPath As String = "C:\Path\Reports\" 'The path to save the messages
    Const sfName As String = "C:\Path\Message Log.xlsx"
    
    Sub Download_Outlook_Mail_To_Excel()
    Dim olApp As Object
    Dim olFolder As Object
    Dim olNS As Object
    Dim xlBook As Workbook
    Dim xlSheet As Worksheet
    Dim NextRow As Long
    Dim i As Long
    Dim olItem As Object
        If FileExists(sfName) Then
            Set xlBook = Workbooks.Open(sfName)
            Set xlSheet = xlBook.Sheets(1)
        Else
            Set xlBook = Workbooks.Add
            Set xlSheet = xlBook.Sheets(1)
            With xlSheet
                .Cells(1, 1) = "Sender"
                .Cells(1, 2) = "Subject"
                .Cells(1, 3) = "Date"
                '.Cells(1, 4) = "Size"
                .Cells(1, 5) = "EmailID"
                .Cells(1, 6) = "Body"
            End With
            xlBook.SaveAs sfName
        End If
        On Error Resume Next
        Set olApp = GetObject(, "Outlook.Application")
        If Err <> 0 Then
            Set olApp = CreateObject("Outlook.Application")
        End If
        On Error GoTo 0
        With xlSheet
            .Cells(1, 1) = "Sender"
            .Cells(1, 2) = "Subject"
            .Cells(1, 3) = "Date"
            '.Cells(1, 4) = "Size"
            .Cells(1, 5) = "EmailID"
            .Cells(1, 6) = "Body"
            CreateFolders fPath
            Set olNS = olApp.GetNamespace("MAPI")
            olNS.Logon
            Set olFolder = olNS.PickFolder
            For Each olItem In olFolder.Items
                NextRow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
                If olItem.Class = 43 Then
                    .Cells(NextRow, 1) = olItem.Sender
                    .Cells(NextRow, 2) = olItem.Subject
                    .Cells(NextRow, 3) = olItem.SentOn
                    '.Cells(NextRow, 4) =
                    .Cells(NextRow, 5) = SaveMessage(olItem)
                    '.Cells(NextRow, 6) = olItem.Body 'Are you sure?
                End If
            Next olItem
        End With
        xlBook.Close SaveChanges:=True
    lbl_Exit:
        Set olApp = Nothing
        Set olFolder = Nothing
        Set olItem = Nothing
        Set xlBook = Nothing
        Set xlSheet = Nothing
        Exit Sub
    End Sub


    Graham Mayor - Word MVP
    www.gmayor.com

    • Proposed as answer by ryguy72 Tuesday, December 22, 2015 2:55 AM
    Sunday, August 16, 2015 1:01 PM
  • Getting there now. I found out why The Rune Time Error 70 was happening. Was due to the folder being protected where it was trying to import the emails. Doh..... Sorry about that.

    I seem to be having an issue now. It is re-importing the same email into a folder I have created (C:\Users\neo_s_000\Desktop\Emails). I have tested against 4 emails. It does not duplicate the information in the spreadsheet which is good. Just re-imports the emails.

    It maybe best if when the email is exported from the inbox it deletes them also (that would be best I think, so they only exist in the exported folder). Not sure as how to do this.

    Also a unique ID is created when an email is imported into the spreadsheet that appears as an address to where the item is on the computer. Only issue is it is not turning it into a hyperlink in Excel. Really unsure how to force it to become a hyperlink.

    Last question on this but if I receive an email that is a reply and it already has the unique ID given in the code when importing can the same ID be added to the email? Unsure again how this is done.

    Thanks again for the help so far ^_^



    Sunday, August 16, 2015 1:50 PM
  • If you add the line

               olItem.Delete

    before the lines

                End If
            Next olItem

    that should delete delete the processed messages

    As for your unique ID, you'll have to explain how that works if you want to incorporate that. The naming in the macro is created in the SaveMessage function and uses the date the message is received. The name is not associated with the original message, which would now be deleted, so checking for an existing ID presents a problem.


    Graham Mayor - Word MVP
    www.gmayor.com

    • Proposed as answer by ryguy72 Tuesday, December 22, 2015 2:55 AM
    Monday, August 17, 2015 4:48 AM
  • Hmmmm what if I add a string of numbers in say column H that starts at 1 and auto adds a number after each email is imported. If the email imported is a reply it uses the number used on the original imported email. Question is can a formula do that or wold it have to be vba? 
    Monday, August 17, 2015 8:08 AM
  • I suppose you could do it either way, but it doesn't help with relating incoming messages with existing message ids.

    Graham Mayor - Word MVP
    www.gmayor.com

    Monday, August 17, 2015 12:05 PM
  • The email import section is fine. What I next need to do is add an idea to each row.  If it's a reply then add the original Id on the spreadsheet.  The other idea is to join or delete the original rowner if a reply comes in for the case and replace it with the new information. Kinda unsure how to do this. 

    Monday, August 17, 2015 12:22 PM
  • Can work out its a reply via re: in the subject line.
    Monday, August 17, 2015 12:23 PM
  • Would it be easier if we did not delete the emails? 
    Monday, August 17, 2015 12:33 PM