CODEWITHSUNDEEP
vbaexceloutlookexcel-2013
neosegauk
neosegauk

Reputation: 53

Anyway To Export Email To Folder Including Attachments?

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 = "[email protected]"

    '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

Upvotes: 0

Views: 330

Answers (1)

B Quesnel
B Quesnel

Reputation: 21

instead of your for loop, you could do : 

Dim msg As Outlook.MailItem 
...

For Each msg in Folder.Items

    'You can access here each message properties, like msg.attachments...
     ThisWorkbook.Sheets(1).Cells(oRow, 1) = msg.Attachments.Item(1).FileName
     ...
     msg.Attachments.Item(1).SaveAsFile "C:\...."

Next

Upvotes: 1

Related Questions