Questions

Can anyone help with this VBA code to extract data from an email body?

+
0 Votes
Locked

Can anyone help with this VBA code to extract data from an email body?

Larry Tyner
I am new to using VBA.

I am trying to extract data from the body of emails that have the same format. I am using Outlook 2007 and Excel 2007.

This is a sample email body.

Contractor ID Number : 0000001501
First Name : Larry
Last Name : Tyner
undefined : Self
Address Street 1 : 4787 Country Manor Drive Address Street 2 :
City : Sarasota
Zip Code : 34233
State : FL
Email : lttsr1@verizon.net


I have adapted the following code which appears to be reading the data but it is not being placed in a spreadsheet.

Sub Results()

'set up dimensions
Dim Namex As String
Dim i As Long, x As Long, k As Long, b As Long
Dim OLF As Outlook.MAPIFolder, oMAPI As Outlook.NameSpace
Dim Info(10)
Dim CutBack(10)

'set number of characters to be cut off from colon to colon
CutBack(1) = 11
CutBack(2) = 10
CutBack(3) = 10
CutBack(4) = 35
CutBack(5) = 35
CutBack(6) = 25
CutBack(7) = 30
CutBack(8) = 6
CutBack(9) = 3
CutBack(10) = 35

'set up access to mailbox
Set oMAPI = GetObject("", "Outlook.Application").GetNamespace("MAPI")
Set OLF = oMAPI.Folders.Item("Personal Folders").Folders("New Contractor Registrations")

'run through items in folder
For i = 1 To OLF.Items.Count
x = 0
With OLF.Items(i)

'run through body of e-mail
For a = 1 To Len(.Body)

'add one to x every time you find a colon
If Right(Left(.Body, a), 1) = ":" Then
x = x + 1
b = 1
'for each x, get and cut down the string you require
If (0 < x And 11 > x) Then
Info(x) = Empty
Do Until (Right(Left(.Body, a + b), 1) = ":")
Info(x) = Info(x) & Right(Left(.Body, a + b), 1)
b = b + 1
Loop
Info(x) = Left(Info(x), Len(Info(x)) - CutBack(x))

'write out results starting on row 2
Sheets("Results").Cells(i + 1, x) = Info(x)
End If

End If
'move to next character
Next a

End With
Next i

End Sub

Any assistance is appreciated.
  • +
    0 Votes
    robo_dev

    To begin with, if 'Results' is a variable, it needs to be declared, no?

    http://www.exceluser.com/explore/questions/vba_textcols.htm

    You might want to start by writing to a text file, just to get it working, as it's more difficult to write to an excel file

    +
    0 Votes
    Larry Tyner

    It appears that the data is being captured, but I obviously am deficient in the file writing.

    "Results" is the name of the workbook.

    Thanks

    +
    0 Votes
    NetMan1958

    it works for me. I'm using Excel and Outlook 2007. I created a folder in Outlook named "New Contractor Registrations" and placed an email in it that is an exact copy of your example email. It writes " 0000001501" in cell A2, " Larry" in cell B2, " Tyner" in cell C2 (including the leading space in each field) and then I get :
    Run-time error '5' :
    Invalid procedure call or argument

    +
    0 Votes
    Larry Tyner

    That's what it is supposed to do but loop through multiple emails.

    I have have only got the number in cell A2 once. I get Run-time err '5' on this line:
    Info(x) = Left(Info(x), Len(Info(x)) - CutBack(x))

    +
    0 Votes
    johnbseaman

    Ok it could be that 'undefined' is seen as a code response and not a value in excel. You could try changing it another field name i.e. undef or dontknow.

    +
    0 Votes
    Larry Tyner

    Edited the email to change field from undefined to Company Name:

    Still receive same error message on this line
    Info(x) = Left(Info(x), Len(Info(x)) - CutBack(x))

    +
    0 Votes
    jboughton29

    Try Adding the Option Explicit statement as well.
    I still feel that it is unhappy with trying to manipulate an "Empty" string on first go.

    +
    0 Votes
    Realvdude

    If Len(Info(x)) - CutBack(x) goes negative you'll get a error 5.

    May I suggest splitting the body into a string array based on vbCrLf (Enter)?

    My example just builds the body string, as my Outlook accesses Exchange Server, but you can substitute your body string.

    Sub Results()
    Dim body As String, sts() As String, iCnt As Integer, colPos As Integer

    body = "Contractor ID Number : 0000001501" + vbCrLf + _
    "First Name : Larry" + vbCrLf + _
    "Last Name : Tyner" + vbCrLf + _
    "undefined: Self" + vbCrLf + _
    "Address Street 1 : 4787 Country Manor Drive Address Street 2 :" + vbCrLf + _
    "City: Sarasota" + vbCrLf + _
    "Zip Code : 34233" + vbCrLf + _
    "State: FL" + vbCrLf + _
    "Email: lttsr1@ verizon.net"

    sts() = Split(body, vbCrLf)
    For iCnt = 0 To UBound(sts)
    colPos = InStr(sts(iCnt), ":")
    If colPos > 0 Then 'we have a piece of information
    If Len(sts(iCnt)) > colPos + 1 Then 'we have a value for it
    'Insert into worksheet
    Debug.Print Mid(sts(iCnt), colPos + 1) 'The value
    End If
    End If
    Next
    End Sub

    You'll note that Address 2: is not handled. You can place it on its own line in the email or add a second InStr starting at colPos + 1 to capture its position.
    At the insert into worksheet, you could add a Select statement and check Left(sts(iCnt),colPos -1) for the information name and determine column to place the value.

    +
    0 Votes
    Spitfire_Sysop

    I agree that saving the data as a text file first will save you a lot of data processing time. There are functions built in to excel for handling text file input. You are attempting to re-code these functions. You can save each message in to a text file of the same name in a loop using excel to place the data you want in to the proper cells of a workbook. This can all be done from a VBScript within excel.

    When you open a text file in excel you can make map the data to cells based on a character like spaces, commas or the colon.

    Here is the text open command:
    <code>
    Workbooks.OpenText Filename:= "emailfile.txt", Origin:=437, StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar:=":", TrailingMinusNumbers:=True
    </code>

    The important part is <code>Other:=True, OtherChar:=":"</code>
    This will put everything on the right of the colon in column B and then you can do whatever processing you want to it.

    +
    1 Votes
    NetMan1958

    This code expounds on what "techr" posted above. I tested it and it works for me.

    Sub Results()
    Dim OLF As Outlook.MAPIFolder, oMAPI As Outlook.Namespace
    Dim sts() As String, iCnt As Integer, colPos As Integer, i As Integer, Row As Integer, Col As Integer
    Set oMAPI = GetObject("", "Outlook.Application").GetNamespace("MAPI")
    Set OLF = oMAPI.Folders.Item("Personal Folders").Folders("New Contractor Registrations")

    For i = 1 To OLF.items.Count
    Row = i + 1 'current Excel row
    sts() = Split(OLF.items(i).body, vbCrLf)
    For iCnt = 0 To UBound(sts)
    Col = iCnt + 1 'current Excel column
    colPos = InStr(sts(iCnt), ":")
    If colPos > 0 Then 'we have a piece of information
    If Len(sts(iCnt)) > colPos + 1 Then 'we have a value for it
    'Insert into worksheet
    Sheets("Results").Cells(Row, Col) = Mid(sts(iCnt), colPos + 1)
    End If
    End If
    Next
    Next i
    End Sub

    +
    0 Votes
    Larry Tyner

    Thanks -

    I tried this which appears to me should work but I got a error message
    Runtime error '9' on this line
    Sheets("Results").Cells(Row, Col) = Mid(sts(iCnt), colPos + 1)

    What am I missing?

    +
    0 Votes
    Larry Tyner

    I got the error '9' running the VBA in Excel

    I also tried it in Oulook and got a runtime error '1004' on this line
    Sheets("Results").Cells(Row, Col) = Mid(sts(iCnt), colPos + 1)

    It stated Method 'Sheets' of object'_Global' failed

    +
    0 Votes
    NetMan1958

    From what I can tell, Run-time error 9 is a "subscript out of range" error.
    Run it in Excel and add the following line just above the problem line so that it looks like this:
    'Insert into worksheet
    Debug.Print Row & ", " & Col & ", " & iCnt & ", " & colPos & vbCrLf
    Sheets("Sheet1").Cells(Row, Col) = Mid(sts(iCnt), colPos + 1)

    Then run it so that you get the error. Go to the last line in the Immediate Window and examine the vlaues for Row, Col, iCnt and colPos to see if they are out of whack.

    +
    0 Votes
    Larry Tyner

    Got compile error on the word Row after Print in this insert - variable not defined

    +
    0 Votes
    Larry Tyner

    OK - Got it to run thru.
    Row = 2
    Col = 1
    colPos = 22 (that doesn't seem right)

    +
    0 Votes
    bjblok

    Hi,

    You will find that the use of Regex (Regular Expressions) will help cut down on the code and make it more readable.

    http://msdn.microsoft.com/en-us/library/system.text.regularexpressions.regex.aspx

    Bart

    +
    1 Votes
    NetMan1958

    You posted :
    "OK - Got it to run thru.
    Row = 2
    Col = 1
    colPos = 22 (that doesn't seem right)"

    I think that is OK as colPos represents the position of the colon in the line. What was the value for "iCnt" ?

    +
    0 Votes
    Larry Tyner

    Thanks for your help.

    The following code works.

    I neglected to name the sheet "Results"

    Now I'll work on code to move the emails to another folder once run through the data extraction.

    +
    0 Votes
    Larry Tyner

    Whoops - here's the code.

    Sub Results()

    Dim OLF As Outlook.MAPIFolder, oMAPI As Outlook.Namespace

    Dim sts() As String, iCnt As Integer, colPos As Integer, i As Integer, Row As Integer, Col As Integer

    Set oMAPI = GetObject("", "Outlook.Application").GetNamespace("MAPI")

    Set OLF = oMAPI.Folders.Item("Personal Folders").Folders("New Contractor Registrations")

    For i = 1 To OLF.Items.Count

    Row = i + 1 'current Excel row

    sts() = Split(OLF.Items(i).Body, vbCrLf)

    For iCnt = 0 To UBound(sts)

    Col = iCnt + 1 'current Excel column

    colPos = InStr(sts(iCnt), ":")

    If colPos > 0 Then 'we have a piece of information

    If Len(sts(iCnt)) > colPos + 1 Then 'we have a value for it

    'Insert into worksheet

    'Insert into worksheet

    Sheets("Results").Cells(Row, Col) = Mid(sts(iCnt), colPos + 1)

    End If

    End If

    Next

    Next i

    End Sub

  • +
    0 Votes
    robo_dev

    To begin with, if 'Results' is a variable, it needs to be declared, no?

    http://www.exceluser.com/explore/questions/vba_textcols.htm

    You might want to start by writing to a text file, just to get it working, as it's more difficult to write to an excel file

    +
    0 Votes
    Larry Tyner

    It appears that the data is being captured, but I obviously am deficient in the file writing.

    "Results" is the name of the workbook.

    Thanks

    +
    0 Votes
    NetMan1958

    it works for me. I'm using Excel and Outlook 2007. I created a folder in Outlook named "New Contractor Registrations" and placed an email in it that is an exact copy of your example email. It writes " 0000001501" in cell A2, " Larry" in cell B2, " Tyner" in cell C2 (including the leading space in each field) and then I get :
    Run-time error '5' :
    Invalid procedure call or argument

    +
    0 Votes
    Larry Tyner

    That's what it is supposed to do but loop through multiple emails.

    I have have only got the number in cell A2 once. I get Run-time err '5' on this line:
    Info(x) = Left(Info(x), Len(Info(x)) - CutBack(x))

    +
    0 Votes
    johnbseaman

    Ok it could be that 'undefined' is seen as a code response and not a value in excel. You could try changing it another field name i.e. undef or dontknow.

    +
    0 Votes
    Larry Tyner

    Edited the email to change field from undefined to Company Name:

    Still receive same error message on this line
    Info(x) = Left(Info(x), Len(Info(x)) - CutBack(x))

    +
    0 Votes
    jboughton29

    Try Adding the Option Explicit statement as well.
    I still feel that it is unhappy with trying to manipulate an "Empty" string on first go.

    +
    0 Votes
    Realvdude

    If Len(Info(x)) - CutBack(x) goes negative you'll get a error 5.

    May I suggest splitting the body into a string array based on vbCrLf (Enter)?

    My example just builds the body string, as my Outlook accesses Exchange Server, but you can substitute your body string.

    Sub Results()
    Dim body As String, sts() As String, iCnt As Integer, colPos As Integer

    body = "Contractor ID Number : 0000001501" + vbCrLf + _
    "First Name : Larry" + vbCrLf + _
    "Last Name : Tyner" + vbCrLf + _
    "undefined: Self" + vbCrLf + _
    "Address Street 1 : 4787 Country Manor Drive Address Street 2 :" + vbCrLf + _
    "City: Sarasota" + vbCrLf + _
    "Zip Code : 34233" + vbCrLf + _
    "State: FL" + vbCrLf + _
    "Email: lttsr1@ verizon.net"

    sts() = Split(body, vbCrLf)
    For iCnt = 0 To UBound(sts)
    colPos = InStr(sts(iCnt), ":")
    If colPos > 0 Then 'we have a piece of information
    If Len(sts(iCnt)) > colPos + 1 Then 'we have a value for it
    'Insert into worksheet
    Debug.Print Mid(sts(iCnt), colPos + 1) 'The value
    End If
    End If
    Next
    End Sub

    You'll note that Address 2: is not handled. You can place it on its own line in the email or add a second InStr starting at colPos + 1 to capture its position.
    At the insert into worksheet, you could add a Select statement and check Left(sts(iCnt),colPos -1) for the information name and determine column to place the value.

    +
    0 Votes
    Spitfire_Sysop

    I agree that saving the data as a text file first will save you a lot of data processing time. There are functions built in to excel for handling text file input. You are attempting to re-code these functions. You can save each message in to a text file of the same name in a loop using excel to place the data you want in to the proper cells of a workbook. This can all be done from a VBScript within excel.

    When you open a text file in excel you can make map the data to cells based on a character like spaces, commas or the colon.

    Here is the text open command:
    <code>
    Workbooks.OpenText Filename:= "emailfile.txt", Origin:=437, StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar:=":", TrailingMinusNumbers:=True
    </code>

    The important part is <code>Other:=True, OtherChar:=":"</code>
    This will put everything on the right of the colon in column B and then you can do whatever processing you want to it.

    +
    1 Votes
    NetMan1958

    This code expounds on what "techr" posted above. I tested it and it works for me.

    Sub Results()
    Dim OLF As Outlook.MAPIFolder, oMAPI As Outlook.Namespace
    Dim sts() As String, iCnt As Integer, colPos As Integer, i As Integer, Row As Integer, Col As Integer
    Set oMAPI = GetObject("", "Outlook.Application").GetNamespace("MAPI")
    Set OLF = oMAPI.Folders.Item("Personal Folders").Folders("New Contractor Registrations")

    For i = 1 To OLF.items.Count
    Row = i + 1 'current Excel row
    sts() = Split(OLF.items(i).body, vbCrLf)
    For iCnt = 0 To UBound(sts)
    Col = iCnt + 1 'current Excel column
    colPos = InStr(sts(iCnt), ":")
    If colPos > 0 Then 'we have a piece of information
    If Len(sts(iCnt)) > colPos + 1 Then 'we have a value for it
    'Insert into worksheet
    Sheets("Results").Cells(Row, Col) = Mid(sts(iCnt), colPos + 1)
    End If
    End If
    Next
    Next i
    End Sub

    +
    0 Votes
    Larry Tyner

    Thanks -

    I tried this which appears to me should work but I got a error message
    Runtime error '9' on this line
    Sheets("Results").Cells(Row, Col) = Mid(sts(iCnt), colPos + 1)

    What am I missing?

    +
    0 Votes
    Larry Tyner

    I got the error '9' running the VBA in Excel

    I also tried it in Oulook and got a runtime error '1004' on this line
    Sheets("Results").Cells(Row, Col) = Mid(sts(iCnt), colPos + 1)

    It stated Method 'Sheets' of object'_Global' failed

    +
    0 Votes
    NetMan1958

    From what I can tell, Run-time error 9 is a "subscript out of range" error.
    Run it in Excel and add the following line just above the problem line so that it looks like this:
    'Insert into worksheet
    Debug.Print Row & ", " & Col & ", " & iCnt & ", " & colPos & vbCrLf
    Sheets("Sheet1").Cells(Row, Col) = Mid(sts(iCnt), colPos + 1)

    Then run it so that you get the error. Go to the last line in the Immediate Window and examine the vlaues for Row, Col, iCnt and colPos to see if they are out of whack.

    +
    0 Votes
    Larry Tyner

    Got compile error on the word Row after Print in this insert - variable not defined

    +
    0 Votes
    Larry Tyner

    OK - Got it to run thru.
    Row = 2
    Col = 1
    colPos = 22 (that doesn't seem right)

    +
    0 Votes
    bjblok

    Hi,

    You will find that the use of Regex (Regular Expressions) will help cut down on the code and make it more readable.

    http://msdn.microsoft.com/en-us/library/system.text.regularexpressions.regex.aspx

    Bart

    +
    1 Votes
    NetMan1958

    You posted :
    "OK - Got it to run thru.
    Row = 2
    Col = 1
    colPos = 22 (that doesn't seem right)"

    I think that is OK as colPos represents the position of the colon in the line. What was the value for "iCnt" ?

    +
    0 Votes
    Larry Tyner

    Thanks for your help.

    The following code works.

    I neglected to name the sheet "Results"

    Now I'll work on code to move the emails to another folder once run through the data extraction.

    +
    0 Votes
    Larry Tyner

    Whoops - here's the code.

    Sub Results()

    Dim OLF As Outlook.MAPIFolder, oMAPI As Outlook.Namespace

    Dim sts() As String, iCnt As Integer, colPos As Integer, i As Integer, Row As Integer, Col As Integer

    Set oMAPI = GetObject("", "Outlook.Application").GetNamespace("MAPI")

    Set OLF = oMAPI.Folders.Item("Personal Folders").Folders("New Contractor Registrations")

    For i = 1 To OLF.Items.Count

    Row = i + 1 'current Excel row

    sts() = Split(OLF.Items(i).Body, vbCrLf)

    For iCnt = 0 To UBound(sts)

    Col = iCnt + 1 'current Excel column

    colPos = InStr(sts(iCnt), ":")

    If colPos > 0 Then 'we have a piece of information

    If Len(sts(iCnt)) > colPos + 1 Then 'we have a value for it

    'Insert into worksheet

    'Insert into worksheet

    Sheets("Results").Cells(Row, Col) = Mid(sts(iCnt), colPos + 1)

    End If

    End If

    Next

    Next i

    End Sub