VBA code to search for an email and copy the body into excel

Question

I am trying to write code that would sort one of the inboxes from my outlook for an email with specific subject and copy the body of the email (its a table) into excel. This is what I have so far. Can't get the code to work though and not sure how to specify which inbox I want to search. Appreciate any help!

Sub CopyEmail()

    Dim olApp As Outlook.Application
    Dim olNs As Outlook.Namespace
    Dim olFldr As Outlook.MAPIFolder
    Dim olItms As Outlook.Items
    Dim olMail As Variant

    Set olApp = New Outlook.Application
    Set olNs = olApp.GetNamespace(”MAPI”) 'get a runtime error here
    Set olFldr = olNs.GetDefaultFolder(olFolderInbox)
    Set olItms = olFldr.Items

    Dim NLXemail As String
    NLXemail = "Patient Receipts"

    olItms.Sort NLXemail

         If InStr(1, olMail.Subject, NLXemail, vbTextCompare) > 0 Then
            ThisWorkbook.Sheets("Sheet1").Cells(3, 1).Value = outMail.Body

        End If

    Set olFldr = Nothing
    Set olNs = Nothing
    Set olApp = Nothing

End Sub

Answer 1

This will copy the body to Excel and a whole lot more.

Option Explicit
'This Code is Downloaded from OfficeTricks.com
'Visit this site for more such Free Code
Sub Export_Outlook_Emails_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 = "MailBox Name"

    'Mailbox Folder or PST Folder Name (As how it is displayed in your Outlook Session)
    Pst_Folder_Name = "Folder Name" '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

See the link below for more info.

http://officetricks.com/outlook-email-download-to-excel/

Answer 2

Figured it out. The script below finds a specific email in the specific outlook mailbox and copies the contents (a table) from the body of the email into excel.

Sub Copyemailbody_refresh()

Dim Folder As Outlook.MAPIFolder
Dim sFolders As Outlook.MAPIFolder
Dim MailBoxName As String, Pst_Folder_Name  As String
Dim oMail As Outlook.MailItem
Dim y As Long, x As Long
Dim olInsp As Outlook.Inspector
Dim wdDoc As Word.Document
Dim tb As Word.Table
Dim Myemail As String
Dim Atmt As Attachment
Dim irow As Integer
irow = 1
'set email date
Dim Emaildate As String
Emaildate = Sheets("Refresh").Range("G12").Value
'set email subject
Myemail = "Today's receipts " & Emaildate”
'Mailbox or PST Main Folder Name to set the name of the inbox - I have several mailboxes, needed to specify
 MailBoxName = "Mymailbox1"  

'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 direct to a Folder at a high level
 Set Folder = Outlook.Session.Folders(MailBoxName).Folders(Pst_Folder_Name)

'copying the email contents into the refresh file
For Each oMail In Folder.Items
 If oMail.Subject = Myemail Then
  With oMail
  Set olInsp = .GetInspector
  Set wdDoc = olInsp.WordEditor

  For Each tb In wdDoc.Tables 'assumes only 1 table in the body of the email

For y = 1 To tb.Rows.Count
For x = 1 To tb.Columns.Count

 Sheets("Refresh").Select 
 Range("A1").Select 
 Selection.Offset(y, x).Value = tb.Cell(y, x).Range

    Next

  Next

 Next

    End With

End If

Next

 'since the table was pasted as a word object, needed to convert text to numbers to perform calc on the table– not sure of a quicker way to do this than Text to columns

Sheets("Refresh").Select
Columns("B:B").Select
Selection.TextToColumns Destination:=Range("B1"), DataType:=xlDelimited
Columns("C:C").Select
Selection.TextToColumns Destination:=Range("C1"), DataType:=xlDelimited
Columns("D:D").Select
Selection.TextToColumns Destination:=Range("D1"), DataType:=xlDelimited
Columns("E:E").Select
Selection.TextToColumns Destination:=Range("E1"), DataType:=xlDelimited
End Sub