Outlook and Excel

[praetorian_prefect_2004]

I need expert help. This code searches four lines in the body of the
email, and copies it to excel by column. I would like to add two more
columns where the date email was received and email subject are also
included.

Sub bodyStrip(msg As Outlook.MailItem)
Dim sBody As String
Dim aFields As Variant
Dim r As Range
Dim n&, iPos1&, ipos2&


aFields = Array("Order Number:", "UIC ID:", "UIC Short Name:", "Order
Status:")


Set r = [a65536].End(xlUp).Offset(1).Resize(, 4)
sBody = msg.Body


For n = 1 To 4
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)
Cells.Columns.AutoFit
Else
Exit For
End If
Next

End Sub

 

[Bernie Deitrick]

Add these lines:

r(5).Value = msg.ReceivedTime
r(6).Value = msg.Subject

after this line:

sBody = msg.Body


HTH,
Bernie
MS Excel MVP

 

[Bernie Deitrick]

Oops, you would need to change

Set r = [a65536].End(xlUp).Offset(1).Resize(, 4)

to

Set r = [a65536].End(xlUp).Offset(1).Resize(, 6)

Sorry about that...

HTH,
Bernie
MS Excel MVP

Add these lines:

r(5).Value = msg.ReceivedTime
r(6).Value = msg.Subject

after this line:

sBody = msg.Body


HTH,
Bernie
MS Excel MVP

I need expert help. This code searches four lines in the body of the
email, and copies it to excel by column. I would like to add two more
columns where the date email was received and email subject are also
included.

Sub bodyStrip(msg As Outlook.MailItem)
Dim sBody As String
Dim aFields As Variant
Dim r As Range
Dim n&, iPos1&, ipos2&


aFields = Array("Order Number:", "UIC ID:", "UIC Short Name:", "Order
Status:")


Set r = [a65536].End(xlUp).Offset(1).Resize(, 4)
sBody = msg.Body


For n = 1 To 4
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)
Cells.Columns.AutoFit
Else
Exit For
End If
Next

End Sub