Question

我正在处理以下代码，我正试图让它从Outlook中的两个不同文件夹中添加电子邮件，但我显然遗漏了一些东西，因为它无法正常工作。当我运行代码时它会从“PolicyCenter”文件夹中提取所有电子邮件而不是“Apex”文件夹。我不确定我做错了什么，非常感谢任何帮助或建议！

Option Explicit
Sub VBA_Export_Outlook_Emails_To_Excel()
Dim Folder As Outlook.MAPIFolder
Dim sFolders As Outlook.MAPIFolder
Dim iRow As Integer, oRow As Integer
Dim MailBoxName As String, Pst_Folder_Name  As String

MailBoxName = "Mailbox, PL-SYSTEM-OUTAGES"

Pst_Folder_Name = "Apex"
Pst_Folder_Name = "PolicyCenter"

    For Each Folder In Outlook.Session.Folders(MailBoxName).Folders
    If VBA.UCase(Folder.Name) = VBA.UCase(Pst_Folder_Name) Then GoTo Label_Folder_Found
    For Each sFolders In Folder.Folders
        If VBA.UCase(sFolders.Name) = VBA.UCase(Pst_Folder_Name) Then
            Set Folder = sFolders
            GoTo Label_Folder_Found
        End If
    Next sFolders
Next Folder

Label_Folder_Found:
 If Folder.Name = "" Then
    MsgBox "Invalid Data in Input"
    GoTo End_Lbl1:
End If

ThisWorkbook.Sheets(1).Activate
Folder.Items.Sort "Received"

ThisWorkbook.Sheets(1).Cells(1, 1) = "Sender"
ThisWorkbook.Sheets(1).Cells(1, 2) = "Subject"
ThisWorkbook.Sheets(1).Cells(1, 3) = "Date"
ThisWorkbook.Sheets(1).Cells(1, 4) = "Size"
'ThisWorkbook.Sheets(1).Cells(1, 5) = "EmailID"
'ThisWorkbook.Sheets(1).Cells(1, 6) = "Body"

oRow = 1
For iRow = 1 To Folder.Items.Count

    If VBA.DateValue(VBA.Now) - VBA.DateValue(Folder.Items.Item(iRow).ReceivedTime) <= 60 Then
       oRow = oRow + 1
       ThisWorkbook.Sheets(1).Cells(oRow, 1).Select
       ThisWorkbook.Sheets(1).Cells(oRow, 1) = Folder.Items.Item(iRow).SenderName
       ThisWorkbook.Sheets(1).Cells(oRow, 2) = Folder.Items.Item(iRow).Subject
       ThisWorkbook.Sheets(1).Cells(oRow, 3) = Folder.Items.Item(iRow).ReceivedTime
       ThisWorkbook.Sheets(1).Cells(oRow, 4) = Folder.Items.Item(iRow).Size
       'ThisWorkbook.Sheets(1).Cells(oRow, 5) = Folder.Items.Item(iRow).SenderEmailAddress
       'ThisWorkbook.Sheets(1).Cells(oRow, 6) = Folder.Items.Item(iRow).Body
    End If
Next iRow
MsgBox "Outlook Mails Extracted to Excel"
Set Folder = Nothing
Set sFolders = Nothing

End_Lbl1:
End Sub

谢谢！ -D

Answer 1

将“新文件夹名称”放在下两个语句之间吗？

Next sFolders
Pst_Folder_Name = "PolicyCenter"
Next Folder

这是否表明我的意思......

将Outlook文件夹中的电子邮件导出到Excel。编码问题

1 个答案: