从电子邮件复制到excel

Question

我不是VBA专家，遇到了一个我无法理解的错误，你能帮忙建议吗？

我需要一个excel宏来从文件夹中的所有电子邮件复制到我的excel，在谷歌上搜索并找到以下代码。对于一些电子邮件，该代码运行良好，之后将出现运行时错误440：数组索引在此行越界。

abody=拆分（objfolder.Items（i）.Body，vbNewLine）

大多数时候，我只是记录宏并从中进行编辑，所以我并不真正理解什么是数组索引越界。真的希望你能启发我，提前非常感谢你的帮助完整的代码可以在下面找到。。。

---

添加在宏将获取其正在处理的电子邮件的详细信息的部分。。。但令我困惑的是，收到的电子邮件细节与正文不符。有人能帮忙建议吗？

---

Sub test()
Dim olApp As Object
Dim olNS As Object
Dim olFldr As Object
Dim olMail As Object
Dim i As Integer
Dim j As Long
Dim abody() As String
Dim Cnt As Long
Dim arrData() As Variant
Set olApp = CreateObject("Outlook.Application")
Set olNS = olApp.GetNamespace("MAPI")
Set olFldr = olNS.GetDefaultFolder(olFolderInbox).Folders("temp")
Cnt = 0
For Each olMail In olFldr.Items
On Error GoTo errorhandler
Cnt = Cnt + 1
abody = Split(olFldr.Items(Cnt).Body, vbNewLine)
For j = 0 To UBound(abody)
Sheet1.Cells(65000, 1).End(xlUp).Offset(1, 0).Value = abody(j)
Next
ReDim Preserve arrData(1 To 1, 1 To Cnt)
arrData(1, Cnt) = olMail.ReceivedTime
Cells(1, 1).Value = arrData(1, Cnt)
Cells(1, 1).NumberFormat = "dd/mm/yyyy hh:mm:ss AM/PM"
olFldr.Items(Cnt).Move olNS.GetDefaultFolder(6).Folders("Processed")
Next
Set olApp = Nothing
Set olNS = Nothing
Set olFldr = Nothing
errorhandler:
Application.CutCopyMode = False
Set olApp = Nothing
Set olNS = Nothing
Set olFldr = Nothing
Exit Sub
End Sub

---

更新代码：

Sub test()
Dim olApp As Object
Dim olNS As Object
Dim olFldr As Object
Dim olMail As Object
Dim i As Integer
Dim j As Long
Dim abody() As String
Dim Cnt As Long
Dim arrData() As Variant
Dim ws As Worksheet
Set olApp = CreateObject("Outlook.Application")
Set olNS = olApp.GetNamespace("MAPI")
Set olFldr = olNS.GetDefaultFolder(olFolderInbox).Folders("temp")
Set ws = ThisWorkbook.Sheets("Sheet1")
EmailCount = olFldr.Items.Count
MsgBox "Number of emails in the folder: " & EmailCount, , "email count"
Cnt = 1
For Each olMail In olFldr.Items
abody = Split(olMail.Body, vbNewLine)
For j = 0 To UBound(abody)
ws.Cells(65000, 1).End(xlUp).Offset(1, 0).Value = abody(j)
Next
ReDim Preserve arrData(1 To 1, 1 To Cnt)
arrData(1, Cnt) = olMail.ReceivedTime
ws.Cells(1, 1).Value = arrData(1, Cnt)
ws.Cells(1, 1).NumberFormat = "dd/mm/yyyy hh:mm:ss AM/PM"
olMail.Move olNS.GetDefaultFolder(6).Folders("Processed")
Cnt = Cnt + 1

Next
Set olApp = Nothing
Set olNS = Nothing
Set olFldr = Nothing
End Sub

Answer 1

你能试着把循环部分改成这样吗
还要为目标工作表添加声明和变量赋值。

Dim ws as Worksheet
Set ws = ThisWorkbook.Sheets("Sheet1") 'added this to avoid the subscript out of range
Cnt = 1
For Each olMail In olFldr.Items
On Error GoTo errorhandler
    abody = Split(olMail.Body, vbNewLine) 'changed this to olMail.Body since you are already iterating each mail
    For j = 0 To UBound(abody)
    ws.Cells(65000, 1).End(xlUp).Offset(1, 0).Value = abody(j) 'use the declared ws here
    Next
    ReDim Preserve arrData(1 To 1, 1 To Cnt)
    arrData(1, Cnt) = olMail.ReceivedTime
    ws.Cells(1, 1).Value = arrData(1, Cnt) 'use ws here as well if same Sheet1
    ws.Cells(1, 1).NumberFormat = "dd/mm/yyyy hh:mm:ss AM/PM"
    olMail.Move olNS.GetDefaultFolder(6).Folders("Processed") 'change to olMail as well
    Cnt = Cnt + 1
Next

这是未经测试的，所以我将测试留给您。：）