导入电子邮件信息到Excel

我试图从Outlook中的共享收件箱中的子文件夹导入电子邮件信息到Excel电子表格。到目前为止，我遇到了很多问题，即访问收件箱的子文件夹，但找到了解决方案。我现在遇到的问题是代码在收件箱中存在相同数量的电子邮件后停止。例如，我想从“归档”文件夹中的信息（收件箱中的子文件夹），但如果在我的收件箱20级的电子邮件，然后当计数到达20码停，只给我的信息在“存档”文件夹中20个项目导入电子邮件信息到Excel

见下从Outlook执行我的代码。我已经标记了代码停止的地方。它给我的错误“aOutput（LCNT，1）=标超出范围”时我胡佛光标移到“aOutput”。如果我跳过代码为“SetxlApp ......”线，它会给我所有的电子邮件到这一点，数据填充（20个电子邮件即我的收件箱相同数量的项目）的Excel工作表，但我需要它来保持循环浏览文件夹的其余部分（可能是成千上万的项目）。任何人都可以对此有所了解吗？还有其他建议吗？谢谢你的帮助。

Sub EmailStats() 

Dim olMail As Outlook.MailItem 
Dim aOutput() As Variant 
Dim lCnt As Long 
Dim xlApp As Excel.Application 
Dim xlSh As Excel.Worksheet 
Dim flInbox As Folder 
Dim olFolder As Outlook.MAPIFolder 

Dim myNamespace As Outlook.NameSpace 
Dim myRecipient As Outlook.Recipient 
Set myNamespace = Application.GetNamespace("MAPI") 
Set myRecipient = myNamespace.CreateRecipient("Team Inbox") 

Set flInbox = Application.GetNamespace("MAPI").GetSharedDefaultFolder(myRecipient, olFolderInbox) 

Set olFolder = flInbox.Folders("ARCHIVE") 
ReDim aOutput(1 To flInbox.Items.Count, 1 To 4) 

For Each olMail In olFolder.Items 
    If TypeName(olMail) = "MailItem" Then 
    On Error GoTo ErrorSkip 
     lCnt = lCnt + 1 
     aOutput(lCnt, 1) = olMail.SenderEmailAddress '**Code stops here** 
     aOutput(lCnt, 2) = olMail.ReceivedTime 
     aOutput(lCnt, 3) = olMail.ConversationTopic 
     aOutput(lCnt, 4) = olMail.Subject 
    End If 
ErrorSkip: 
Next olMail 

Set xlApp = New Excel.Application 
Set xlSh = xlApp.Workbooks.Add.Sheets(1) 

xlSh.Range("A1").Resize(UBound(aOutput, 1), UBound(aOutput, 2)).Value = aOutput 
xlApp.Visible = True 

End Sub

来源

2015-08-14 Colin Torpey

摆脱On Error GoTo ErrorSkip线看（如果有的话）返回什么错误。

来源

2015-08-14 16:35:11

当我删除'On Error GoTo ErrorSkip'行时，我得到相同的错误。我只输入这个来尝试修复最初的问题，但它什么都不做。 –

你永远不会初始化lCnt变量。在进入循环之前将其初始化为0。 –

感谢您的评论。对不起，如果我不太熟悉Outlook VBA，但我试图在循环开始之前输入lCnt = 0，但我仍然有同样的问题。 –

我发现很多试错后的答案。对于任何有兴趣的人，请参阅下面的代码，将共享收件箱中的电子邮件详细信息导入到Excel表格中。只需将“共享收件箱”文本更改为您自己的共享收件箱的名称即可。我的收件箱结构为“共享收件箱”>“收件箱”>“存档”。您还需要在Set objFolder行上更改这些以指定您需要的文件夹。

我仍然遇到一个问题，即代码在遇到非邮件项目（未送达通知或会议邀请）时停止运行，但正在处理解决方案。

Sub EmailStatsV3() 

Dim olMail As Outlook.MailItem 
Dim aOutput() As Variant 
Dim lCnt As Long 
Dim xlApp As Excel.Application 
Dim xlSh As Excel.Worksheet 
Dim flInbox As Folder 

'Gets the mailbox and shared folder inbox 
Dim myNamespace As Outlook.NameSpace 
Dim myRecipient As Outlook.Recipient 
Set myNamespace = Application.GetNamespace("MAPI") 
Set myRecipient = myNamespace.CreateRecipient("Shared Inbox") 

Set objOutlook = CreateObject("Outlook.Application") 
Set objNamespace = objOutlook.GetNamespace("MAPI") 
Set objInbox = objNamespace.GetSharedDefaultFolder(myRecipient, olFolderInbox) 

'Uses the Parent of the Inbox to specify the mailbox 
strFolderName = objInbox.Parent 

'Specifies the folder (inbox or other) to pull the info from 
Set objMailbox = objNamespace.Folders(strFolderName) 
Set objFolder = objMailbox.Folders("Inbox").Folders("ARCHIVE") 
Set colItems = objFolder.Items 

'Specify which email items to extract 
ReDim aOutput(1 To objFolder.Items.Count, 1 To 5) 
For Each olMail In objFolder.Items 
If TypeName(olMail) = "MailItem" Then 

     lCnt = lCnt + 1 
     aOutput(lCnt, 1) = olMail.SenderEmailAddress 'maybe stats on domain 
     aOutput(lCnt, 2) = olMail.ReceivedTime 'stats on when received 
     aOutput(lCnt, 3) = olMail.ConversationTopic 'group based on subject w/o regard to prefix 
     aOutput(lCnt, 4) = olMail.Subject 'to split out prefix 
     aOutput(lCnt, 5) = olMail.Categories 'to split out category 
End If 

Next 

'Creates a blank workbook in excel then inputs the info from Outlook 
Set xlApp = New Excel.Application 
Set xlSh = xlApp.Workbooks.Add.Sheets(1) 

xlSh.Range("A1").Resize(UBound(aOutput, 1), UBound(aOutput, 2)).Value = aOutput 
xlApp.Visible = True 


End Sub

来源

2015-09-21 15:06:27

导入电子邮件信息到Excel

回答

相关问题