Problem creating an array using system generated email

[bobaftt]

I am trying to adapt the code below for my use in excel to scrape information from an outlook email so that I can create a new record for an individual. I struggle to use arrays so this may not be the best way to do what I want but my questions are as follows.
1. how do I get the macro to read off of another folder other than inbox?
2. How do I get the macro to create a new line for each blankety blank coverage including the rest of the data listed above?
I have scrubbed the data but you can get the idea.
The email looks like this with a subject of:
Action Required: Manually add employee, traditional coverage, not late

Action Required: Manually add employee, traditional coverage, not late
Customer ID: 0123456
Customer Name: Blankety blank customer
Billing ID: E1821129
Billing Name: Blankety blank customer
Payroll Frequency:
Reason for Enrollment: New Applicant
First Name: New
Middle Initial:
Last Name: Customer
Suffix:
Date of Birth: 99/99/9999
Gender: F
SSN: 123456789
Employee ID:
Date of Hire: 11/10/01
Date Newly Eligible: 11/10/01
Earnings: 100000.00
Earnings Mode: A
Eligibility Class: Blah Blah Blah
Signature Date:
Automatically Enrolled Coverages:
Blankety Blank Coverage1 (Coverage Effective Date 10/28/2010)
Blankety Blank Coverage2 (Coverage Effective Date 10/28/2010)
Blankety Blank Coverage 3 (Coverage Effective Date 10/28/2010)
Blankety Blank Coverage 4 (Coverage Effective Date 10/28/2010)

Option Explicit
Option Compare Text
Sub ReadInbox()
Dim appOL As Outlook.Application
Dim oSpace As Outlook.Namespace
Dim oFolder As Outlook.MAPIFolder
Dim oItems As Outlook.Items
Dim oMail As Outlook.MailItem
Set appOL = CreateObject("Outlook.Application")
Set oSpace = appOL.GetNamespace("MAPI")
Set oFolder = oSpace.GetDefaultFolder(olFolderInbox)
Set oItems = oFolder.Items
oItems.Sort "Received", True
For Each oMail In oItems
If oMail.Subject Like "Action Required: Manually add*" Then
Call bodyStrip(oMail)
End If
Next
End Sub
Sub bodyStrip(msg As Outlook.MailItem)
Dim sBody As String
Dim aFields As Variant
Dim r As Range
Dim n&, iPos1&, ipos2&
aFields = Array("Customer ID:", "Customer Name:", "Billing ID:", "Billing Name:", "Payroll Frequency:", "Reason for enrollment:" _
, "First Name:", "Middle Initial:", "Last Name:", "Suffix:", "Date of Birth:", "Gender:", "SSN:", "Employee ID:", "Date of Hire:" _
, "Date Newly eligible:", "Earnings:", "Earnings Mode:", "Eligibility Class:", "Signature Date:", "Automatically Enrolled Coverages:")
Set r = [a65536].End(xlUp).Offset(1).Resize(, 20)
sBody = msg.Body
For n = 1 To 20
iPos1 = InStr(ipos2 + 1, sBody, aFields(n - 1))
If iPos1 > 0 Then
iPos1 = iPos1 + Len(aFields(n - 1))
ipos2 = InStr(iPos1 + 1, sBody, vbCrLf)

r(n) = Mid(sBody, iPos1, ipos2 - iPos1)
Else
Exit For
End If
Next
End Sub

 

[ChrisOswald]

Hi,
from here
http://www.outlookcode.com/codedetail.aspx?id=824

I found some code that'll make getting a different MAPI folder simpler.

Function GetFolder(strFolderPath)
    ' folder path needs to be something like
    '   "Public Folders\All Public Folders\Company\Sales"
    '   or "Mailbox - User Name\Calendar\My Events"
    Dim objApp As Outlook.Application
    Dim objNS As Outlook.NameSpace
    Dim colFolders As Outlook.Folders
    Dim objFolder As Outlook.MAPIFolder
    Dim arrFolders() As String
    Dim i As Long
    Dim j As Long
    On Error Resume Next
 
    ' just in case the path string uses the wrong
    ' slash mark
    strFolderPath = Replace(strFolderPath, "/", "\")
    arrFolders() = Split(strFolderPath, "\")
    Set objApp = CreateObject("Outlook.Application")
    Set objNS = objApp.GetNamespace("MAPI")
    ' set starting folder and array element
    If Left(strFolderPath, 34) = _
      "Public Folders\All Public Folders\" Then
        Set objFolder = objNS.GetDefaultFolder( _
                        olPublicFoldersAllPublicFolders)
        j = 2
    Else
        Set objFolder = objNS.Folders.Item(arrFolders(0))
        j = 1
    End If
 
    If Not objFolder Is Nothing Then
        For i = j To UBound(arrFolders)
            Set colFolders = objFolder.Folders
            Set objFolder = Nothing
            Set objFolder = colFolders.Item(arrFolders(i))
            If objFolder Is Nothing Then
                Exit For
            End If
        Next
    End If
    Set GetFolder = objFolder
    Set colFolders = Nothing
    Set objNS = Nothing
    Set objApp = Nothing
End Function

and replace

Set oFolder = oSpace.GetDefaultFolder(olFolderInbox)
 
with 
 
Set oFolder = oSpace.GetDefaultFolder("Whatever my folder path is")

Now, the second question is a lot more .... twitchy. If each line ends with a line break character (chr(13), chr(11), something else?), you might be able to use something (roughly) like this.

Sub bodyStrip(msg As Outlook.MailItem)
    Dim sBody                       As String
    Dim aFields                     As Variant
    Dim MyRowNbr                    As Long
    Dim i                           As Long
    Dim j                           As Long
    Dim SbodyClauses()              As Variant
    aFields = Array("Customer ID:", "Customer Name:", "Billing ID:", "Billing Name:", "Payroll Frequency:", "Reason for enrollment:" _
                    , "First Name:", "Middle Initial:", "Last Name:", "Suffix:", "Date of Birth:", "Gender:", "SSN:", "Employee ID:", "Date of Hire:" _
                    , "Date Newly eligible:", "Earnings:", "Earnings Mode:", "Eligibility Class:", "Signature Date:", "Automatically Enrolled Coverages:")
 
    MyRowNbr = Range("A65536").End(xlUp).Row + 1
 
    sBody = msg.Body
 
    'If you're lucky, you'll be able to split out on some special character,
    'or from a bunch of blank spaces, or something clever.
    SbodyClauses = Split(sBody, Chr(13))
 
 
 
    'Warning: This nested loop has not been tested.  I have an amazing aptitude for randomly reversing my indices
 
    For i = LBound(aFields(), 1) To UBound(aFields(), 1)
        For j = LBound(SbodyClauses(), 1) To UBound(SbodyClauses(), 1)
            If Left(SbodyClauses(j), Len(aFields(i))) = aFields(i) Then
                Cells(MyRowNbr, i) = Mid(SbodyClauses(j), Len(aFields(i) + 1))
                Exit For
            End If
        Next j
    Next i

Of course, this won't work for the items where search terms are in the middle, but use of INSTR() will give you a hand. Or RegEX's might be the solution.

 

[bobaftt]

Thanks for the suggestions I will try them and let you know.

 

[bobaftt]

Any reason to use a function rather than a sub?

 

[ChrisOswald]

For the GetOLFolder function? I think it makes it easier to reuse the code and to read the sub that's calling it.

 

[bobaftt]

thanks again. I am not super familiar with Functions and was curious about the benefit to using the Function rather than the Sub.

Thanks!