General discussion
Thread display: Collapse - |
All Comments
Start or search
Create a new discussion
If you're asking for technical help, please be sure to include all your system info, including operating system, model number, and any other specifics related to the problem. Also please exercise your best judgment when posting in the forums--revealing personal information such as your e-mail address, telephone number, and address is not recommended.
Outlook email to excel: parse body text
Customer Name: John Doe
Contact Time: Any Phone - Anytime
Daytime Phone: 555-555-5555
Email: example@yahoo.com
Address: 123 example Lane, City, State 11111
So far I have been able to send the email to a excel spread sheet by using this code posted on this site with a how to. Then I found a parse text example on a different site with code listed below as well. Basically I am trying to integrate the two to make it just parse the name, contact time, phone, email, and address into a predefined spreadsheet. So anytime an email comes in it will automatically save this info into the spreadsheet.
Option Explicit
Sub ExportToExcel()
On Error GoTo ErrHandler
Dim appExcel As excel.Application
Dim wkb As excel.Workbook
Dim wks As excel.Worksheet
Dim rng As excel.Range
Dim strSheet As String
Dim strPath As String
Dim intRowCounter As Integer
Dim intColumnCounter As Integer
Dim msg As Outlook.MailItem
Dim nms As Outlook.NameSpace
Dim fld As Outlook.MAPIFolder
Dim itm As Object
strSheet = "OutlookItems.xls"
strPath = "C:\Examples\"
strSheet = strPath & strSheet
Debug.Print strSheet
'Select export folder
Set nms = Application.GetNamespace("MAPI")
Set fld = nms.PickFolder
'Handle potential errors with Select Folder dialog box.
If fld Is Nothing Then
MsgBox "There are no mail messages to export", vbOKOnly, _
"Error"
Exit Sub
ElseIf fld.DefaultItemType <> olMailItem Then
MsgBox "There are no mail messages to export", vbOKOnly, _
"Error"
Exit Sub
ElseIf fld.Items.Count = 0 Then
MsgBox "There are no mail messages to export", vbOKOnly, _
"Error"
Exit Sub
End If
'Open and activate Excel workbook.
Set appExcel = CreateObject("Excel.Application")
appExcel.Workbooks.Open (strSheet)
Set wkb = appExcel.ActiveWorkbook
Set wks = wkb.Sheets(1)
wks.Activate
appExcel.Application.Visible = True
'Copy field items in mail folder.
For Each itm In fld.Items
intColumnCounter = 1
Set msg = itm
intRowCounter = intRowCounter + 1
Set rng = wks.Cells(intRowCounter, intColumnCounter)
rng.Value = msg.To
intColumnCounter = intColumnCounter + 1
Set rng = wks.Cells(intRowCounter, intColumnCounter)
rng.Value = msg.SenderEmailAddress
intColumnCounter = intColumnCounter + 1
Set rng = wks.Cells(intRowCounter, intColumnCounter)
rng.Value = msg.Subject
intColumnCounter = intColumnCounter + 1
Set rng = wks.Cells(intRowCounter, intColumnCounter)
rng.Value = msg.SentOn
intColumnCounter = intColumnCounter + 1
Set rng = wks.Cells(intRowCounter, intColumnCounter)
rng.Value = msg.ReceivedTime
Next itm
Set appExcel = Nothing
Set wkb = Nothing
Set wks = Nothing
Set rng = Nothing
Set msg = Nothing
Set nms = Nothing
Set fld = Nothing
Set itm = Nothing
Exit Sub
ErrHandler:
If Err.Number = 1004 Then
MsgBox strSheet & " doesn't exist", vbOKOnly, _
"Error"
Else
MsgBox Err.Number & "; Description: ", vbOKOnly, _
"Error"
End If
Set appExcel = Nothing
Set wkb = Nothing
Set wks = Nothing
Set rng = Nothing
Set msg = Nothing
Set nms = Nothing
Set fld = Nothing
Set itm = Nothing
End Sub
I then found separate code that can search the body of a email and copy a certain section... here is the code...
Function ParseText(strSource As String, strLabel As String)
Set myolapp = CreateObject("Outlook.Application")
Set olns = myolapp.GetNamespace("MAPI")
Set myInbox = olns.PickFolder
Set myItems = myInbox.Items
Set myItem = myItems("Test")
Dim intLocLabel As Integer
Dim intLocCRLF As Integer
Dim intLenLabel As Integer
Dim strText As String
strSource = myItem.Body
' intLocLabel = "To:"
'intLocLabel = InStr(strSource, strLabel)
intLocLabel = InStr(strSource, "To:")
intLenLabel = Len(strLabel)
If intLocLabel > 0 Then
intLocCRLF = InStr(intLocLabel, strSource, vbCrLf)
If intLocCRLF > 0 Then
intLocLabel = intLocLabel + intLenLabel
strText = Mid(strSource, _
intLocLabel, _
intLocCRLF - intLocLabel)
Else
intLocLabel = Mid(strSource, intLocLabel + intLenLabel)
End If
End If
ParseText = Trim(strText)
End Function
Sub Search()
myValue = ParseText("To:", "To: <")
MsgBox myValue
End Sub