从 Outlook 检索电子邮件的 Excel VBA 代码

Excel VBA Code to retrieve e-mails from outlook

提问by Artur Rutkowski

I am to write a VBA code that would retrive emails from Outlook based on certain conditions. The problem I have is that I have to denote a certain folder in my code (in the example below the folder denoted is "PRE Costumer". I would like to retrive all emails from my 'inbox' or in better case from all outlook folders. The problem is that my inbox consists of many subfolders (because of rules0. My problem is that I may not know all the subfolders names (as many useres are going to use the macro and even someone can have the e mails in Personal Folders).
Could you please advise is there a way to overcome this problem?
Please let me know if this question is vague (as I am newcomer)

我将编写一个 VBA 代码，根据某些条件从 Outlook 检索电子邮件。我遇到的问题是我必须在我的代码中表示某个文件夹（在下面的示例中，表示的文件夹是“PRE Costumer”。我想从我的“收件箱”或更好的情况下从所有 Outlook 文件夹中检索所有电子邮件. 问题是我的收件箱包含许多子文件夹（因为规则 0。我的问题是我可能不知道所有子文件夹的名称（因为许多用户将使用宏，甚至有人可以在个人文件夹中拥有电子邮件） .
请问有没有办法解决这个问题？
如果这个问题含糊不清，请告诉我（因为我是新手）

Please find the line that I have probelm with marked with a comment.

请找到我有问题并标有评论的那一行。

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

回答by L42

Just loop through all the folders in Inbox.
Something like this would work.

只需遍历Inbox.
像这样的事情会起作用。

Edit1:This will avoid blank rows.

Edit1：这将避免空行。

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

Above takes care of all subfolders in Inbox.
Is this what you're trying?

以上处理Inbox.
这是你正在尝试的吗？

回答by PatricK

To fix your error (olFolderInboxis a Outlook only constant, so you need to define it in vba that is not Outlook):

要修复您的错误（olFolderInbox是仅 Outlook 的常量，因此您需要在不是 Outlook 的 vba 中定义它）：

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

Also to prevent missing Reference when run from another computer, I would:

另外为了防止从另一台计算机运行时丢失参考，我会：

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")
'...

You might also want to disable ScreenUpdating, then enable it in Excel if you expect a long list.

您可能还想禁用ScreenUpdating，然后在 Excel 中启用它（如果您希望列表很长）。

---

---

UPDATE (Solution for all folders from a Root Folder)更新（根文件夹中所有文件夹的解决方案）

I used something slightly different for comparing the dates.

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

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