excel - 如何从 Outlook 中的文件夹、子文件夹、子文件夹中获取主题?
问题描述
我已经构建以从 Outlook 收件箱中获取主题。它将从收件箱和收件箱文件夹中提取主题。如果文件夹下没有硬编码的子文件夹很少,我该如何提取?
从收件箱、FolderA、FolderB、FolderC 等读取主题的预期结果。在 FolderA 下可能有几个子文件夹。
当前 Excel VBA 代码:
Option Explicit
Sub GetMailInfo()
Dim results As Variant
' get contacts
results = ExportEmails(True)
' paste onto worksheet
Range(Cells(1, 1), Cells(UBound(results), UBound(results, 2))).Value = results
' done
MsgBox "Completed"
End Sub
Function ExportEmails(Optional headerRow As Boolean = False) As Variant
Dim objOutlook As Object ' Outlook.Application
Dim objNamespace As Object ' Outlook.Namespace
Dim strFolderName As Object
Dim objMailbox As Object
Dim objFolder As Object
Dim mailFolderItems As Object ' Outlook.items
Dim folderItem As ResultItem
Dim msg As Object ' Outlook.MailItem
Dim tempString() As String
Dim i As Long
Dim numRows As Long
Dim startRow As Long
Dim jAttach As Long ' counter for attachments
Dim debugMsg As Integer
Dim resultsList As New Collection
' select output results worksheet and clear previous results
Sheets("Outlook Results").Select
Sheets("Outlook Results").Cells.ClearContents
Range("A5").Select
Set objOutlook = CreateObject("Outlook.Application")
'MsgBox objOutlook, vbOKOnly 'for debugging
Set objNamespace = objOutlook.GetNamespace("MAPI")
'MsgBox objNamespace, vbOKOnly 'for debugging
'Set objInbox = objNamespace.GetDefaultFolder(olFolderInbox)
'MsgBox objInbox, vbOKOnly 'for debugging
Set strFolderName = objNamespace.PickFolder
GetFolderMails strFolderName, resultsList
' if calling procedure wants header row
If headerRow Then
startRow = 1
Else
startRow = 0
End If
numRows = resultsList.Count
' resize array
ReDim tempString(1 To (numRows + startRow), 1 To 100)
' loop through folder items
For i = 1 To numRows
Set folderItem = resultsList.Item(i)
With folderItem
tempString(i + startRow, 1) = .CreationTime
tempString(i + startRow, 2) = .SenderName
tempString(i + startRow, 3) = .ReceivedByName
tempString(i + startRow, 4) = .ReceivedTime
tempString(i + startRow, 5) = .ToName
tempString(i + startRow, 6) = .Subject
If .Attachments.Count > 0 Then
For jAttach = 1 To .Attachments.Count
tempString(i + startRow, 39 + jAttach) = .Attachments.Item(jAttach)
Next jAttach
End If
End With
Next i
' first row of array should be header values
If headerRow Then
tempString(1, 1) = "CreationTime"
tempString(1, 2) = "SenderName"
tempString(1, 3) = "ReceivedByName"
tempString(1, 4) = "ReceivedTime"
tempString(1, 5) = "To"
tempString(1, 6) = "Subject"
End If
ExportEmails = tempString
' apply pane freeze and filtering
Range("A6").Select
ActiveWindow.FreezePanes = True
Rows("1:1").Select
'Selection.AutoFilter
End Function
Function IsMail(itm As Object) As Boolean
IsMail = (TypeName(itm) = "MailItem")
End Function
Sub GetFolderMails(MailFolder As Object, resultsList As Collection)
Dim itm As Object
Dim newResult As ResultItem
Dim jAttach As Long
Dim subFolder As Object
For Each itm In MailFolder.Items
If IsMail(itm) Then
Set newResult = New ResultItem
With itm
newResult.CreationTime = .CreationTime
newResult.SenderName = .SenderName
newResult.ReceivedByName = .ReceivedByName
newResult.ReceivedTime = .ReceivedTime
newResult.ToName = .To
newResult.Subject = .Subject
If .Attachments.Count > 0 Then
For jAttach = 1 To .Attachments.Count
newResult.Attachments.Add .Attachments.Item(jAttach).DisplayName
Next jAttach
End If
End With
resultsList.Add newResult
End If
Next itm
For Each subFolder In MailFolder.Folders
GetFolderMails subFolder, resultsList
Next subFolder
End Sub
解决方案
谢谢@TimWilliams
我已经修改了我的代码以在最后一部分进行捕获。
If (MailFolder.Items.Count > 0) Then
For Each subFolder In MailFolder.Folders
GetFolderMails subFolder, resultsList
Next subFolder
End If
现在工作正常。
推荐阅读
- python - 在 NumPy 中转置存储在一维数组中的矩阵的最快方法?
- angular - 为什么这个变量来自未定义的本地存储?角 10
- javascript - 如何只显示一个隐藏的字母(js)
- javascript - 这个 Python 函数可以转换为 Javascript 吗?
- git - 如何通过 SSH 连接 Git GUI 客户端(GitKraken)
- css - 本地和在线的不同行为
- vue.js - Vue.js:无法使用通过 Axios 发出的获取请求来更新数据存储变量?
- kotlin - Kotlin:尝试,捕捉,并且只有在最后出现错误时
- python - 使用 streamlit 绘图时,xticklabels 不会出现在图中
- postgresql - 删除打印语句和注释会破坏我的代码