Захватывать время получения электронной почты в электронной таблице 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

Answer 1

Хорошо, я понял что-то, что, вероятно, не рекомендуется, но это сработало для меня. Я добавил функцию спецэлементов, которая ищет пустые ячейки в столбце, а затем добавляет дату, которая мне нужна. Большое спасибо за помощь

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

Answer 2

Вы можете использовать свойство MailItem.ReceivedTime для получения времени электронной почты.

Пожалуйста, попробуйте следующий код.

    Public Sub Driver()
    Dim xlApp As Object
    Dim sourceWB As Workbook
    Dim strFile As String
    Dim olItems As Outlook.Items
    Dim sourceSH As Worksheet
    Dim olFolder As Outlook.folder
    Dim olNameSpace As Outlook.NameSpace
    Dim objEmail As Object
    Dim intRowIndex As Integer
    Dim intEmailIndex As Integer
    Dim objFolder As Outlook.MAPIFolder
    Dim m As Long
    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]")
    strFile = "C:\Users\dfddg\Desktop\Book1.xlsx"
    Set sourceWB = Workbooks.Open(strFile, , False, , , , , , , True)
    Set sourceSH = sourceWB.Worksheets("Sheet1")
    sourceWB.Activate
    m = 1
    For Each Item In olItems
    sourceSH.cells(m, 4) = Item.ReceivedTime
    'MsgBox Item.ReceivedTime
    'MsgBox Item.Subject
    m = m + 1
    Next
    sourceWB.Save
    sourceWB.Close
End Sub