如何使用Excel VBA从Outlook检索电子邮件？

Question

我想根据特定条件从Outlook中检索电子邮件。

在我的代码中，我指定了一个特定的文件夹。下面的示例中，文件夹名称是"PRE Customer"。
我希望从收件箱或更好地说，来自所有Outlook文件夹中检索电子邮件。

我的收件箱包含许多子文件夹。由于有很多用户，并且有人可能会将电子邮件放在"个人文件夹"中，因此我可能不知道所有子文件夹的名称。

问题行已经用注释标记出来了。

Sub GetFromInbox()

Dim olApp As Outlook.Application
Dim olNs As Namespace
Dim Fldr As MAPIFolder
Dim olMail As Variant
Dim i As Integer

Set olApp = New Outlook.Application
Set olNs = olApp.GetNamespace("MAPI")

'Below is the line I have problem with
Set Fldr = olNs.GetDefaultFolder(olFolderInbox).Folders("PRE Customer") 

i = 1
x = Date

For Each olMail In Fldr.Items
    If InStr(olMail.Subject, "transactions") > 0 _
      And InStr(olMail.ReceivedTime, x) > 0 Then  
        ActiveSheet.Cells(i, 1).Value = olMail.Subject
        ActiveSheet.Cells(i, 2).Value = olMail.ReceivedTime
        ActiveSheet.Cells(i, 3).Value = olMail.SenderName
        i = i + 1
    End If
Next olMail

Set Fldr = Nothing
Set olNs = Nothing
Set olApp = Nothing
End Sub

- Artur Rutkowski

---

因为Outlook的安全系统，从Outlook写入Excel比从Excel读取Outlook要容易得多。这两个答案可能会给您一些启示。如何使用VBA或宏将Outlook邮件消息复制到Excel中 如何将Outlook邮件数据导入Excel - Tony Dallimore

Answer 1

只需循环遍历Inbox文件夹中的所有文件夹即可。
像这样做就可以了。

编辑1：这将避免空白行。

Sub test()
    Dim olApp As Outlook.Application, olNs As Outlook.Namespace
    Dim olFolder As Outlook.MAPIFolder, olMail As Outlook.MailItem
    Dim eFolder As Outlook.Folder '~~> additional declaration
    Dim i As Long
    Dim x As Date, ws As Worksheet '~~> declare WS variable instead
    Dim lrow As Long '~~> additional declaration

    Set ws = Activesheet '~~> or you can be more explicit using the next line
    'Set ws = Thisworkbook.Sheets("YourTargetSheet")
    Set olApp = New Outlook.Application
    Set olNs = olApp.GetNamespace("MAPI")
    x = Date

    For Each eFolder In olNs.GetDefaultFolder(olFolderInbox).Folders
        'Debug.Print eFolder.Name
        Set olFolder = olNs.GetDefaultFolder(olFolderInbox).Folders(eFolder.Name)
        For i = olFolder.Items.Count To 1 Step -1
            If TypeOf olFolder.Items(i) Is MailItem Then
                Set olMail = olFolder.Items(i)
                If InStr(olMail.Subject, "transactions") > 0 _
                And InStr(olMail.ReceivedTime, x) > 0 Then
                    With ws
                       lrow = .Range("A" & .Rows.Count).End(xlup).Row
                       .Range("A" & lrow).Offset(1,0).value = olMail.Subject
                       .Range("A" & lrow).Offset(1,1).Value = olMail.ReceivedTime
                       .Range("A" & lrow).Offset(1,2).Value = olMail.SenderName
                    End With
                End If
            End If
        Next i
        Set olFolder = Nothing
    Next eFolder
End Sub

上面的代码可以处理“收件箱”中的所有子文件夹。您是不是想要这个？

- L42

---

非常感谢，现在我必须尝试先检查仅来自今天的电子邮件，然后再加上其他条件，因为现在有很多电子邮件，所以它运行得很慢。 - Artur Rutkowski

嗨，输出了正确的数据，但是如果没有符合条件的电子邮件，则在Excel中会出现空白位置，这导致检索到的电子邮件之间有空行。也许您有什么想法可以解决这个问题吗？ - Artur Rutkowski

修复空行：将 j = j + 1 上移 2 行。 - PatricK

@ArturRutkowski 请看我的编辑。直接访问最后一个空行可能是最好的方法。 - L42

感谢您提供的解决方案。我有几个要求：

1. 是否有一种方法可以在消息中识别图像（内联）？
2. 寻找一种选项，可以使用Excel VBA编辑消息并将其保存回Outlook。 感谢您的建议。

- Sriram

Answer 2

为了解决您的错误（olFolderInbox是仅限于Outlook的常量，因此您需要在非Outlook的vba中定义它）：

Const olFolderInbox = 6
'...
Set Fldr = olNs.GetDefaultFolder(olFolderInbox).Folders("PRE Customer")

为了防止在从另一台计算机运行时出现缺少引用的情况，我会执行以下操作：

Dim olApp As Object
Dim olNs As Object
Dim Fldr As Object
Dim olMail As Object
Dim i As Long
Set olApp = CreateObject("Outlook.Application")
'...

您可能还希望禁用 ScreenUpdating，如果您期望有一个长列表，则在 Excel 中启用它。

---

更新（解决方案适用于根文件夹中的所有文件夹）

我用了一些稍微不同的东西来比较日期。

Option Explicit

Private lRow As Long, x As Date, oWS As Worksheet

Sub GetFromInbox()
    Const olFolderInbox = 6
    Dim olApp As Object, olNs As Object
    Dim oRootFldr As Object ' Root folder to start
    Dim lCalcMode As Long

    Set olApp = CreateObject("Outlook.Application")
    Set olNs = olApp.GetNamespace("MAPI")
    Set oRootFldr = olNs.GetDefaultFolder(olFolderInbox).Folders("PRE Customer")
    Set oWS = ActiveSheet

    x = Date
    lRow = 1
    lCalcMode = Application.Calculation
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    GetFromFolder oRootFldr
    Application.ScreenUpdating = True
    Application.Calculation = lCalcMode

    Set oWS = Nothing
    Set oRootFldr = Nothing
    Set olNs = Nothing
    Set olApp = Nothing
End Sub

Private Sub GetFromFolder(oFldr As Object)
    Dim oItem As Object, oSubFldr As Object

    ' Process all mail items in this folder
    For Each oItem In oFldr.Items
        If TypeName(oItem) = "MailItem" Then
            With oItem
                If InStr(1, .Subject, "transactions", vbTextCompare) > 0 And DateDiff("d", .ReceivedTime, x) = 0 Then
                    oWS.Cells(lRow, 1).Value = .Subject
                    oWS.Cells(lRow, 2).Value = .ReceivedTime
                    oWS.Cells(lRow, 3).Value = .SenderName
                    lRow = lRow + 1
                End If
            End With
        End If
    Next

    ' Recurse all Subfolders
    For Each oSubFldr In oFldr.Folders
        GetFromFolder oSubFldr
    Next
End Sub

- PatricK

---

非常感谢，我今天也会尝试这个。干杯！ - Artur Rutkowski

你可以在收件箱中递归到所有文件夹，但是你需要在Excel中知道文件夹路径吗？或者如果您想稍后引用它，需要知道EntryID吗？ - PatricK

我只需要电子邮件的属性（主题、时间、发件人），无论来自哪个Outlook文件夹，只需添加条件，如主题中包含“word”并且是今天的邮件（我想这样做是为了首先检查今天的日期，以便立即不检查如果日期不是今天）。 - Artur Rutkowski

@ArturRutkowski 请尝试使用更新后的代码来递归模式，给定一个根文件夹。 - PatricK

当olFldr中的olMail不是MailItem时，这可能会生成错误。但是，由于将被多个用户使用，因此对于LateBinding给予+1的评价是正确的，这将消除版本差异。 - L42

在假设它是MailItem之前，应该检查项目类型的True。@ArturRutkowski应该将Sub GetFromFolder中第42行的类型检查结合起来，如果遇到问题，请告诉我们。 - PatricK