如何也从共享邮箱子文件夹导入电子邮件，并在Excel中标记文件夹名称 [英] How to import email from a shared mailbox subfolder too, and mark the foldername in Excel

问题描述

我有以下宏，用于从Outlook导入电子邮件.宏仅从收件箱"文件夹

I have the following macro, where I'm importing emails from outlook. The macro only imports the emails from the Inbox folder,

我希望宏通过收件箱文件夹的subfolders(因此，没有已发送的邮件等，但仅收件箱文件夹的sub folders).

I would like the macro to go through al the subfolders of Inbox Folder (so no Sent items, etc, but the sub folders of the Inbox folder only).

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"列中，我想写一封用于接收电子邮件的文件夹的名称...

and in the E column, I would like if the name of the folder it took the email from would-be written...

所以其他列已经可以了，但是以这种方式，我想如果它是从Inbox文件夹中复制的，那么在E column中它将写入Inbox，但是如果它是从Subfolder1复制的则它将写入SUbfolder1等...

So it is already okay with other columns, however in this way, I would like if it is copied from Inbox folder then in E column it will write Inbox, but if it is copied from Subfolder1 then it will write SUbfolder1 and etc...

我应该如何处理?

推荐答案

尝试以下操作

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("[e-mail]") ' 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

这篇关于如何也从共享邮箱子文件夹导入电子邮件，并在Excel中标记文件夹名称的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！