我有以下代码,可以从 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
首先,迭代循环中的所有项目以获取特定日期的项目是不正确的。相反,您需要使用
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
属性)。Stop
类的 Search
方法随时停止搜索过程。在以编程方式在 Outlook 中进行高级搜索:C#、VB.NET 文章中了解更多相关信息。
在循环之前初始化计数器 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