从多个子文件夹中提取 Outlook 数据

问题描述 投票:0回答:2

我有以下代码,可以从 Outlook 文件夹中提取数据并选择日期范围或限制日期。

我正在尝试从多个 Outlook 文件夹中提取数据。

下面的代码允许我一次从一个文件夹中选择。

如何选择更多文件夹或循环此操作以从其他文件夹添加更多数据?

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
excel vba outlook
2个回答
1
投票

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

Find
类的
FindNext
/
Restrict
Items
方法。您可以在我为技术博客撰写的文章中阅读有关这些方法的更多信息:

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

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 文章中了解更多相关信息。


0
投票

编辑

在循环之前初始化计数器 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
© www.soinside.com 2019 - 2024. All rights reserved.