Auto email code

[Osamarizwan]

Dear,
I have an excel file that have an expiration date, and I would like that when the date is -15 days before expiring it send an email automatically based on some cells information to the outlook email once the system logged in. I have add a code but it is not sending auto email and I have to add button for it after opening file.

I would prefer that it could work with the file closed.

Below is the table which I am using.

S.NO	CLIENT NAME	SERVICE	CONTRACT START DATE	Expiry	Period	Amount	Status	Remark
1	ABC	IJK	06-Oct-2022	30-Sep-2023	12 MONTHS		Over Due

 

[Logit]

I believe you have not received assistance due to :

- The workbook must be opened to run the email macro

- The client information you have provided does not include an email address. Will you be sending the email to only one client ? If so, what is the email address ?

 

[Osamarizwan]

Can you please let me know the code for this purpose, also note another Vba is already applied in my sheet.

 

[Logit]

Following is the code used in this project :

Option Explicit

Sub eMail()
Dim lRow As Integer
Dim i As Integer
Dim toDate As Date
Dim toList As String
Dim eSubject As String
Dim eBody As String
Dim OutApp
Dim OutMail

With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .DisplayAlerts = False
End With

Sheets(1).Select
lRow = Cells(Rows.Count, 11).End(xlUp).Row

For i = 2 To lRow
toDate = Replace(Cells(i, 5), ".", "/")
  If Not Cells(i, 10) <> "" And Cells(i, 5) = Date Then     ' Formula in Col E determines the email send date
     Set OutApp = CreateObject("Outlook.Application")
     Set OutMail = OutApp.CreateItem(0)

        toList = Cells(i, 11)    'gets the recipient from col K
        eSubject = "Your Contract Expiration Date Is " & Cells(i, 5) + 15
        eBody = "Dear " & Cells(i, 2) & " :" & vbCrLf & vbCrLf & "Contract fee is " & Cells(i, 7) & " for the service of " _
        & Cells(i, 3) & ".  " & vbCrLf & vbCrLf & "Please renew your contract." _
        & vbCrLf & vbCrLf & vbCrLf & "Sincerely," & vbCrLf & vbCrLf & "ABC Finance"
       
        On Error Resume Next
        With OutMail
        .To = toList
        .CC = ""
        .BCC = ""
        .Subject = eSubject
        .Body = eBody
        .bodyformat = 1
        .Display   ' ********* Creates draft emails. Comment this out when you are ready
        '.Send     '********** UN-comment this if you don't require reviewing each email prior to sending
        End With
 
    On Error GoTo 0
    Set OutMail = Nothing
    Set OutApp = Nothing
 Cells(i, 10) = "Mail Sent " & Date + Time 'Marks the row as "email sent in Column J"
End If
Next i

ActiveWorkbook.Save

With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .DisplayAlerts = True
End With
End Sub

The sample workbook may be downloaded at :Internxt Drive – Private & Secure Cloud Storage

The columns with grey background ... do not manually enter anything into those cells. Each cell (down to row 1,000) contains formulas and automatically calculate.
If you need more than 1000 rows they can be add to by dragging the last cell down the column.

Each workday morning you'll open the workbook and click the EMAIL button. The workbook will automatically process the data and create the required emails, displaying
each on screen to be reviewed prior to sending. You'll need to configure your copy of Outlook to send emails for this workbook to send emails.