Outlook电子邮件正文不会复制到Excel

时间:2016-05-12 14:11:43

标签: excel vba excel-vba outlook outlook-vba

以下代码有效它将从指定的电子邮件中打开指定的文件。但是它不会将身体信息分成excel中的不同行,有什么建议吗?

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

1 个答案:

答案 0 :(得分:3)

您可以在lRow语句中设置With,但每次有MyAr定义的换行符时,您还需要添加1行,请尝试:

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