Sub Extract()
On Error Resume Next
Set myOlApp = Outlook.Application
Set mynamespace = myOlApp.GetNamespace("mapi")
Dim objFS As New Scripting.FileSystemObject
Dim objFile As Scripting.TextStream
Dim FilePath As String
Dim sFilePath As String
Dim fileNumber As Integer
Dim strRowData As String
Dim strDelimiter As String
Dim j As Integer
strRowData = ""
Set myfolder = myOlApp.ActiveExplorer.CurrentFolder
sFilePath = "C:\a" & Format(Now, "ddmmyyyyhhmmss") & ".txt"
For i = 1 To myfolder.Items.Count
messageArray = ""
strRowData = ""
Set myitem = myfolder.Items(i)
msgtext = Trim(myitem.Body)
'search for specific text
delimtedMessage = Replace(Trim(msgtext), "Name", "###")
delimtedMessage = Replace(Trim(delimtedMessage), "Account Number", "###")
delimtedMessage = Replace(Trim(delimtedMessage), "Address", "###")
delimtedMessage = Replace(delimtedMessage, "Telephone Number", "###")
delimtedMessage = Replace(delimtedMessage, "DOB", "###")
delimtedMessage = Replace(delimtedMessage, "University", "###")
delimtedMessage = Replace(delimtedMessage, "SUbjects", "###")
delimtedMessage = Replace(delimtedMessage, "Birth Place", "###")
delimtedMessage = Replace(delimtedMessage, "SCore", "###")
delimtedMessage = Replace(delimtedMessage, "Outcome", "###")
delimtedMessage = Replace(delimtedMessage, "References", "###")
messageArray = Split(delimtedMessage, "###")
For j = 1 To 11
strRowData = strRowData & Replace(Replace(Trim(strRowData & Trim(messageArray(j)) & "|"), vbCr, ""), vbLf, "")
Next j
MsgBox strRowData
If i = 1 Then
' create the file on first run
Set objFile = objFS.CreateTextFile(sFilePath, False)
Else
' open text file on succeeding files
Set objFile = objFS.OpenTextFile(sFilePath, ForAppending)
End If
With objFile
.WriteLine strRowData
End With
objFile.Close
Next i
End Sub