Excel VBA - 循环遍历 3 个特定的 Outlook 文件夹

Question

我有一些代码可以将 Outlook 邮件导出到 Excel 中，它可以完美运行，但我目前必须为 3 个不同文件夹（不是子文件夹）更改此代码。 有没有办法可以指定它们并且代码在所有 3.x 上运行。

这是我目前拥有的代码

    Dim mailFolderItemsB As Object
    objOwner.Resolve
    If objOwner.Resolved Then
        Set mailFolderItemsB = objNamespace.GetSharedDefaultFolder(objOwner, olFolderInbox) _
                              .Parent.folders("Folder A") 'change this to B and then C once code has run.
    '.Parent.folders("Folder B")
    '.Parent.folders("Folder C")
    Set mailFolderItems = mailFolderItemsB.Items

如果忽略和道歉，这也可能是第二个问题。 是否可以在打开电子邮件然后更改时跟踪更改，因为用户经常打开邮件更改主题标题然后关闭。 想到一个 old.value 事件。

编辑 - 我的宏

Sub GetEmail()
 On Error GoTo ErrorHandler
Application.ScreenUpdating = False
Application.EnableEvents = False

Dim results() As String

  ' call function
  results = ExportEmails(True)

  ' paste onto worksheet
  Range(Cells(1, 1), Cells(UBound(results), UBound(results, 2))).Value = results
 Exit Sub
ErrorHandler:
    MsgBox Err.Description & " " & Err.Number, vbOKOnly + vbCritical, "Database Error"
End Sub

这是功能

Function ExportEmails(Optional headerRow As Boolean = False) As String()
    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 Object
    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
    
    ' select output results worksheet and clear previous results
    Sheets("Outlook Results").Select
    Sheets("Outlook Results").Cells.ClearContents
    Range("A1").Select
    Set objOutlook = CreateObject("Outlook.Application")
    Set objNamespace = objOutlook.GetNamespace("MAPI")
    
    Dim OutApp As outlook.Application
    Dim objOwner As outlook.Recipient
    
    Set OutApp = New outlook.Application
    Set objOwner = objNamespace.CreateRecipient("EmailAddess@CompanyName.com")
    
    Dim mailFolderItemsB As Object, f, mailFolderItems
    
    objOwner.Resolve
    If objOwner.Resolved Then
    
        For Each f In Array("Folder A", "Folder B", "Folder C")
            Set mailFolderItemsB = objNamespace.GetSharedDefaultFolder(objOwner, olFolderInbox) _
                     .Parent.folders(f) 'change this to B and then C once code has run.
            Set mailFolderItems = mailFolderItemsB.Items
    
      ' if calling procedure wants header row
      If headerRow Then
        startRow = 1
      Else
        startRow = 0
      End If
    
      numRows = mailFolderItems.Count
    
      ReDim tempString(1 To (numRows + startRow), 1 To 100)
    
      ' loop through folder items
      For i = 1 To numRows
    
        Set folderItem = mailFolderItems.Item(i)
    
        If IsMail(folderItem) Then
          Set msg = folderItem
    
    End If
        With msg
          tempString(i + startRow, 1) = .subject
          tempString(i + startRow, 2) = Replace(.body, vbLf, "")
          tempString(i + startRow, 3) = .Categories
          tempString(i + startRow, 4) = .cc
          tempString(i + startRow, 5) = .entryid
          tempString(i + startRow, 6) = .ConversationID ' .ConversationTopic 'conversationID  or conversationindex.propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x007D001E") '.ConversationIndex
          tempString(i + startRow, 7) = .LastModificationTime 'sent
          tempString(i + startRow, 8) = .ReceivedByName
          tempString(i + startRow, 9) = .ReceivedOnBehalfOfName
          tempString(i + startRow, 10) = .ReceivedTime
          tempString(i + startRow, 11) = .SenderEmailAddress
          tempString(i + startRow, 12) = .SenderName
          tempString(i + startRow, 13) = .SentOn
          tempString(i + startRow, 14) = .To
          tempString(i + startRow, 15) = .propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x1035001E")
    
        End With
        ' adding file attachment names where they exist
    If msg.Attachments.Count > 0 Then
        For jAttach = 1 To msg.Attachments.Count
           
    'get pdf and xlsx files
    Dim sAttachment As String
    sAttachment = msg.Attachments.Item(jAttach).DisplayName
        If Right(sAttachment, 4) = ".pdf" Or Right(sAttachment, 5) = ".xlsx" Then
    
    tempString(i + startRow, 21 + jAttach) = msg.Attachments.Item(jAttach).DisplayName
    
    End If
            
            Next jAttach
    
        End If
    
      Next i
    
      ' first row of array should be header values
      If headerRow Then
    
       tempString(1, 1) = "Subject"
          tempString(1, 2) = "Body"
          tempString(1, 3) = "Categories"
          tempString(1, 4) = "CC"
          tempString(1, 5) = "CreationTime"
          tempString(1, 6) = "ConversationID"
          tempString(1, 7) = "LastModificationTime"
          tempString(1, 8) = "ReceivedByName"
          tempString(1, 9) = "ReceivedOnBehalfOfName"
          tempString(1, 10) = "ReceivedTime"
          tempString(1, 11) = "SenderEmailAddress"
          tempString(1, 12) = "SenderName"
          tempString(1, 13) = "SentOn"
          tempString(1, 14) = "To"
          tempString(1, 15) = "ID"
          tempString(1, 16) = "Number of Attachments"
        tempString(1, 17) = "Attachment 1 Filename"
        tempString(1, 18) = "Attachment 2 Filename"
        tempString(1, 19) = "Attachment 3 Filename"
        tempString(1, 20) = "Attachment 4 Filename"
        tempString(1, 21) = "Attachment 5 Filename"
        tempString(1, 22) = "Attachment 6 Filename"
        tempString(1, 23) = "Attachment 7 Filename"
        tempString(1, 24) = "Attachment 8 Filename"
        tempString(1, 25) = "Attachment 9 Filename"
        tempString(1, 26) = "Attachment 10 Filename"
        tempString(1, 27) = "Attachment 11 Filename"
        tempString(1, 28) = "Attachment 12 Filename"
        tempString(1, 29) = "Attachment 13 Filename"
        tempString(1, 30) = "Attachment 14 Filename"
        tempString(1, 31) = "Attachment 15 Filename"
        tempString(1, 32) = "Attachment 16 Filename"
        tempString(1, 33) = "Attachment 17 Filename"
        tempString(1, 34) = "Attachment 18 Filename"
        tempString(1, 35) = "Attachment 19 Filename"
        tempString(1, 36) = "Attachment 20 Filename"
    End If
         Next f
    End If
    
      ExportEmails = tempString
    
        Range("A2").Select
        ActiveWindow.FreezePanes = True
        Rows("1:1").Select
    
    End Function

Answer 1

像这样的东西：

Dim mailFolderItemsB As Object, f, mailFolderItems 

'...
objOwner.Resolve
If objOwner.Resolved Then

    For Each f in Array("Folder A","Folder B","Folder C")
        Set mailFolderItemsB = objNamespace.GetSharedDefaultFolder(objOwner, olFolderInbox) _
                 .Parent.folders(f) 'change this to B and then C once code has run.
        Set mailFolderItems = mailFolderItemsB.Items

        'something happens here...

    Next f
End If

编辑：你有一个巨大的功能，它做得太多了。 试试这个重新设计的例子

Sub ProcessEmails()

    Dim OutApp As Outlook.Application
    Dim objOwner As Outlook.Recipient
    Dim objOutlook As Object ' Outlook.Application
    Dim objNamespace As Object ' Outlook.Namespace
    Dim strFolderName As Object
    Dim objMailbox As Object
    Dim objFolder As Object, data
    Dim wsResults As Worksheet
    Dim mailFolderInbox As Object, f, dataRow As Long
    
    ' select output results worksheet and clear previous results
    Set wsResults = ThisWorkbook.Sheets("Outlook Results")
    wsResults.Cells.ClearContents
    
    Set objOutlook = CreateObject("Outlook.Application")
    Set objNamespace = objOutlook.GetNamespace("MAPI")
    
    Set OutApp = New Outlook.Application
    Set objOwner = objNamespace.CreateRecipient("EmailAddess@CompanyName.com")
    
    objOwner.Resolve
    If objOwner.Resolved Then
    
        Set mailFolderInbox = objNamespace.GetSharedDefaultFolder(objOwner, olFolderInbox)
        dataRow = 1 'start putting data on this row
        For Each f In Array("Folder A", "Folder B", "Folder C")
            data = MailData(mailFolderInbox.Parent.Folders(f), True)
            If Not IsEmpty(data) Then
                wsResults.Cells(dataRow, 1).Resize(UBound(data, 1), UBound(data, 2)).Value = data
                dataRow = dataRow + UBound(data, 1) 'next data dump position
            End If
        Next f 'next folder
    End If
End Sub

'Given an Outlook folder object, return an array of data about the contained
'  mail items.  Optionally add a header row to the array.
Function MailData(objFolder As Object, Optional headerRow As Boolean = False)
    
    Dim colMail As New Collection, itm As Object, data(), dataRow As Long, i As Long
    Dim arrHdr, dn, attNum As Long
    
    'only want mail items, so collect them in a Collection
    For Each itm In objFolder.Items
        If TypeName(itm) = "MailItem" Then colMail.Add itm
    Next itm
    If colMail.Count = 0 Then
        MailData = Empty 'nothing to report
        Exit Function
    End If
    
    dataRow = IIf(headerRow, 2, 1) 'data "row" for mail#1
    ReDim data(1 To colMail.Count + (dataRow - 1), 1 To 36)
    
    If headerRow Then 'adding a header "row"?
        arrHdr = Array("Subject", "Body", "Categories", "CC", "EntryId", _
                   "ConversationID", "LastModificationTime", "ReceivedByName", _
                   "ReceivedOnBehalfOfName", "ReceivedTime", "SenderEmailAddress", _
                   "SenderName", "SentOn", "To", "ID", "Number of Attachments")
        For i = 0 To UBound(arrHdr)
            data(1, i + 1) = arrHdr(i)
        Next i
        For i = 1 To 20
            data(1, 16 + i) = "Attachment " & i & " Filename"
        Next i
    End If
    
    For Each itm In colMail 'process all the mailitems found
        With itm
            data(dataRow, 1) = .Subject
            data(dataRow, 2) = Replace(.body, vbLf, "")
            data(dataRow, 3) = .Categories
            data(dataRow, 4) = .cc
            data(dataRow, 5) = .entryid
            data(dataRow, 6) = .ConversationID ' .ConversationTopic 'conversationID  or conversationindex.propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x007D001E") '.ConversationIndex
            data(dataRow, 7) = .LastModificationTime 'sent
            data(dataRow, 8) = .ReceivedByName
            data(dataRow, 9) = .ReceivedOnBehalfOfName
            data(dataRow, 10) = .ReceivedTime
            data(dataRow, 11) = .SenderEmailAddress
            data(dataRow, 12) = .SenderName
            data(dataRow, 13) = .SentOn
            data(dataRow, 14) = .to
            data(dataRow, 15) = .propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x1035001E")
            data(dataRow, 16) = .attachments.Count
            attNum = 0
            For i = 1 To .attachments.Count
                dn = .attachments(i).DisplayName
                If dn Like "*.xlsx" Or dn Like "*.pdf" Then
                    attNum = attNum + 1
                    If attNum > 20 Then Exit For 'too many attachments...
                    data(dataRow, 16 + attNum) = dn
                End If
            Next i
            dataRow = dataRow + 1
        End With
    Next itm
    MailData = data
End Function

Answer 2

首先，您需要为用户检索共享的默认文件夹 - 这是一个常见的操作，应该连续重复 3 次：

Dim mailFolderItemsB As Object
objOwner.Resolve
If objOwner.Resolved Then
    Set mailSharedInboxFolder = objNamespace.GetSharedDefaultFolder(objOwner, olFolderInbox) 

然后，您可以获取三个文件夹的父文件夹：

Set mailSharedParentInboxFolder = mailSharedInboxFolder.Parent

最后你可以得到三个文件夹：

Set mailFolderItemsA = mailSharedParentInboxFolder.folders("Folder A")
Set mailFolderItemsB = mailSharedParentInboxFolder.folders("Folder B")
Set mailFolderItemsC = mailSharedParentInboxFolder.folders("Folder C")
'
Set mailFolderItems = mailFolderItemsB.Items

我建议避免在一行代码中使用多个点。 因此，您将能够轻松排除故障并优化整体性能。

---

对于跟踪项目更改，我建议创建一个检查器包装器，请参阅为检查器实现包装器并在每个检查器中跟踪项目级事件以获取更多信息。