如何使用 VBA 根据日期和主题提取电子邮件数据？

Question

我有一个代码可以根据主题提取电子邮件。但我也想根据日期提取邮件。所以它应该是 Date & subject 的交集，只有当两个条件都满足时我才应该获取提取的数据。就主题条件而言，代码工作正常，但是当我添加日期条件时，它没有正确获取。例如：我想提取昨天的主题行为“卷数据”的电子邮件。我在代码中做错了什么？有人可以帮忙吗？

Option Explicit

Sub FinalMacro()
Application.DisplayAlerts = False
Dim wkb As Workbook
Set wkb = ThisWorkbook

Sheets("Sheet1").Cells.Clear

' point to the desired email
Const strMail As String = "emailaddress"

Dim oApp As Outlook.Application
Dim oMapi As Outlook.MAPIFolder
Dim oItem As Object

On Error Resume Next
Set oApp = GetObject(, "OUTLOOK.APPLICATION")
If (oApp Is Nothing) Then Set oApp = CreateObject("OUTLOOK.APPLICATION")

On Error GoTo 0

Set oMapi = oApp.GetNamespace("MAPI").Folders(strMail).Folders("inbox") 'Folders("Others")

For Each oItem In oMapi.Items
    If oItem.Subject = "Volume data" & oItem.ReceivedTime = Date Then
       'If oItem.ReceivedTime = Date Then
     Dim HTMLdoc As MSHTML.HTMLDocument
     Dim tables As MSHTML.IHTMLElementCollection
     Dim table As MSHTML.HTMLTable


     Set HTMLdoc = New MSHTML.HTMLDocument
     With HTMLdoc
     .Body.innerHTML = oItem.HTMLBody
     Set tables = .getElementsByTagName("table")
     End With


     Dim t As Long, r As Long, c As Long
     Dim eRow As Long

        For t = 0 To tables.Length - 1
          eRow = Sheets(1).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
              For r = 0 To (tables(t).Rows.Length - 1)
                 For c = 0 To (tables(t).Rows(r).Cells.Length - 1)
                      Range("A" & eRow).Offset(r, c).Value = tables(t).Rows(r).Cells(c).innerText
                 Next c
              Next r
          eRow = Sheets(1).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
        Next t
        
        Cells(eRow, 1) = "Date & Time of Receipt:" & " " & oItem.ReceivedTime
        Cells(eRow, 1).Interior.Color = vbRed
        Cells(eRow, 1).Font.Color = vbWhite
        Cells(eRow, 1).Columns.AutoFit

     Set oApp = Nothing
     Set oMapi = Nothing
     Set HTMLdoc = Nothing
     Set tables = Nothing

       'End If
    End If
Next oItem
wkb.Save 
Application.DisplayAlerts = True
End Sub

Answer 1

请测试下一个适配代码：

Sub FinalMacro()
 Dim wkb As Workbook:  Set wkb = ThisWorkbook

 'Sheets("Sheet1").cells.Clear 'uncomment if you need to start from the first row...

 ' point to the desired email
 Const strMail As String = "emailaddress"

 Dim oApp As Outlook.Application, oMapi As Outlook.MAPIFolder, oItem  As Outlook.MailItem
 Dim destCell As Range, i As Long

 With ActiveSheet
     Set destCell = .cells(rows.count, "A").End(xlUp) 'last cell where from to extract the last date
 End With

 On Error Resume Next
  Set oApp = GetObject(, "OUTLOOK.APPLICATION")
  If (oApp Is Nothing) Then Set oApp = CreateObject("OUTLOOK.APPLICATION")
 On Error GoTo 0

 Dim HTMLdoc As MSHTML.HTMLDocument, tables As MSHTML.IHTMLElementCollection
 Dim table As MSHTML.HTMLTable
 Dim t As Long, r As Long, c As Long, eRow As Long
 
 Set oMapi = oApp.GetNamespace("MAPI").Folders(strMail).Folders("inbox") 'Folders("Others")
 'the necessary elements to extract only the necessary mails:_______________________________________________
  Dim startDate As String, endDate As String, flt As String
  startDate = CStr(Date) & " " & "00:00"      'Date can be replaced with any string Date
  endDate = CStr(Date + 1) & " " & "00:00"    'the same, it should be the previous Date +1
  flt = "[Subject] = 'Volume data' and [ReceivedTime] >= '" & startDate & "' and  [ReceivedTime] < '" & endDate & "'"
  Dim myItems As Outlook.items
  Set myItems = oMapi.items.Restrict(flt)    '____________________________________________________________
                                                               
  Application.DisplayAlerts = False
 
  For Each oItem In myItems
        Set HTMLdoc = New MSHTML.HTMLDocument
        With HTMLdoc
            .body.innerHTML = oItem.HtmlBody
            Set tables = .getElementsByTagName("table")
        End With
        For t = 0 To tables.Length - 1
                eRow = ActiveSheet.cells(rows.count, 1).End(xlUp).row + 1
                For r = 0 To (tables(t).rows.Length - 1)
                    For c = 0 To (tables(t).rows(r).cells.Length - 1)
                        Range("A" & eRow).Offset(r, c).value = tables(t).rows(r).cells(c).innerText
                    Next c
                Next r
                eRow = ActiveSheet.cells(rows.count, 1).End(xlUp).Offset(1, 0).row
           Next t
         
            cells(eRow, 1) = "Date & Time of Receipt:" & " " & oItem.ReceivedTime
            cells(eRow, 1).Interior.color = vbRed
            cells(eRow, 1).Font.color = vbWhite
            cells(eRow, 1).Columns.AutoFit
Next oItem
wkb.Save
Application.DisplayAlerts = True
End Sub

endDate 仅当您选择过滤过去的日期时才需要。

没测试过，当然我没有必要的数据，不过应该是这个思路。我只测试了过滤部分，它按需工作。

已编辑:

现在，有一些变体可以构建必要的 start/end 日期，以满足不同的情况：

要处理从 2021 年 10 月 12 日到月底收到的邮件，请使用以下定义：

   startDate = CStr(DateSerial(2021, 10, 12)) & " " & "00:00"   
   endDate = CStr(DateSerial(2021, 11, 1)) & " " & "00:00"

要处理今天 12 点之后收到的邮件，请使用以下定义：

  startDate = CStr(Date) & " " & "12:00"
  endDate = CStr(Date + 1) & " " & "00:00"

在这种情况下，过滤器 (flt) 字符串定义可能会遗漏 endDate 部分，这在这种情况下并不重要...

由于您的代码将 oItem.ReceivedTime 记录为 cells(eRow, 1) = "Date & Time of Receipt:" & " " & oItem.ReceivedTime，因此可以提取最后记录的时间并处理在该特定时间之后收到的所有邮件：

'1. comment the next existing code line:
   'Sheets("Sheet1").Cells.Clear
`2. declare the next new (necessary) variables:
  Dim destCell As Range, lastOne As String, arrD, arrS
  Set DestCell = ActiveSheet.cells(rows.count, "A").End(xlUp)
  arrD = Split(destCell.value, " "): arrS = Split(arrD(6), ":")
  lastOne = arrD(5) & " " & arrS(0) & ":" & arrS(1)
`3. Change the filter string:
  flt = "[Subject] = 'Volume data' and [ReceivedTime] > '" & lastOne & "'"

如果有什么地方不够清楚，请不要犹豫，要求澄清。但是在您尝试了解它的工作原理并推断出可能出现错误的位置以及原因之后...

我们的使命不是提供免费的代码示例，而是让尽可能多的用户学习...

如何使用 VBA 根据日期和主题提取电子邮件数据？

How to extract email data based on Date & subject using VBA?

excel

outlook

vba