从多个电子邮件地址或子文件夹中提取 Outlook 数据

Question

我有以下代码，可以从 Outlook 文件夹中提取数据并选择日期范围或限制日期。但是，我试图从“多个 Outlook 文件夹”中提取数据，但下面的代码只允许我一次从“1”文件夹中选择。
我怎样才能选择更多文件夹或循环它以从其他文件夹添加更多数据？请帮忙！我到处搜索都找不到解决方案。

Sub getDataFromOutlookChoiceFolder()

Dim OutlookApp As Outlook.Application
Dim OutlookNameSpace As Namespace
Dim Folder As MAPIFolder
Dim OutlookMail As Variant
Dim i As Long

Set OutlookApp = New Outlook.Application
Set OutlookNameSpace = OutlookApp.GetNamespace("MAPI")
Set Folder = OutlookNameSpace.PickFolder

If Folder.Items.Count = 0 Then
MsgBox "No emails. Existing procedure!"
Exit Sub
End If

i = 1

Dim rngName As Name
Sheet1.Cells.Clear
For Each rngName In ActiveWorkbook.Names
rngName.Delete
Next

Range("A1").Name = "receivedtime"
Range("A1") = "Received Time"
Range("B1").Name = "From"
Range("B1") = "From"
Range("C1").Name = "To"
Range("C1") = "To"
Range("D1").Name = "Subject"
Range("D1") = "Subject"
Range("E1").Name = "Body"
Range("E1") = "Body"
Range("F1").Name = "Conversation_ID"
Range("F1") = "Conversation ID"
Range("G1").Name = "email_Receipt_Date"
Range("G2").Name = "email_end_date"
Range("email_Receipt_Date").Value = InputBox("Enter Receipt Date like DD-Mon-YYYY")
Range("email_end_date").Value = InputBox("Enter Receipt Date like DD-Mon-YYYY")

    
For Each OutlookMail In Folder.Items
If OutlookMail.ReceivedTime >= Range("email_Receipt_Date").Value And OutlookMail.ReceivedTime <= Range("email_end_date").Value Then


Range("receivedtime").Offset(i, 0).Value = OutlookMail.ReceivedTime
Range("receivedtime").Offset(i, 0).Columns.AutoFit
Range("receivedtime").Offset(i, 0).VerticalAlignment = xlTop
Range("from").Offset(i, 0).Value = OutlookMail.SenderName
Range("from").Offset(i, 0).Columns.AutoFit
Range("from").Offset(i, 0).VerticalAlignment = xlTop
Range("to").Offset(i, 0).Value = OutlookMail.To
Range("to").Offset(i, 0).Columns.AutoFit
Range("to").Offset(i, 0).VerticalAlignment = xlTop
Range("subject").Offset(i, 0).Value = OutlookMail.Subject
Range("subject").Offset(i, 0).Columns.AutoFit
Range("subject").Offset(i, 0).VerticalAlignment = xlTop
Range("body").Offset(i, 0).Value = OutlookMail.Body
Range("body").Offset(i, 0).Columns.AutoFit
Range("body").Offset(i, 0).VerticalAlignment = xlTop
Range("Conversation_ID").Offset(i, 0).Value = OutlookMail.ConversationID
Range("Conversation_ID").Offset(i, 0).Columns.AutoFit
Range("Conversation_ID").Offset(i, 0).VerticalAlignment = xlTop


i = i + 1
End If
Next OutlookMail

Set Folder = Nothing
Set OutlookNameSpace = Nothing
Set OutlookApp = Nothing


MsgBox ("Completed")
End Sub

Answer 1

首先，迭代循环中的所有项目以获取特定日期的项目是不正确的。相反，您需要使用

Find

类的

FindNext

/

Restrict

或

Items

方法。您可以在我为技术博客撰写的文章中阅读有关这些方法的更多信息：

• 如何：使用 Find 和 FindNext 方法从文件夹中检索 Outlook 邮件项目 (C#、VB.NET)
• 如何：使用限制方法从文件夹中检索 Outlook 邮件项目

如果需要处理所有子文件夹，则必须递归地迭代子文件夹。例如：

Private Sub processFolder(ByVal oParent As Outlook.MAPIFolder)

   Dim oFolder As Outlook.MAPIFolder
   Dim oMail As Outlook.MailItem

   For Each oMail In oParent.Items
     'Get your data here ...
   Next

   If (oParent.Folders.Count > 0) Then
     For Each oFolder In oParent.Folders
        processFolder oFolder
     Next
   End If
End Sub

但是满足您所有需求的更好的解决方案是

AdvancedSearch

类的

Application

方法。在 Outlook 中使用

AdvancedSearch

方法的主要好处是：

• 搜索是在另一个线程中执行的。您不需要手动运行另一个线程，因为

  AdvancedSearch

  方法会在后台自动运行它。
• 可以在任何位置（即超出特定文件夹的范围）搜索任何项目类型：邮件、约会、日历、笔记等。

  Restrict

  和

  Find

  /

  FindNext

  方法可应用于特定的

  Items

  集合（请参阅 Outlook 中

  Items

  类的

  Folder

  属性）。
• 完全支持 DASL 查询（自定义属性也可用于搜索）。为了提高搜索性能，如果商店启用了即时搜索，则可以使用即时搜索关键字（请参阅 Store 类的 IsInstantSearchEnabled 属性）。
• 您可以使用

  Stop

  类的

  Search

  方法随时停止搜索过程。

在以编程方式在 Outlook 中进行高级搜索：C#、VB.NET 文章中了解更多相关信息。

Answer 2

编辑

在循环之前初始化计数器 i。我不小心把它留在原来的地方了。

原创

这比您想象的要容易。我已将您的代码放在

Do ... Loop

中，以允许用户继续选择文件夹，直到用户单击“取消”。退出循环。

我删除了你的大部分汇报线只是为了保持干净。一旦您确信这有效，请将它们添加回来。

Option Explicit  ' Should be the first line in every module

Sub getDataFromOutlookChoiceFolder()
    Dim OutlookApp As Outlook.Application
    Dim OutlookNameSpace As Namespace
    Dim Folder As MAPIFolder
    Dim OutlookMail As Variant
    Dim i As Long
    Dim rngName As Name
    Dim wkshSheet1 As Worksheet  ' Dim this variable; Option Explicit will force that
    
    Set OutlookApp = New Outlook.Application
    Set OutlookNameSpace = OutlookApp.GetNamespace("MAPI")
    
    Set wkshSheet1 = ActiveWorkbook.Worksheets("Sheet1") ' Define for your needs
    wkshSheet1.Cells.Clear
    For Each rngName In ActiveWorkbook.Names
        rngName.Delete
    Next

    ' Shortened from original to save space; replace your original lines here
    Range("A1").Name = "receivedtime"
    Range("A1") = "Received Time"
    Range("B1").Name = "From"
    Range("B1") = "From"

    i = 1  ' EDIT: initialize i before loop

    ' Loop allowing user to choose folders
    Do
        Set Folder = OutlookNameSpace.PickFolder
        
        If Folder Is Nothing Then ' User clicked Cancel, bail out
            Exit Do
        End If
        
        ' Empty folder selected; (commented to allow loop to continue)
        If Folder.Items.Count = 0 Then
'            MsgBox "No emails. Exiting procedure!"
'            Exit Sub
        End If
        
'        i = 1  ' EDIT: MOVE THIS BEFORE LOOP
        
        For Each OutlookMail In Folder.Items
            If OutlookMail.ReceivedTime >= Range("email_Receipt_Date").Value And _
                    OutlookMail.ReceivedTime <= Range("email_end_date").Value Then
                
                Range("receivedtime").Offset(i, 0).Value = OutlookMail.ReceivedTime
                Range("receivedtime").Offset(i, 0).Columns.AutoFit
                Range("receivedtime").Offset(i, 0).VerticalAlignment = xlTop
                Range("from").Offset(i, 0).Value = OutlookMail.SenderName
                Range("from").Offset(i, 0).Columns.AutoFit
                Range("from").Offset(i, 0).VerticalAlignment = xlTop
                
                i = i + 1
            End If
        Next OutlookMail
        
    Loop  ' Choose next folder
    
    Set Folder = Nothing
    Set OutlookNameSpace = Nothing
    Set OutlookApp = Nothing
    
    MsgBox ("Completed")
End Sub