Outlook and Excel

  • Thread starter Thread starter praetorian_prefect_2004
  • Start date Start date
P

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
 
Add these lines:

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

after this line:

sBody = msg.Body


HTH,
Bernie
MS Excel MVP
 
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


Bernie Deitrick said:
Add these lines:

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

after this line:

sBody = msg.Body


HTH,
Bernie
MS Excel MVP


[email protected] said:
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
Click to expand...
Click to expand...
 
Back
Top