Record the sent date after executing Excel send email VBA

[amanphilip]

Hello and Good Day!

I am currently new to VBA and currently trying to create a macro wherein it will capture the Date the email was sent in outlook and place it somewhere in the workbook template. Here's the current code in the workbook:

Sub bankwide()
Dim OutApp As Object
Dim OutMail As Object
Dim recipient As String
Dim rng As Range
Dim lstrow As Long
Dim IDno, lname, fname, fname2, mname, sector, group, division, department, section, rank, position, OnboardD As String
Dim path, subj2, cc, hiringmanager As String



path = Application.ActiveWorkbook.path
'On Error Resume Next

lstrow = Cells(Rows.Count, 3).End(xlUp).Row
    Set rng = Range("C4:C" & lstrow)
   
        For Each cell In rng
            IDno = Range(cell.Address).Offset(0, 0).Value
            lname = Range(cell.Address).Offset(0, 1).Value
            fname = Range(cell.Address).Offset(0, -2).Value
            fname2 = Range(cell.Address).Offset(0, 2).Value
            mname = Range(cell.Address).Offset(0, 3).Value
            sector = Range(cell.Address).Offset(0, 4).Value
            group = Range(cell.Address).Offset(0, 5).Value
            division = Range(cell.Address).Offset(0, 6).Value
            department = Range(cell.Address).Offset(0, 7).Value
            section = Range(cell.Address).Offset(0, 8).Value
            rank = Range(cell.Address).Offset(0, 9).Value
            position = Range(cell.Address).Offset(0, 10).Value
            OnboardD = Range(cell.Address).Offset(0, -1).Value
            cc = Range(cell.Address).Offset(0, 13).Value
            hiringmanager = Range(cell.Address).Offset(0, 12).Value
           
            Set OutApp = CreateObject("Outlook.Application")
            'Set OutMail = OutApp.createitemfromtemplate("C:\Users\t-amachavezjr\Desktop\Reports Automation\Resource Team\Email Sending Template\Bankwide_Onboarding.oft")
               Set OutMail = OutApp.createitemfromtemplate(path & "\Bankwide_Onboarding.oft")
            With OutMail
               .to = hiringmanager
               .cc = cc
            '  .BCC = ""
              .Subject = "[Action Required] Bankwide Onboarding - Group " & group & " for " & OnboardD
              .HTMLbody = Replace(.HTMLbody, "fname", "<b>" & fname & "</b>")
              .HTMLbody = Replace(.HTMLbody, "inum", "<b>" & IDno & "</b>")
              .HTMLbody = Replace(.HTMLbody, "lname", "<b>" & lname & "</b>")
              .HTMLbody = Replace(.HTMLbody, "finame", "<b>" & fname2 & "</b>")
              .HTMLbody = Replace(.HTMLbody, "mname", "<b>" & mname & "</b>")
              .HTMLbody = Replace(.HTMLbody, "%sec%", "<b>" & sector & "</b>")
              .HTMLbody = Replace(.HTMLbody, "%Gr%", "<b>" & group & "</b>")
              .HTMLbody = Replace(.HTMLbody, "%Dv1%", "<b>" & division & "</b>")
              .HTMLbody = Replace(.HTMLbody, "%Dept%", "<b>" & department & "</b>")
              .HTMLbody = Replace(.HTMLbody, "%Sect%", "<b>" & section & "</b>")
              .HTMLbody = Replace(.HTMLbody, "%r1%", "<b>" & rank & "</b>")
              .HTMLbody = Replace(.HTMLbody, "%Pos%", "<b>" & position & "</b>")
              .HTMLbody = Replace(.HTMLbody, "%d1%", "<b>" & OnboardD & "</b>")
              .Display
            End With
           
            subj2 = OutMail.Subject
           
        Next cell
       
        Set OutMail = Nothing
    Set OutApp = Nothing
 

End Sub

I found this code online however this code is for outlook VBA and I am trying to figure out how can I insert this code with the above(VBA EXCEL)

Sub GetMailProps()
Dim myMail As Outlook.MailItem
For Each myMail In Application.ActiveExplorer.Selection
MsgBox "Mail was sent on: " & myMail.SentOn & vbCr & _
"by: " & myMail.SenderName & vbCr & _
"message was received at: " & myMail.ReceivedTime
Next

Set myMail = Nothing
End Sub

Any help is appreciated. Thank you!

 

[DanteAmor]

Hi and welcome to MrExcel.

it will capture the Date the email was sent in outlook and place it somewhere in the workbook template

If I understood correctly you want to save the date in each submitted row.
After this line:

.Display

Put this line:

Range("S" & cell.Row).Value = Date

Change the "S" to the column where you want the date.

--------------
Let me know the result and I'll get back to you as soon as I can.
Cordially
Dante Amor
--------------​

 

[amanphilip]

Hi Dante,

First of all I would like to say thank you for taking your time in helping me out with the query. I have tried your code and it worked perfectly fine.

However, what I am trying to achieve is to record the date only if the email was registered as sent in outlook. To ensure that the email was really sent on that date.

Thank you & Regards,

 

[amanphilip]

marking this thread as resolved as I was able to find a solution online.

For reference here's the code:

Sub OutlookSentItems()
Application.ScreenUpdating = False
Dim olApp As Object ' outlook.application
Dim olNameSpace As Object ' Outlook.Namespace
Dim olSentItems As Object ' Outlook.Items
Dim olMailItem As Object ' Outlook.MailItem
Dim xlApp As Excel.Application
Dim xlWB As Excel.Workbook
Dim xlWS As Excel.Worksheet
Dim row As Long
Dim path As String
Dim i As Integer
Dim ws As Worksheet

Dim rng As Range


path = Application.ActiveWorkbook.path

Set olApp = GetObject(, "Outlook.Application")

On Error GoTo 0

        If olApp Is Nothing Then
            Set olApp = CreateObject("Outlook.Application")
        End If

Set olNameSpace = olApp.GetNamespace("MAPI")
Set olSentItems = olNameSpace.GetDefaultFolder(5).Items


On Error Resume Next
Set xlWB = Workbooks.Open(path & "\SentMail Log File.xlsx", editable:=True)
    xlWB.LockServerFile
Set xlApp = Excel.Application
Set xlWS = xlWB.Sheets(1)
Set rng = xlWS.Range("A:C")

xlWS.Cells(1, 1).Value = "Subject"
xlWS.Cells(1, 2).Value = "Sender"
xlWS.Cells(1, 3).Value = "Sent On"

row = xlWS.Cells(xlWS.Rows.Count, "A").End(-4162).row + 1
    For Each olMailItem In olSentItems
        If InStr(1, olMailItem.Subject, "Welcome to Metrobank", vbTextCompare) > 0 Then
            xlWS.Cells(row, 1).Value = olMailItem.Subject
            xlWS.Cells(row, 2).Value = olMailItem.SenderName
            xlWS.Cells(row, 3).Value = olMailItem.SentOn
            row = row + 1
           
        ElseIf InStr(1, olMailItem.Subject, "[Action Required] Completion of Roll Off Checklist", vbTextCompare) > 0 Then
            Set xlWS = xlWB.Sheets(3)
            row = xlWS.Cells(xlWS.Rows.Count, "A").End(-4162).row + 1
                xlWS.Cells(row, 1).Value = olMailItem.Subject
                xlWS.Cells(row, 2).Value = olMailItem.SenderName
                xlWS.Cells(row, 3).Value = olMailItem.SentOn
                row = row + 1
           
        ElseIf InStr(1, olMailItem.Subject, "[Action Required] Bankwide Onboarding", vbTextCompare) > 0 Then
            Set xlWS = xlWB.Sheets(2)
            row = xlWS.Cells(xlWS.Rows.Count, "A").End(-4162).row + 1
                xlWS.Cells(row, 1).Value = olMailItem.Subject
                xlWS.Cells(row, 2).Value = olMailItem.SenderName
                xlWS.Cells(row, 3).Value = olMailItem.SentOn
                row = row + 1
           
        End If
    Next olMailItem

            For Each ws In xlWB.Worksheets
                With ws
                     Set rng = .Range("A:C")
                     rng.RemoveDuplicates Columns:=Array(1, 2), Header:=xlYes
                     On Error Resume Next
                     rng.SpecialCells(xlCellTypeBlanks).Delete xlShiftUp
                End With

            Next ws

    xlWS.Columns.AutoFit
   
    xlApp.Visible = True
    xlWB.Save
    xlWB.Close
   
    Set olApp = Nothing
    Set olNameSpace = Nothing
    Set olSentItems = Nothing
    Set olMailItem = Nothing
    Set xlApp = Nothing
    Set xlWB = Nothing
    Set xlWS = Nothing

Application.ScreenUpdating = True
End Sub

 

[Peter_SSs]

Good to hear you have a solution & thanks for posting the code to help future readers.
However, when posting vba code in the forum, please use the available code tags. It makes your code much easier to read/debug & copy. My signature block below has more details. I have added the tags in the two posts for you this time.

 

[amanphilip]

Good to hear you have a solution & thanks for posting the code to help future readers.
However, when posting vba code in the forum, please use the available code tags. It makes your code much easier to read/debug & copy. My signature block below has more details. I have added the tags in the two posts for you this time.

Hi Peter,

My apologies will take note of this next time!

Regards