If you know for sure that the contents of each email are in that same
exact format, it's a simple matter to parse each email body and look
for the text you want.
Here's some VBA in Outlook that sets a reference to each email in your
default Inbox and writes some properties to an Excel worksheet. It's
untested but it should work to show you how you can write to a
worksheet from Outlook.
(Based on
http://www.codeforexcelandoutlook.com/blog/2008/09/export-outlook-contacts-to-excel/)
Option Explicit
Sub ExtractEmailsFromOutlookToExcel()
Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Dim myItems As Outlook.Items
Dim ThisItem As Object
Dim Msg As Outlook.MailItem
Dim xlApp As Excel.Application
Dim MyBook As Excel.Workbook
Dim MySheet As Excel.Worksheet
Dim arrData() As Variant
Dim i As Long
Application.ScreenUpdating = False
Set olApp = Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set myItems = olNS.GetDefaultFolder(olFolderInbox).Items
If myItems.Count > 0 Then
' resize data array to hold 3 random msg properties
ReDim arrData(1 To myItems.Count, 1 To 3)
' get Excel and set up some basic wksht properties
Set xlApp = GetExcelApplication
Set MyBook = xlApp.Workbooks.Add
Set MySheet = MyBook.Sheets(1)
MySheet.Name = "Emails"
' loop through each item and write to array
For i = 1 To myItems.Count
If TypeName(myItems.Item(i)) = "MailItem" Then
Set Msg = ThisItem
With Msg
arrData(i, 1) = .Sensitivity
arrData(i, 2) = .ReceivedTime
arrData(i, 3) = .SenderEmailType
End With
End If
Next i
' dump array to worksheet in one shot
MySheet.Range("A1").Offset(1, 0).Resize(myItems.Count, 3).Value =
arrData
End If
ExitProc:
Set olApp = Nothing
Set olNS = Nothing
Set myItems = Nothing
End Sub
Function GetExcelApplication()
On Error Resume Next
Set GetExcelApplication = GetObject(, "Excel.Application")
If Err <> 0 Then
Set GetExcelApplication = CreateObject("Excel.Application")
End If
On Error GoTo 0
End Function
