Question

我要编写一个VBA代码，根据某些条件从Outlook中检索电子邮件。我遇到的问题是我必须在我的代码中表示某个文件夹（在下面的示例中，表示的文件夹是＆＃34; PRE Costumer＆＃34;。我想从我的＆＃39;收件箱中删除所有电子邮件＆＃ 39;或者更好地来自所有outlook文件夹。问题是我的收件箱包含许多子文件夹（因为rules0。我的问题是我可能不知道所有的子文件夹名称（因为许多用户将使用宏甚至有人可以在个人文件夹中收到电子邮件你能否告诉我有没有办法解决这个问题？
如果这个问题含糊不清（我是新人），请告诉我。

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

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

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

上面会处理Inbox中的所有子文件夹这是你正在尝试的吗？

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

Excel VBA代码从outlook中检索电子邮件

2 个答案: