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

我有下面的宏，我从outlook导入电子邮件。宏仅从收件箱文件夹导入电子邮件

我希望宏遍历Inbox文件夹的所有

子文件夹

（因此没有已发送的项目等，但只查看Inbox文件夹的

子文件夹

）

在E栏中，我想知道它从潜在用户那里接收电子邮件的文件夹的名称是否被写入

所以其他栏目已经可以了，但是这样，我想如果它是从收件箱文件夹复制的，那么在

E栏目

中它将写入收件箱，但是如果它是从

子文件夹1

复制的，那么它将写入

子文件夹1

等等

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

试试下面的方法

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

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