我在这个问题上摸不着头脑,我对 VBA(和一般编程)相当陌生,并且希望改进此代码。关于如何使用改进或简化的代码覆盖主文件夹、子文件夹、子子文件夹中的所有邮件项目的任何想法?
1级以下:
下降2级:
下3级:
到目前为止,我的代码是:
Sub GetEmailsDetailsMINE()
Dim outlook_app As Outlook.Application
Dim namespace As Outlook.namespace
Set outlook_app = New Outlook.Application
Set namespace = outlook_app.GetNamespace("MAPI")
Dim account_folder As Outlook.MAPIFolder
Dim main_folder As Outlook.MAPIFolder
Dim sub_folder1 As Outlook.MAPIFolder
Dim sub_folder2 As Outlook.MAPIFolder
On Error Resume Next
Dim obj_mail As Outlook.MailItem
Dim rowNumber As Integer
rowNumber = 2
For Each account_folder In namespace.Folders
' main account, eg someone@company.com
For Each main_folder In account_folder.Folders
' 1 level down, find emails here
For Each obj_item In main_folder.Items
If obj_item.Class = olMail Then
Set obj_mail = obj_item
Cells(rowNumber, 1) = obj_mail.SenderEmailAddress
Cells(rowNumber, 2) = obj_mail.To
Cells(rowNumber, 3) = obj_mail.Subject
Cells(rowNumber, 4) = obj_mail.ReceivedTime
Cells(rowNumber, 5) = obj_mail.EntryID
Cells(rowNumber, 6) = main_folder.Name
rowNumber = rowNumber + 1
End If
Next obj_item
For Each sub_folder1 In main_folder.Folders
' two levels down, find emails here
For Each obj_item In sub_folder1.Items
If obj_item.Class = olMail Then
Set obj_mail = obj_item
Cells(rowNumber, 1) = obj_mail.SenderEmailAddress
Cells(rowNumber, 2) = obj_mail.To
Cells(rowNumber, 3) = obj_mail.Subject
Cells(rowNumber, 4) = obj_mail.ReceivedTime
Cells(rowNumber, 5) = obj_mail.EntryID
Cells(rowNumber, 6) = sub_folder1.Name
rowNumber = rowNumber + 1
End If
Next obj_item
' three levels down
For Each sub_folder2 In sub_folder1.Folders
For Each obj_item In sub_folder2.Items
If obj_item.Class = olMail Then
Set obj_mail = obj_item
Cells(rowNumber, 1) = obj_mail.SenderEmailAddress
Cells(rowNumber, 2) = obj_mail.To
Cells(rowNumber, 3) = obj_mail.Subject
Cells(rowNumber, 4) = obj_mail.ReceivedTime
Cells(rowNumber, 5) = obj_mail.EntryID
Cells(rowNumber, 6) = sub_folder1.Name & " || " & sub_folder2.Name
rowNumber = rowNumber + 1
End If
Next obj_item
Next sub_folder2
Next sub_folder1
Next main_folder
Next account_folder
On Error GoTo 0
End Sub
这很好用,我可以得到我想要的所有项目,但不知何故我发现它重复了。关于如何改进我的代码的任何想法?
最佳答案
编辑 - 测试/修复
非递归方法:
Sub GetEmailsDetails()
Dim outlook_app As Outlook.Application
Dim namespace As Outlook.namespace
Dim colFolders As New Collection
Dim fldr As Outlook.MAPIFolder, subfldr As Outlook.MAPIFolder
Dim obj_mail As Outlook.MailItem, obj_item
Dim rowNumber As Long
Set outlook_app = New Outlook.Application
Set namespace = outlook_app.GetNamespace("MAPI")
For Each fldr In namespace.Folders
For Each subfldr In fldr.Folders
colFolders.Add subfldr
Next subfldr
Next
rowNumber = 2
Do While colFolders.Count > 0
Set fldr = colFolders(1) 'get next folder to process
colFolders.Remove 1 'remove that item
Application.StatusBar = fldr.FolderPath
'process the folder
For Each obj_item In fldr.Items
If obj_item.Class = olMail Then
Set obj_mail = obj_item
Application.StatusBar = rowNumber & " - " & fldr.FolderPath
On Error Resume Next
Cells(rowNumber, 1).Resize(1, 6).Value = _
Array(obj_mail.SenderEmailAddress, obj_mail.To, _
obj_mail.Subject, obj_mail.ReceivedTime, _
obj_mail.EntryID, fldr.FolderPath)
On Error GoTo 0
rowNumber = rowNumber + 1
End If
Next obj_item
'store all subfolders for processing
For Each subfldr In fldr.Folders
colFolders.Add subfldr, before:=1
Next
Loop
Application.StatusBar = False
End Sub
关于excel - 循环浏览 Outlook 邮件项目,我们在Stack Overflow上找到一个类似的问题: https://stackoverflow.com/questions/60370414/