Code to automatically send an email a week before date with a message.

[Dazzawm]

I have a sheet as set out below. Is there a way or a code that will automatically send an email a week before the date in column B with a message of my choice?

Thanks.

​Excel 2010

	A	B
john@gmail.com
eric@hotmail.com
daz@hotmail.co.uk

<colgroup><col style="width: 25pxpx" https:="" www.mrexcel.com="" forum="" usertag.php?do="list&action=hash&hash=DAE7F5"" target="_blank"></colgroup><colgroup><col><col></colgroup><thead>
</thead><tbody>
[TD="align: center"]2[/TD]

[TD="align: right"]25/07/2019[/TD]

[TD="align: center"]3[/TD]

[TD="align: right"]15/08/2019[/TD]

[TD="align: center"]4[/TD]

[TD="align: right"]10/10/2019[/TD]

</tbody>

Sheet1​

 

[Dazzawm]

Any ideas anyone please? Or even if anyone knows a program that may do the same thing.

 

[Logit]

.
This example auto-sends an email on the date specified in Col A, when the workbook is opened :

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, 1).End(xlUp).Row


For i = 2 To lRow
toDate = Sheets("Sheet1").Cells(i, 1)


If toDate < Date Then: Exit Sub


  If Left(Cells(i, 5), 4) <> "Mail" And toDate = Date Then
  
             Set OutApp = CreateObject("Outlook.Application")
             Set OutMail = OutApp.CreateItem(0)
        
                toList = Cells(i, 2)    'gets the recipient from col B
                eSubject = Cells(i, 3)  'gets subject from col C
                eBody = Cells(i, 4)     'gets body of email from col D
                
                'enter email body here
                
                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 when you  are ready to go live
                End With
         
            On Error GoTo 0
            Set OutMail = Nothing
            Set OutApp = Nothing
         Cells(i, 5) = "Mail Sent " & Date + Time 'Marks the row as "email sent in Column C"
             
    End If
Next i
ActiveWorkbook.Save


With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .DisplayAlerts = True
End With
MsgBox "All emails have been sent. ", vbInformation, "Email Notice "


End Sub


Sub sbInsertingRows()
    'Inserting a Row at at Row 2
    Range("A2").EntireRow.Insert
End Sub

Download workbook : https://www.amazon.com/clouddrive/share/F7okMA0vsWpFtcN4uIe4DnPd7HJBuBU2JSRCaqp3Iow

 

[Dazzawm]

Thanks what email program will it use?

 

[Dazzawm]

I see it uses Microsoft Outlook but I don't use that. Mine is the Windows 10 mail app.

 

[Logit]

Doesn't your version of Office have Outlook ?

If not, you can download Outlook separately.

 

[Dazzawm]

So it wont work with the windows 10 email app? As the email account I want it sent from is a gmail

 

[Dazzawm]

Ok I have managed to set up my gmail in Microsoft Outlook. When I run your 'send' code it opens up the email but doesn't automatically send?

 

[Logit]

.
Note the comments after .Send and .Display

 

[Dazzawm]

.
Note the comments after .Send and .Display

Done that and pressed send but the circle just keeps spinning to the point of freezing?