我有一個根據主題提取電子郵件的代碼。但我也想根據日期提取郵件。所以它應該是日期和主題的交集，只有當兩個條件都滿足時，我才應該得到提取的資料。僅使用主題條件，代碼就可以正常作業，但是當我添加日期條件時，它無法正確獲取。例如：我想提取主題行為“卷資料”的昨天的電子郵件。我在代碼中做錯了什么？有人可以幫忙嗎？
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
uj5u.com熱心網友回復：
請測驗下一個改編的代碼：
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 僅當您選擇過濾過去的日期時才需要。
沒有測驗過，當然，我沒有必要的資料，但這應該是這個想法。我只測驗了過濾部分，它按需要作業。
編輯：
現在，有一些變體可以構建必要的開始/結束日期，以滿足不同的情況：
- 要處理從 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 & "'"
如果有什么不夠清楚，請不要猶豫，要求澄清。但是在您嘗試了解它的作業原理并推斷出錯誤可能出現的位置以及原因之后......
我們在這里的使命不是提供免費的代碼示例，而是讓盡可能多的用戶學習...
轉載請註明出處，本文鏈接：https://www.uj5u.com/qita/357735.html
上一篇：從最后一行到usedRange，VBA結束之間選擇范圍的正確/更短的代碼？
下一篇：使用標準查找最接近的3個值