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

Question

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

电子邮件的主题发生了变化，但所有电子邮件的部分主题都相同。

例如我的电子邮件主题是“Prod - 用户 Steve Johnson (1234567) 的每日工作提醒”

主题的静态部分是：“Prod - Work Daily Alert for user”。

主题的动态部分是：“Steve Johnson (1234567)”。

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

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

如果我删除

If InStr(olMail.Subject, "Prod - Work 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

您可以减少使用 Restrict 处理的项目数量。

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