根据主题和日期中的特定单词，使用Excel VBA提取Outlook电子邮件的详细信息

Question

我想根据电子邮件主题中的特定单词使用Excel VBA提取Outlook电子邮件数据。

电子邮件的主题已更改，但所有电子邮件中的主题的某些部分均保持不变。

例如我的电子邮件主题是“产品-用户Steve Johnson（1234567）的工作每日警报”

主题的静态部分是：“产品-用户的每日工作警报”。

主题的动态部分是：“史蒂夫·约翰逊（1234567）”。

我想根据静态部分从电子邮件中提取数据。

我试图通过进行一些修改来使用StackOverflow的以下VBA代码。它不满足“如果”条件，因此不会从电子邮件中提取任何内容。

如果我删除

If InStr(olMail.Subject, "Prod - RECON Daily Alert for user") > 0 _
  And InStr(olMail.ReceivedTime, x) > 0 Then

然后从收件箱中的所有电子邮件中提取数据。

Sub ExtractEmailContent()

    Dim olApp As Outlook.Application, olNs As Outlook.Namespace
    Dim olFolder As Outlook.MAPIFolder, olMail As Outlook.MailItem
    Dim eFolder As Outlook.Folder 
    Dim i As Long
    Dim x As Date, ws As Worksheet 
    Dim lRow As Long 

    Set ws = ActiveSheet

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

    For Each eFolder In olNs.GetDefaultFolder(olFolderInbox).Folders

        Set olFolder = olNs.GetDefaultFolder(olFolderInbox)

        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, "Prod - Work Daily Alert for user") > 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
                        .Range("A" & lRow).Offset(1, 3).Value = olMail.CC
                        .Range("A" & lRow).Offset(1, 4).Value = olMail.Body
                    End With
                End If
            End If
        Next i

        'forward_Email ()
        Set olFolder = Nothing
    Next eFolder
End Sub

Answer 1

And InStr(olMail.ReceivedTime, x) > 0是奇数。

这可能是检查日期的更好方法。

Option Explicit

Sub ExtractEmailContent_Inefficiently()

    Dim olApp As Outlook.Application
    Dim olNs As Outlook.NameSpace
    Dim olFolder As Outlook.folder
    Dim olMail As Outlook.MailItem

    Dim i As Long

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

    Set olFolder = olNs.GetDefaultFolder(olFolderInbox)

    Debug.Print "olFolder.Items.Count: " & olFolder.Items.Count

    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, "Prod - Work Daily Alert for user") > 0 Then

                If olMail.ReceivedTime >= Date Then
                    Debug.Print i & " - olMail.ReceivedTime: " & olMail.ReceivedTime
                Else
                    Debug.Print i & " - processing every item is inefficient."
                End If

            End If

        End If

    Next i

End Sub

您可以减少使用限制处理的项目数。

Sub ExtractEmailContent_Restrict()

    Dim olApp As Outlook.Application
    Dim olNs As Outlook.NameSpace
    Dim olFolder As Outlook.folder
    Dim olMail As Outlook.MailItem

    Dim i As Long

    Dim strFilter As String
    Dim olResults As Outlook.Items

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

    Set olFolder = olNs.GetDefaultFolder(olFolderInbox)

    ' Apply formatting to Date
    strFilter = "[ReceivedTime]>'" & Format(Date, "DDDDD HH:NN") & "'"
    Debug.Print "strFilter .....: " & strFilter

    Set olResults = olFolder.Items.Restrict(strFilter)
    Debug.Print "olResults.Count: " & olResults.Count

    For i = olResults.Count To 1 Step -1

        If TypeOf olResults(i) Is MailItem Then

            Set olMail = olResults(i)

            If InStr(olMail.Subject, "Prod - Work Daily Alert for user") > 0 Then
                Debug.Print i & " - olMail.ReceivedTime: " & olMail.ReceivedTime
            End If

        End If

    Next i

End Sub