I've used a variety of resources from stackoverflow and a few other places to get some code in VBA. This is the third iteration I've tried and still haven't gotten it to work. The first iteration was written mostly from scratch, but didn't work. The second iteration was based on this stackoverflow post. I had the code in the ThisOutlookSession Outlook Object to run at startup. The current iteration is based on this stackoveflow post and is in it's own Module. It's run using a rule in Outlook.
The part that gets the data from the email body has seemed to work fine in the previous iterations of the code. But the part that writes to Excel doesn't seem to be working, and hasn't worked in any of the previous iterations and I don't know why.
I have a rule set in Outlook to run the macro on emails with a specific subject line. These emails are structured in a specific way that makes it easy to get the data. The rule also sets these emails to read, which it does, so I can see the rule works.
I have an Excel sheet in My Documents with the first row being dedicated to labeling the columns. Though I've tried this with an empty Excel sheet as well and it still didn't work.
The email body looks something like this:
ID: 608
FirstName: test
MiddleInitial: t
LastName: testet
BirthDate: 01/01/1900
Gender: Male
StreetAddress:
City:
State:
Zip:
Ethnicity:
dtAdded: 01/19/2016
Area: Hair Loss
Area: Skin Cancer
There could be anywhere from 0 to 12 Areas, each simply labeled as Area. Below is some of the code I have. I've trimmed some of the repetitive parts so it isn't as long (still kind of long, sorry):
Option Explicit
Const xlUp As Long = -4162
Sub ExportToExcel(MyMail As MailItem)
Dim strID As String, olNS As Outlook.NameSpace
Dim olMail As Outlook.MailItem
Dim strFileName As String
'~~> Outlook Variables
Dim idNum As String
Dim firstName As String
Dim middleInitial As String
Dim lastName As String
Dim birthDate As String
Dim gender As String
Dim streetAddress As String
Dim city As String
Dim state As String
Dim zipcode As String
Dim ethnicity As String
Dim dateAdded As String
Dim area1 As String
Dim area2 As String
Dim area11 As String
Dim area12 As String
Dim areaOther As String
Dim areas As String
'~~> Process Outlook Stuff
idNum = ParseTextLinePair(olMail.Body, "ID:")
firstName = ParseTextLinePair(olMail.Body, "FirstName:")
middleInitial = ParseTextLinePair(olMail.Body, "MiddleInitial:")
lastName = ParseTextLinePair(olMail.Body, "LastName:")
birthDate = ParseTextLinePair(olMail.Body, "BirthDate:")
gender = ParseTextLinePair(olMail.Body, "Gender:")
streetAddress = ParseTextLinePair(olMail.Body, "StreetAddress:")
city = ParseTextLinePair(olMail.Body, "City:")
state = ParseTextLinePair(olMail.Body, "State:")
zipcode = ParseTextLinePair(olMail.Body, "Zipcode:")
ethnicity = ParseTextLinePair(olMail.Body, "Ethnicity:")
Dim intLocLabel As Integer
Dim intLocCRLF As Integer
Dim intLenLabel As Integer
'area1
intLocLabel = InStr(olMail.Body, "Area:")
intLenLabel = Len("Area:")
If intLocLabel > 0 Then
'vbCrLf = new line
intLocCRLF = InStr(intLocLabel, olMail.Body, vbCrLf)
If intLocCRLF > 0 Then
intLocLabel = intLocLabel + intLenLabel
area1 = Mid(olMail.Body, _
intLocLabel, _
intLocCRLF - intLocLabel)
Else
' this was Mid(..
area1 = Mid(olMail.Body, intLocLabel + intLenLabel)
End If
End If
'area2:
If intLocCRLF > 0 Then
intLocLabel = InStr(intLocCRLF, olMail.Body, "Area:")
If intLocLabel > 0 Then
intLocCRLF = InStr(intLocLabel, olMail.Body, vbCrLf)
If intLocCRLF > 0 Then
intLocLabel = intLocLabel + intLenLabel
area2 = Mid(olMail.Body, _
intLocLabel, _
intLocCRLF - intLocLabel)
Else
' this was Mid(..
area2 = Mid(olMail.Body, intLocLabel + intLenLabel)
End If
End If
End If
'area11:
If intLocCRLF > 0 Then
intLocLabel = InStr(intLocCRLF, olMail.Body, "Area:")
If intLocLabel > 0 Then
intLocCRLF = InStr(intLocLabel, olMail.Body, vbCrLf)
If intLocCRLF > 0 Then
intLocLabel = intLocLabel + intLenLabel
area11 = Mid(olMail.Body, _
intLocLabel, _
intLocCRLF - intLocLabel)
Else
' this was Mid(..
area11 = Mid(olMail.Body, intLocLabel + intLenLabel)
End If
End If
End If
'area12
If intLocCRLF > 0 Then
intLocLabel = InStr(intLocCRLF, olMail.Body, "Area:")
If intLocLabel > 0 Then
intLocCRLF = InStr(intLocLabel, olMail.Body, vbCrLf)
If intLocCRLF > 0 Then
intLocLabel = intLocLabel + intLenLabel
area12 = Mid(olMail.Body, _
intLocLabel, _
intLocCRLF - intLocLabel)
Else
' this was Mid(..
area12 = Mid(olMail.Body, intLocLabel + intLenLabel)
End If
End If
End If
'areaOther is easy because it has the Other Skin Problems label
areaOther = ParseTextLinePair(olMail.Body, "Other Skin Problems,")
If InStr(area1, "Other Skin Problems,") = 0 Then
areas = areas & area1
End If
If InStr(area2, "Other Skin Problems,") = 0 Then
areas = areas & area2
End If
If InStr(area3, "Other Skin Problems,") = 0 Then
areas = areas & area3
End If
If InStr(area4, "Other Skin Problems,") = 0 Then
areas = areas & area4
End If
If InStr(area5, "Other Skin Problems,") = 0 Then
areas = areas & area5
End If
If InStr(area6, "Other Skin Problems,") = 0 Then
areas = areas & area6
End If
If InStr(area7, "Other Skin Problems,") = 0 Then
areas = areas & area7
End If
If InStr(area8, "Other Skin Problems,") = 0 Then
areas = areas & area8
End If
If InStr(area9, "Other Skin Problems,") = 0 Then
areas = areas & area9
End If
If InStr(area10, "Other Skin Problems,") = 0 Then
areas = areas & area10
End If
If InStr(area11, "Other Skin Problems,") = 0 Then
areas = areas & area11
End If
If InStr(area12, "Other Skin Problems,") = 0 Then
areas = areas & area12
End If
'~~> Excel Variables
Dim oXLApp As Object, oXLwb As Object, oXLws As Object
Dim lRow As Long
strID = MyMail.EntryID
Set olNS = Application.GetNamespace("MAPI")
Set olMail = olNS.GetItemFromID(strID)
'~~> Establish an EXCEL application object
On Error Resume Next
Set oXLApp = GetObject(, "Excel.Application")
'~~> If not found then create new instance
If Err.Number <> 0 Then
Set oXLApp = CreateObject("Excel.Application")
End If
Err.Clear
On Error GoTo 0
'~~> Show Excel
oXLApp.Visible = True
'~~> Open the relevant file
Set oXLwb = oXLApp.Workbooks.Open("C:\Users\$$MYUSER$$\Documents\$$MYFILENAME$$.xlsx")
'~~> Set the relevant output sheet. Change as applicable
Set oXLws = oXLwb.Sheets("Sheet1")
lRow = oXLws.Range("A" & oXLApp.Rows.Count).End(xlUp).Row + 1
'~~> Write to outlook
With oXLws
'
'
.Range("A" & lRow).Value = idNum
.Range("B" & lRow).Value = dateAdded
.Range("O" & lRow).Value = firstName
.Range("P" & lRow).Value = middleInitial
.Range("Q" & lRow).Value = lastName
.Range("R" & lRow).Value = birthDate
.Range("S" & lRow).Value = gender
.Range("T" & lRow).Value = streetAddress
.Range("U" & lRow).Value = city
.Range("V" & lRow).Value = state
.Range("W" & lRow).Value = zipcode
.Range("AE" & lRow).Value = ethnicity
With .Range("C" & lRow)
If InStr(areas, "Acne") > 0 Then
.Value = "Yes"
End If
End With
With .Range("H" & lRow)
If InStr(areas, "Hair Loss") > 0 Then
.Value = "Yes"
End If
End With
With .Range("J" & lRow)
If InStr(areas, "Skin Cancer") > 0 Then
.Value = "Yes"
End If
End With
With .Range("L" & lRow)
If InStr(areas, "Wrinkles") > 0 Then
.Value = "Yes"
End If
End With
End With
Debug.Print idNum
Debug.Print firstName
'~~> Close and Clean up Excel
oXLwb.Close (True)
oXLApp.Quit
Set oXLws = Nothing
Set oXLwb = Nothing
Set oXLApp = Nothing
Set olMail = Nothing
Set olNS = Nothing
End Sub
Function ParseTextLinePair(strSource As String, strLabel As String)
'This function extracts the data from any label-data pair that appears
'in a block of text, where all the label-data pairs are on separate
'lines. A typical application would be parsing the text sent as email
'by a form on a web site, where the incoming message has multiple lines
'each with a different Label: Data pair
Dim intLocLabel As Integer
Dim intLocCRLF As Integer
Dim intLenLabel As Integer
Dim strText As String
' locate the label in the source text
' InStr returns 0 if srtLabel is not found in strSource
' InStr returns the position of the first occurance of strLabel in strSource
intLocLabel = InStr(strSource, strLabel)
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
strText = Mid(strSource, intLocLabel + intLenLabel)
End If
End If
' the Trim function can be useful to remove non-printing and
' leading or ending spaces from text
ParseTextLinePair = Trim(strText)
End Function
