将 Outlook 电子邮件从子文件夹（共享收件箱）提取到 Excel

Answer 1

尝试这个：

Sub GetEmails()

    'Add Tools->References->"Microsoft Outlook nn.n Object Library"
    'nn.n varies as per our Outlook Installation
    Const NUM_DAYS As Long = 18
    Dim OutlookApp As Outlook.Application
    Dim i As Long
    Dim Folder As Outlook.MAPIFolder
    Dim itm As Object
    Dim iRow As Long, oRow As Long, ws As Worksheet, sBody As String
    Dim mailboxName As String, inboxName As String, subfolderName As String
    
    mailboxName = "mailboxNameHere"
    inboxName = "Inbox"
    subfolderName = "Contracts" 'for example

    Set OutlookApp = New Outlook.Application
    On Error Resume Next
    Set Folder = OutlookApp.Session.Folders(mailboxName) _
                     .Folders(inboxName).Folders(subfolderName)
    On Error GoTo 0
    
    If Folder Is Nothing Then
        MsgBox "Source folder not found!", vbExclamation, _
                "Problem with export"
        Exit Sub
    End If
    
    Set ws = ThisWorkbook.Worksheets(1)
    'add headers
    ws.Range("A1").Resize(1, 4).Value = Array("Sender", "Subject", "Date", "Body")
    iRow = 2
    Folder.Items.Sort "Received"
    For Each itm In Folder.Items
        If TypeOf itm Is Outlook.MailItem Then       'check it's a mail item (not appointment, etc)
            If Date - itm.ReceivedTime <= NUM_DAYS Then
                sBody = Left(Trim(itm.Body), 150)    'first 150 chars of Body
                sBody = Replace(sBody, vbCrLf, "; ") 'remove newlines
                sBody = Replace(sBody, vbLf, "; ")
                ws.Cells(iRow, 1).Resize(1, 4).Value = _
                    Array(itm.SenderName, itm.Subject, itm.ReceivedTime, sBody)
                iRow = iRow + 1
            End If
        End If
    Next itm

    MsgBox "Outlook Mails Extracted to Excel"

End Sub