如何跳過正文中不包含任何資料表的電子郵件？[復制]

社區正在審查是否從昨天開始重新提出這個問題。

目前，我正在使用 VBA 代碼從回顧 45 天的子收件箱中提取新員工電子郵件。電子郵件包含我提取的資料表，因此我可以復制這些列。我想避免打開所有 45 天的電子郵件來復制資料。有時我們收到的電子郵件沒有資料表，只有一句“未找到記錄”，這意味著我們沒有雇用或解雇任何人。

問題：當我們收到沒有資料表的電子郵件時，電子郵件的日期順序被拋出。

如果在 6/2、6/3 和 6/4 我收到一封包含資料表的電子郵件，而在 6/5 我收到一封沒有資料表的電子郵件，但在 6/6（今天）我收到一封電子郵件確實有資料，審計不會跳過 6/5 的接收時間，而是添加 6/6 的資料。當我進行審計時，它顯示 6/2、6/3、6/4 和 6/5（帶有來自 6/6 的資料表）而不是 6/2、6/3、6/4 和 6 /6（跳過 6/5）。

Sub Extractor()

Range("A2:H30000").Clear
Dim OLApp As Outlook.Application
Set OLApp = New Outlook.Application

Dim ONS As Outlook.Namespace

Set ONS = OLApp.GetNamespace("MAPI")
Dim MYFOLDER As Outlook.Folder
 
Set MYFOLDER = ONS.Folders("[email protected]").Folders("Inbox")
Set MYFOLDER = MYFOLDER.Folders("NewHires")

Dim OLMAIL As Outlook.MailItem
Set OLMAIL = OLApp.CreateItem(olMailItem)

Set myItems = MYFOLDER.Items
myItems.Sort "ReceivedTime", True
 
For Each OLMAIL In myItems
    Dim daysBack As Date
    Dim dateOfEmail As Date
    daysBack = VBA.Now - 45
    dateOfEmail = OLMAIL.ReceivedTime
    If dateOfEmail < daysBack Then Exit For

    Dim oHTML As MSHTML.HTMLDocument
    Set oHTML = New MSHTML.HTMLDocument

    Dim oElColl As MSHTML.IHTMLElementCollection
    With oHTML
        .Body.innerHTML = OLMAIL.HTMLBody
        Set oElColl = .getElementsByTagName("table")
    End With
 
    Dim t As Long, r As Long, c As Long
    Dim eRow As Long

    For t = 0 To oElColl.Length - 1
        eRow = Sheets(1).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
        For r = 0 To (oElColl(t).Rows.Length - 1)
            For c = 0 To (oElColl(t).Rows(r).Cells.Length - 1)
                Range("A" & eRow).Offset(r, c).Value = oElColl(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) = "Sender's Name:" & " " & OLMAIL.Sender
    Cells(eRow, 1).Interior.Color = vbRed
    Cells(eRow, 1).Font.Color = vbWhite
    Cells(eRow, 2) = OLMAIL.ReceivedTime
    Cells(eRow, 2).Interior.Color = vbBlue
    Cells(eRow, 2).Font.Color = vbWhite
    Range(Cells(eRow, 1), Cells(eRow, 2)).Columns.AutoFit
Next OLMAIL

Range("A2").Select

Set OLApp = Nothing
Set OLMAIL = Nothing
Set oHTML = Nothing
Set oElColl = Nothing

ThisWorkbook.VBProject.VBE.MainWindow.Visible = False
 
End Sub

uj5u.com熱心網友回復：

未經測驗，但這樣的東西應該可以作業。一些部分拆分為單獨的方法以保持主要邏輯清晰。

Sub Extractor()

    Const DAYS_BACK As Long = 45
    
    Dim OLApp As Outlook.Application, ONS As Outlook.Namespace
    Dim OLMAIL As Outlook.MailItem, MYFOLDER As Outlook.Folder
    Dim oHTML As MSHTML.HTMLDocument, oElColl As MSHTML.IHTMLElementCollection
    Dim cDest As Range, tbl As Object, myItems As Object, ws As Worksheet
    
    Set ws = ActiveSheet        'or some specific named sheet
    ws.Range("A2:H30000").Clear
    Set cDest = ws.Range("A2")  'start point for copied data
    
    Set OLApp = New Outlook.Application
    Set ONS = OLApp.GetNamespace("MAPI")
    Set MYFOLDER = ONS.Folders("[email protected]"). _
                   Folders("Inbox").Folders("NewHires")
    
    Set myItems = MYFOLDER.Items
    myItems.Sort "ReceivedTime", True
    
    For Each OLMAIL In myItems
        If OLMAIL.ReceivedTime > (VBA.Now - DAYS_BACK) Then 'within the time window?
            
            Set oHTML = New MSHTML.HTMLDocument
            With oHTML
                .Body.innerHTML = OLMAIL.HTMLBody
                Set oElColl = .getElementsByTagName("table")
            End With
            
            If oElColl.Length > 0 Then       'any tables to process?
                AddHeader cDest, OLMAIL      'add header for this mail
                For Each tbl In oElColl
                    TableToRange cDest, tbl  'transfer table content
                Next tbl
            End If
        End If
    Next OLMAIL
    ws.Range("A1:B1").EntireColumn.AutoFit
End Sub

'copy an HTML table to a worksheet, starting at cell `cDest`
Sub TableToRange(cDest As Range, tbl As Object)
    Dim r As Long, c As Long, rw As Object
    For r = 0 To tbl.Rows.Length - 1
        Set rw = tbl.Rows(r)
        For c = 0 To rw.Cells.Length - 1
            cDest.Offset(0, c).Value = rw.Cells(c).innerText
        Next c
        Set cDest = cDest.Offset(1, 0) 'next sheet row
    Next r
End Sub

'add header info and move destination row down
Sub AddHeader(cDest As Range, oMail As Object)
    With cDest
        .Value = "Sender's Name:" & " " & oMail.Sender
        .Interior.Color = vbRed
        .Font.Color = vbWhite
        .Offset(0, 1).Value = oMail.ReceivedTime
        .Offset(0, 1).Interior.Color = vbBlue
        .Offset(0, 1).Font.Color = vbWhite
    End With
    Set cDest = cDest.Offset(1, 0) 'next sheet row
End Sub

標籤：擅长 vba 外表

上一篇：獲取ODBC-超出系統資源（Rutime錯誤3035）

下一篇：當用戶嘗試執行操作時，我如何彈出msgbox錯誤？（例如洗掉）