根據主題和日期中的單詞使用 Excel VBA 從 Outlook 電子郵件中提取詳細信息

Question

我想根據電子郵件主題中的特定詞使用 Excel VBA 提取 Outlook 電子郵件數據。

電子郵件的主題會發生變化，但所有電子郵件的部分主題都是相同的。

例如，我的電子郵件主題是“Prod - 用戶 Steve Johnson (1234567) 的每日工作警報”

主題的靜態部分是：“Prod - Work Daily Alert for user”。

主題的動態部分是：“Steve Johnson (1234567)”。

我想根據靜態部分從電子郵件中提取數據。

我嘗試使用 StackOverflow 中的以下 VBA 代碼並進行一些修改。 它不滿足“If”條件，因此不會從電子郵件中提取任何內容。

如果我刪除

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