CODEWITHSUNDEEP
excelvbaoutlook
Luis
Luis

Reputation: 139

Body of outlook email does not copy to excel

The following code works It will open up designated file from designated email. However it will not Seperate the body message into different line in excel, any suggestions?

For i = LBound(MyAr) To UBound(MyAr)
    '~~> This will give you the contents of your email
    '~~> on separate lines
    Debug.Print MyAr(i)
Next i
    End With

Const xlUp As Long = -4162

Sub ExportToExcel(MyMail As MailItem)
    Dim strID As String, olNS As Outlook.NameSpace
    Dim olMail As Outlook.MailItem
    Dim strFileName As String

'~~> Excel Variables
Dim oXLApp As Object, oXLwb As Object, oXLws As Object
Dim lRow As Long

strID = MyMail.EntryID
Set olNS = Application.GetNamespace("MAPI")
Set olMail = olNS.GetItemFromID(strID)

'~~> Establish an EXCEL application object
On Error Resume Next
Set oXLApp = GetObject(, "Excel.Application")

'~~> If not found then create new instance
If Err.Number <> 0 Then
    Set oXLApp = CreateObject("Excel.Application")
End If
Err.Clear
On Error GoTo 0

'~~> Show Excel
oXLApp.Visible = True

'~~> Open the relevant file
Set oXLwb = oXLApp.Workbooks.Open("C:\Users\ltorres\Documents\multiplier.xlsx")

'~~> Set the relevant output sheet. Change as applicable
Set oXLws = oXLwb.Sheets("Sheet1")

lRow = oXLws.Range("A" & oXLws.Rows.Count).End(xlUp).Row + 1

'~~> Write to outlook
With oXLws
Dim MyAr() As String

MyAr = Split(olMail.Body, vbCrLf)

For i = LBound(MyAr) To UBound(MyAr)
    '~~> This will give you the contents of your email
    '~~> on separate lines
    Debug.Print MyAr(i)
Next i
    End With

'~~> Close and Clean up Excel
oXLwb.Close (True)
oXLApp.Quit
Set oXLws = Nothing
Set oXLwb = Nothing
Set oXLApp = Nothing

Set olMail = Nothing
Set olNS = Nothing

End Sub

Upvotes: 1

Views: 205

Answers (1)

Jordan
Jordan

Reputation: 4514

You can set lRow in the With statement, but you also need to add 1 row each time there is a line break as defined by your MyAr, try:

With oXLws
lRow = .Range("A" & .Rows.Count).End(xlUp).Row + 1
Dim MyAr() As String
MyAr = Split(olMail.Body, vbCrLf)
For i = LBound(MyAr) To UBound(MyAr)
    .Range("A" & lRow).Value = MyAr(i)
    lRow = lRow + 1
Next i
End With

Upvotes: 3

Related Questions