• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Macro to capture email sent datetime in excel

I

IKHAN

Member
Hi,

Can email sent thru excel spreadsheet capture "date/time and write text" in 2 separate columns.

Column M text " Email sent" and Column K"ddd mmm dd, yyyy - hh:mm AM/PM"


Thanks in advance
 
Sure thing. Whatever code you're currently using, put some code like
Code: 
Range("M2").Value = " Email sent"
Range("K2").Value = Now
and format K2 however you'd like the date to appear.
 
Cool...

Can it capture date\time and text after email being sent.

With Above code..It changes to "email sent" and "date/time" as the email in draft after selecting rows in spreadsheet.Sometimes employees create draft earlier than actual time email suppose to send.

Also,

There's multiple rows in spreadsheet with different activities on different time,So how do i change to reflect M2 ...M500 for each activity.
 
W/o knowing how your code is structured, I'm not sure. Presumably, place the code after the line that actually sends the email.

For the different activities, are you sending an email for each one? As you loop over them, could loop over the code. Again, I don't know what your current code looks like.
 
Different activities in rows - Sending mail for each one.

ex. Select row 5 activitity - send email to group of ppl at provided time
select row 6 activitity - send email to another group of ppl at a different time....and so on

All activities on same sheet.
 
Then presumably your code already has some way of knowing which row you are getting information from. You would use that same knowledge to tell it which cell in col M and K to put information back into.
 
Arrgh..Messing it up..

Please help..Using selection code below..rows are highlighted to send email, So need to fillup info colum M once email is sent with text"email sent" and time..

Dim thissheet As String
thissheet = ActiveSheet.Name

Dim head As Range
Dim rng As Range

Set rng = Nothing
ccreceiver = ""
On Error Resume Next

'setting variables
receiver = Range("C" & CStr(ActiveCell.Row())).Value
Set rng = Selection.SpecialCells(xlCellTypeVisible)
 
Looks like you could use the rng variable. So, later on in your code:
Code: 
Cells(rng.Row, "M").Value = " Email sent"
Cells(rng.Row, "K").Value = Now
 
Thanks @Luke..

Tested and works fine ... If more than 1 row is selected,can it fill up same info (email sent and date/time) pn all selected rows..or am i askin lil too much.
 
No, should be able to. Again, it depends on your current code. However the code is keep track of which activity it's looking at, could use that same path.
 
@Luke

Added line code provided on last step and still not filling up status of "email sent" and date for more than 1 row selected.

Works fine if single row selected.
Kindly suggest ....

Code: 
Sub Mail_Outlook()


    Dim receiver As String
    Dim ccreceiver As String
    Dim subject As String
    Dim message As String
      
    Dim OutApp As Object
    Dim OutMail As Object
  
    Dim thissheet As String
    thissheet = ActiveSheet.Name ' points to the active sheet in use
  
    Dim head As Range
    Dim rng As Range
  
  
    Set rng = Nothing
    ccreceiver = ""
  
    On Error Resume Next
  
        receiver = Range("C" & CStr(ActiveCell.Row())).Value
                                                      
    Set rng = Selection.SpecialCells(xlCellTypeVisible)
    Set head = Sheets(thissheet).Range("A2:C2").SpecialCells(xlCellTypeVisible)
    On Error GoTo 0

    If rng Is Nothing Then
        MsgBox "The selection is not a range or the sheet is protected" & _
              vbNewLine & "please correct and try again.", vbOKOnly
        Exit Sub
    End If
  
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With

    ' setting subject
    Sheets("1. Highlevel ").Select
    subject = Range("C6").Value & " - " & Range("C5").Value & " - Activities"
  

    Sheets("4. MOBILE").Select

    Range("I3").Select
  

  
    Do While ActiveCell.Value <> "End"
        If ActiveCell.Value = "X" Or ActiveCell.Value = "x"
            If HasHyperlink(ActiveCell.Offset(0, -1)) Then
                ccreceiver = ccreceiver & ";" & GetAddress(ActiveCell.Offset(0, -1))
            
              
            Else
          
                ccreceiver = ccreceiver & ";" & ActiveCell.Offset(0, -1).Value
            
              
            End If
        Else
        ' ignore if there is no X
    
        End If
      
        ActiveCell.Offset(1, 0).Select ' select next cell
    
    Loop

    ' message body
    message = "Hi " & receiver & ", " & "<br>" & "<br>" & "Proceed <b> STARTED </b> and <b> COMPLETED: </b>"
    message = message & "<br>" & "<b>  Screenshots, Logs, Etc.) </b>" & "<br>"
  
    ' creating the email
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    On Error Resume Next

  
    With OutMail
        .Display ' Display the email, can also send
        .To = receiver
        .CC = ccreceiver
        .BCC = ""
        .subject = subject
        .HTMLBody = message & "<span>" & RangetoHTML(head) & RangetoHTML(rng) & "</span>" & "<br>" & _
                    "xxxx</a> Team." & _
                    "<br>" & "<br>" & .HTMLBody ' the link in the description and the signature
                    ' RangetoHTML function reformats the range given to it into HTML format and paste it into the email
    End With
        With Application
        .EnableEvents = True
        .ScreenUpdating = True
      
      
    End With

    On Error GoTo 0
  
    Set OutMail = Nothing ' free memory
    Set OutApp = Nothing
  
    Sheets(thissheet).Select ' go back to the original sheet

    Cells(rng.Row, "M").Value = " email sent" ' Added new line code from Chandoo to fill status
    Cells(rng.Row, "K").Value = Now ' Added new line code from Chandoo
End Sub
 
Last edited:
Try this.
Code: 
Sub Mail_Outlook()
    Dim receiver As String
    Dim ccReceiver As String
    Dim subJect As String
    Dim message As String
       
    Dim OutApp As Object
    Dim OutMail As Object
   
    Dim thisSheet As String
    thisSheet = ActiveSheet.Name ' points to the active sheet in use
    Dim head As Range
    Dim rng As Range
    Dim c As Range
   
   
    Set rng = Nothing
    ccReceiver = ""
   
    On Error Resume Next
   
    receiver = Range("C" & CStr(ActiveCell.Row())).Value
                                                       
    Set rng = Selection.SpecialCells(xlCellTypeVisible)
    Set head = Sheets(thisSheet).Range("A2:C2").SpecialCells(xlCellTypeVisible)
    On Error GoTo 0

    If rng Is Nothing Then
        MsgBox "The selection is not a range or the sheet is protected" & _
              vbNewLine & "please correct and try again.", vbOKOnly
        Exit Sub
    End If
   
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With

    ' setting subject
    Sheets("1. Highlevel ").Select
    subJect = Range("C6").Value & " - " & Range("C5").Value & " - Activities"
   

    Sheets("4. MOBILE").Select

    Range("I3").Select
   

   
    Do While ActiveCell.Value <> "End"
        If ActiveCell.Value = "X" Or ActiveCell.Value = "x" Then
            If HasHyperlink(ActiveCell.Offset(0, -1)) Then
                ccReceiver = ccReceiver & ";" & GetAddress(ActiveCell.Offset(0, -1))
             
               
            Else
           
                ccReceiver = ccReceiver & ";" & ActiveCell.Offset(0, -1).Value
             
               
            End If
        Else
        ' ignore if there is no X
   
        End If
       
        ActiveCell.Offset(1, 0).Select ' select next cell
   
    Loop

    ' message body
    message = "Hi " & receiver & ", " & "<br>" & "<br>" & "Proceed <b> STARTED </b> and <b> COMPLETED: </b>"
    message = message & "<br>" & "<b>  Screenshots, Logs, Etc.) </b>" & "<br>"
   
    ' creating the email
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    On Error Resume Next
   
    With OutMail
        .Display ' Display the email, can also send
        .To = receiver
        .CC = ccReceiver
        .BCC = ""
        .subJect = subJect
        .HTMLBody = message & "<span>" & RangetoHTML(head) & RangetoHTML(rng) & "</span>" & "<br>" & _
                    "xxxx</a> Team." & _
                    "<br>" & "<br>" & .HTMLBody ' the link in the description and the signature
                   ' RangetoHTML function reformats the range given to it into HTML format and paste it into the email
    End With

   
    Sheets(thisSheet).Select ' go back to the original sheet

    'Mark up statuses
    For Each c In rng.Cells
        Cells(c.Row, "G").Value = " email sent" ' Added new line code from Chandoo to fill status
        Cells(c.Row, "K").Value = Now ' Added new line code from Chandoo
    Next c
   
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With

    On Error GoTo 0
   
    Set OutMail = Nothing ' free memory
    Set OutApp = Nothing
End Sub
 
You must log in or register to reply here.
Back
Top