Capture Email Received Time in an Excel Spreadsheet

Question

I need to start from scratch. I have code as long as my arm. I "simply" want to figure out how to take the date that an email was sent and insert it into a specific column in Excel. I have already figured out how to take the HTML table in the body of the email and place it in Excel. NOW, "all" I need to do is capture the date of email and drop in Column

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 = "me@memememe.com"

        .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

I googled, (did you?): https://learn.microsoft.com/en-us/office/vba/api/outlook.mailitem.senton — , Sep 25 '18 at 16:01
Based on the title of the question - how is the [`ReceivedTime`](https://learn.microsoft.com/en-us/office/vba/api/outlook.mailitem.receivedtime) property not working? — BigBen, Sep 25 '18 at 16:04
check this out: https://stackoverflow.com/questions/43766570/how-to-get-outlook-email-received-time — Ibo, Sep 25 '18 at 16:04
@peakpeak do you feel better now that you tried to belittle me? bravo and helpful — donviti, Sep 25 '18 at 16:05
@BigBen I can't seem to even be able to create the object to pull the date and drop it into a column. I'm not even bother putting the code I had in b/c nothing literally nothing has even come close to working — donviti, Sep 25 '18 at 16:06
Is `Item` not the `MailItem` in question? Although as is your code assumes that `Item` is in fact a `MailItem` — BigBen, Sep 25 '18 at 16:07
@Ibo thank you, I found that but I honestly can't figure out how to use that code and drop the date into a column. I admit I'm struggling with this — donviti, Sep 25 '18 at 16:07
@BigBen it could be man, but my comprehension of VBA is hitting a wall with how to drop that into a column — donviti, Sep 25 '18 at 16:08
What do you mean by "drop it into a column" - write it into a particular cell? Just set the cell's `.Value` equal to the `ReceivedTime`. — BigBen, Sep 25 '18 at 16:11
@BigBen yes. I feel like I have tried doing it but I can't seem to get anything to work — donviti, Sep 25 '18 at 16:15
this code: `cells.Select : Selection.Delete` is quite dangerous! It will delete the contents of whatever cell happens to be selected when you run it. — FreeMan, Sep 25 '18 at 16:19
Your code is kinda all over the place, but I think the issue is here: `sourceSH.cells(1, 4) = "Received Time"`. That should _probably_ be `sourceSH.cells(1, 4) = Item.ReceivedTime`, but there's no guarantee that's it. — FreeMan, Sep 25 '18 at 16:21
@FreeMan I don't disagree that it's all over the place at all. — donviti, Sep 25 '18 at 16:31
@FreeMan holy crap. That's gonna be good enough. man what a fool. Any idea how to get that to populate the array? The number of rows varies by day, and ideally I'd like that to populate the column all the way down next to the other data.... — donviti, Sep 25 '18 at 16:40
Instead of `sourceSH.cells(1, 4) = Item.ReceivedTime` you'd want `sourceSH.cells(currentRow, currentCol) = Item.ReceivedTime` where `currentRow` and/or `currentCol` change as you loop through all the email messages you're reading. — FreeMan, Sep 25 '18 at 16:45
@FreeMan Thank you, it's not looping through the email messages. It's taking an HTML table which is in the body of the email. I then am attaching the date of the email to each row that has data from the column. So if today's email has 20 names, ideally I want 20 dates. Tomorrow could be 15, so I'll want 15. This has been a big help. I'll try to figure out how to insert the date for each row — donviti, Sep 25 '18 at 17:08
You would get way more useful help if your explanation in your question wasn't barely 3 sentences :p — Marcucciboy2, Sep 25 '18 at 17:22
@Marcucciboy2 I don't disagree with that but sometimes I give too much info and it confuses people more — donviti, Sep 25 '18 at 17:41
In those cases, if the underlying question is good, many people wouldn't hesitate to edit that up for you to help make a coherent and concise question (I do it all the time) — Marcucciboy2, Sep 25 '18 at 17:42

score 0 · Answer 1 · answered Sep 26 '18 at 05:55

You can use MailItem.ReceivedTime Property to get the time of email.

Please try the following code.

    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

So that is almost what I need and I think I can work with that. It is giving me a bunch of different dates and running past the rows with data. Thank you, the m=1 thing is what I'm failing to understand and this is a big help — donviti, Sep 26 '18 at 11:52
m=1 just specifies that it starts to loop from there. It is not the point. could you please mark the answer if it helps — Evanzheng, Sep 27 '18 at 03:30

score 0 · Answer 2 · answered Sep 26 '18 at 18:22

Ok, I figured out something that is probably not advisable, but it worked for me. I added a specialcells function that searches for the blank cells in a column and then it adds the Date that I need. Thanks so much for all the help

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

Capture Email Received Time in an Excel Spreadsheet

2 Answers2