如何也从共享邮箱子文件夹导入电子邮件，并在 Excel 中标记文件夹名称

Question

我有以下宏，我正在从 Outlook 导入电子邮件。该宏仅从收件箱文件夹中导入电子邮件，

我希望宏通过收件箱文件夹的subfolders（所以没有已发送的项目等，但仅收件箱文件夹的sub folders）。

Sub GetFromOutlook()

Dim OutlookApp As Outlook.Application
Dim OutlookNamespace As Namespace
Dim Folder As MAPIFolder
Dim OutlookMail As Variant
Dim i As Integer
Dim objMail As Outlook.MailItem
Dim objFlaggedMail As Outlook.MailItem

Application.ScreenUpdating = False

Set OutlookApp = New Outlook.Application
Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")

Set olShareName = OutlookNamespace.CreateRecipient("shared_mailbox_name")
Set Folder = OutlookNamespace.GetSharedDefaultFolder(olShareName, olFolderInbox)

Range("A:I").ClearContents

Range("A3").Value = "Subject"
Range("B3").Value = "Date"
Range("C3").Value = "Sender"
Range("D3").Value = "Category"
Range("E3").Value = "Mailbox"
i = 4

On Error Resume Next
For Each OutlookMail In Folder.Items

    Range("A" & i).Value = OutlookMail.Subject
    Range("B" & i).Value = OutlookMail.ReceivedTime
    Range("C" & i).Value = OutlookMail.SenderName
    Range("D" & i).Value = OutlookMail.Categories
    Range("E" & i).Value = OutlookMail.Folder

在 E 列中，我想写下它接收电子邮件的文件夹的名称......

所以其他列已经可以了，但是通过这种方式，我想如果它是从收件箱文件夹复制的，那么在E column它会写收件箱，但是如果它是从Subfolder1复制的，那么它会写SUbfolder1等等……

我应该如何处理这个问题？

Answer 1

试试下面的

Option Explicit
Private Sub Example()
    Dim olApp As outlook.Application
    Set olApp = New outlook.Application

    Dim olNs As outlook.Namespace
    Set olNs = olApp.GetNamespace("MAPI")

    Dim olRecip As outlook.Recipient
    Set olRecip = olNs.CreateRecipient("0m3r@EmailAddress.com") ' Update email

    Dim Inbox As outlook.MAPIFolder
    Set Inbox = olNs.GetSharedDefaultFolder(olRecip, olFolderInbox)

    Dim Sht As Worksheet
    Set Sht = ThisWorkbook.Sheets("Sheet1")

    With Sht
        .Range("A3").Value = "Subject"
        .Range("B3").Value = "Date"
        .Range("C3").Value = "Sender"
        .Range("D3").Value = "Category"
        .Range("E3").Value = "Mailbox"
    End With

'   // Process Current Folder
    LoopFolders Inbox, Sht

End Sub

Private Sub LoopFolders( _
    ByVal CurrentFolder As outlook.MAPIFolder, _
    ByVal Sht As Worksheet _
)

    Dim Items As outlook.Items
    Set Items = CurrentFolder.Items

    Dim i As Long
    Dim last_row As Long
    Dim Item As Object ' Outlook.MailItem

    With Sht
        last_row = Sht.Range("A" & .Rows.Count).End(xlUp).Row + 1

        For i = Items.Count To 1 Step -1 ' run loop
            Set Item = Items(i)
            DoEvents
            If TypeOf Item Is outlook.MailItem Then

                 Debug.Print Item
                .Range("A" & last_row).Value = Item.Subject
                .Range("B" & last_row).Value = Item.ReceivedTime
                .Range("C" & last_row).Value = Item.SenderName
                .Range("D" & last_row).Value = Item.Categories
                .Range("E" & last_row).Value = CurrentFolder.Name

            End If

            last_row = last_row + 1

        Next

    '   // Recurse through subfolders
        Dim folder As outlook.MAPIFolder
        If CurrentFolder.Folders.Count > 0 Then
            For Each folder In CurrentFolder.Folders
                LoopFolders folder, Sht
            Next
        End If

    End With

'   // Cleanup
    Set folder = Nothing
    Set Item = Nothing
    Set Items = Nothing
End Sub