Outlook Timestamp

[ir121973]

Hi,

I wonder whether someone may be able to help me please.

I'm using an adaptation of one of Ron de Bruins email scripts below:

Sub Email()


    Dim OutApp As Object
    Dim OutMail As Object
    Dim cell As Range


    Dim Src As Worksheet
    Dim fNameAndPath As Variant, wb As Workbook


    Application.ScreenUpdating = False




    fNameAndPath = Application.GetOpenFilename(Title:="Select File To Be Opened")
    If fNameAndPath = False Then Exit Sub


    Set wb = Workbooks.Open(fNameAndPath)


    Set OutApp = CreateObject("Outlook.Application")
    Set Src = wb.Sheets("Sheet1")


    On Error GoTo cleanup


    Src.Select
    For Each cell In Columns("E").Cells.SpecialCells(xlCellTypeConstants)
        If cell.Value Like "?*@?*.?*" And _
            Cells(cell.Row, "K").Value = True Then


            Set OutMail = OutApp.CreateItem(0)
            On Error Resume Next
            With OutMail
                .To = cell.Value
                .Subject = "Access"
                .Body = "Hi " & Cells(cell.Row, "A").Value _
                    & vbNewLine & vbNewLine & _
                        "I have been asked to create an account for you." & _
                    vbNewLine & vbNewLine & _
                        "Your username and password details are:" & _
                    vbNewLine & vbNewLine & _
                        "Username: " & Cells(cell.Row, "C").Value & _
                    vbNewLine & _
                        "Password: " & Cells(cell.Row, "I").Value & _
                    vbNewLine & vbNewLine & _
                        "Please log in at your earliest convenience and change your password to a more secure one." & _
                    vbNewLine & vbNewLine & _
                        "You can do this by clicking on your name on the top menu and select 'Edit Account'." & _
                    vbNewLine & vbNewLine & _
                        "You can use this link to get to the log in page for this environment: " & _
                    vbNewLine & vbNewLine & _
                        "Many thanks and kind regards"
                    .Sensitivity = 2
                    .Send
            End With
            On Error GoTo 0
            Cells(cell.Row, "P").Value = "send"
            Set OutMail = Nothing
        End If
        Next cell


cleanup:
            Set OutApp = Nothing
            Application.ScreenUpdating = True


            wb.Close savechanges:=True 'or false
End Sub

The code works fine, but I'd like to amend the end of the script so that I can record the 'Outlook sent email' time stamp.

You'll see that I've included this row Cells(cell.Row, "P").Value = "send" so that I can add the word "send" and I'd like the time stamp do be placed in column Q against each user in the range.

I've done a fair bit of research but I've not been able to find a suitable solution.

I just wondered whether someone may be able to look at this please and offer some guidance on how I may achieve this please?

Many thanks and kind regards

Chris

 

[CalcSux78]

Have you looked into using NOW() for your time stamp?

All you'd need is add this:

Cells(cell.Row, "P").Value = "send"
[B][COLOR=#0000ff]cells(cell.row, "Q").Value =  Now[/COLOR][/B]
Set OutMail = Nothing