vba - 在 Excel 电子表格中捕获电子邮件接收时间

Question

我需要从头开始。我的代码和我的手臂一样长。我“只是”想弄清楚如何获取电子邮件的发送日期并将其插入 Excel 中的特定列。我已经想出了如何在电子邮件正文中获取 HTML 表格并将其放入 Excel 中。现在，“所有”我需要做的就是捕获电子邮件的日期并放入列

Public Sub Driver()

    Dim Item As MailItem, x%
    Dim r As Object                              'As Word.Range
    Dim doc As Object                            'As Word.Document
    Dim xlApp As Object
    Dim olItems As Outlook.Items
    Dim sourceWB As Workbook
    Dim sourceSH As Worksheet
    Dim olFolder As Outlook.Folder
    Dim strFile As String
    Dim olEleColl As MSHTML.IHTMLElementCollection
    Dim olNameSpace As Outlook.NameSpace
    Dim olHTML As MSHTML.HTMLDocument: Set olHTML = New MSHTML.HTMLDocument
    Dim OutlookApp As Object
    Dim OutlookMail As Object

    Dim objEmail As Outlook.MailItem
    Dim intRowIndex As Integer
    Dim intEmailIndex As Integer
    Dim objFolder As Outlook.MAPIFolder

    Set xlApp = CreateObject("Excel.Application")
    With xlApp
        .Visible = True
        .EnableEvents = False
        .EnableEvents = False
        .DisplayAlerts = False
    End With

    Set olNameSpace = Application.GetNamespace("MAPI")
    Set olFolder = olNameSpace.GetDefaultFolder(olFolderInbox)
    Set olItems = olFolder.Items
    'olItems.Sort ("[ReceivedTime]")
    Set Item = olItems(olItems.Count)

    'save Outlook email's html body (tables)
    With olHTML
        .Body.innerHTML = Item.HTMLBody
        Set olEleColl = .getElementsByTagName("table")
    End With

    strFile = "C:\xls\Driver.xlsx"

    Set sourceWB = Workbooks.Open(strFile, , False, , , , , , , True)
    Set sourceSH = sourceWB.Worksheets("Sheet1")
    sourceWB.Activate

    cells.Select
    Selection.Delete

    For Each Item In Application.ActiveExplorer.Selection
        Set doc = Item.GetInspector.WordEditor

        For x = 1 To doc.tables.Count
            Set r = doc.tables(x)
            r.Range.Copy
            sourceSH.Paste

            ActiveSheet.Pictures.Delete
            rows(4).Delete
            rows(1).EntireRow.Delete
            rows(1).EntireRow.Delete
            rows(1).EntireRow.Delete
            Range("D:E").Delete

            sourceSH.cells(sourceSH.rows.Count, 1).End(3).Offset(1).Select

            sourceSH.cells(1, 4) = "Received Time"

        Next
    Next

    sourceWB.Save
    sourceWB.Close

    Set sourceWB = Nothing
    xlApp.Quit
    Set xlApp = Nothing

    Set OutlookApp = CreateObject("Outlook.Application")
    Set OutlookMail = OutlookApp.CreateItem(0)

    On Error Resume Next
    With OutlookMail
        .To = "[e-mail]"

        .CC = ""
        .BCC = ""
        .Subject = "If this works!"
        .Body = "Test."
        .Attachments.Add ("c:\xls\Driver.xlsx")
        .Send
    End With

    Set OutlookMail = Nothing
    Set OutlookApp = Nothing

End Sub

标签： vbaoutlook

Answer 1

好的，我想出了一些可能不可取的东西，但它对我有用。我添加了一个 specialcells 函数，用于搜索列中的空白单元格，然后添加我需要的日期。非常感谢所有的帮助

Public Sub Driver()


Dim Item As MailItem, x%
Dim r As Object  'As Word.Range
Dim doc As Object 'As Word.Document
Dim xlApp As Object
Dim olItems As Outlook.Items
Dim sourceWB As Workbook
Dim sourceSH As Worksheet
Dim olFolder As Outlook.Folder
Dim strFile As String
Dim olEleColl As MSHTML.IHTMLElementCollection
Dim olNameSpace As Outlook.NameSpace
Dim olHTML As MSHTML.HTMLDocument: Set olHTML = New MSHTML.HTMLDocument
Dim OutlookApp As Object
Dim OutlookMail As Object

Dim objEmail As Outlook.MailItem
Dim intRowIndex As Integer
Dim intEmailIndex As Integer
Dim objFolder As Outlook.MAPIFolder

Set xlApp = CreateObject("Excel.Application")
    With xlApp
        .Visible = True
        .EnableEvents = False
        .EnableEvents = False
        .DisplayAlerts = False
    End With
    Set olNameSpace = Application.GetNamespace("MAPI")

Set olFolder = olNameSpace.GetDefaultFolder(olFolderInbox)
Set olItems = olFolder.Items
'olItems.Sort ("[ReceivedTime]")
Set Item = olItems(olItems.Count)

'save Outlook email's html body (tables)
With olHTML
    .Body.innerHTML = Item.HTMLBody
    Set olEleColl = .getElementsByTagName("table")
End With

strFile = "C:\xls\Driver.xlsx"

 Set sourceWB = Workbooks.Open(strFile, , False, , , , , , , True)
 Set sourceSH = sourceWB.Worksheets("Sheet1")
    sourceWB.Activate

cells.Select
    Selection.Delete

For Each Item In Application.ActiveExplorer.Selection
Set doc = Item.GetInspector.WordEditor
    For x = 1 To doc.tables.Count
     Set r = doc.tables(x)


        r.Range.Copy
       sourceSH.Paste
ActiveSheet.Pictures.Delete
rows(4).Delete
    rows(1).EntireRow.Delete
    rows(1).EntireRow.Delete
    rows(1).EntireRow.Delete
 Range("D:E").Delete
       sourceSH.cells(sourceSH.rows.Count, 1).End(3).Offset(1).Select


sourceSH.cells(2, 4) = Item.ReceivedTime
sourceSH.cells(1, 4) = "Received Time"
Range("D2").CurrentRegion.SpecialCells(xlCellTypeBlanks).Value = Item.ReceivedTime


    Next
Next
End Sub