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

我建議避免在一行代碼中使用多個點。 因此，您將能夠輕松排除故障並優化整體性能。

---

對於跟蹤項目更改，我建議創建一個檢查器包裝器，請參閱為檢查器實現包裝器並在每個檢查器中跟蹤項目級事件以獲取更多信息。