Code to scrape system generated outlook email doesn't get all the data

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

bump no response.