Automatic email generate

Hi all, need your expert help on this. attached workbook has a coloum for date and expire date. I need a script or something to make the workbook sent automatic emails to 2 or 3 contacts when the date is expired. Can this be done? if yes, how can I trigger it to send mails? (Do i have to open it? or press a button? or excel automatically do this?) and one last thing if there are 2 copies of the work book does both of them sends the emails or only one sends it?

Thanks,
Sanjeeva

AttachmentSize
Blank.xlsx38.02 KB
Almir's picture

Use onTime method to schedule e-mail sending

I have already posted solution, but, for unknown reason, it has gone. However, here it is again:
Store first macro (SheduleEmailSending) into Personal.xlsb at your computer. Put another macro (SendEmail, along with GetBoiler function) into a separate module in your main file. Storing scheduling macro in Personal.xlsb will prevent that sending is executed by error on recipients' computers at scheduled time.
Macro to schedule execution (put it into Personal.xlsb):

Sub ScheduleEmailSending()
With Application
.OnTime TimeValue("12:00:00"), "SendingEmail"
End With
End Sub

GetBoiler function to enable sending email with Outlook signature:

Function GetBoiler(ByVal sFile As String) As String
' This function is necessary in order sending file to function properly.
Dim fso As Object
Dim ts As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
GetBoiler = ts.readall
ts.Close
End Function

Main macro (SendingEmail):

Sub SendingEmail()
Dim temp As String
Dim ws As Worksheet
Dim strTo As String
Dim Fval As String

strTo = "recipient1@something.com;recipient2@something.com" ' put recipients' e-mail addresses, separated by semi-colon

'Declare and establish the Object variables for Outlook.
Dim objOutlook As Object
Dim objNameSpace As Object
Dim objInbox As Object
Dim objMailItem As Object
Dim SigString As String
Dim Signature As String
Set objOutlook = CreateObject("Outlook.Application")
Set objNameSpace = objOutlook.GetNamespace("MAPI")
Set objInbox = objNameSpace.Folders(1)
Set objMailItem = objOutlook.CreateItem(0)

'Send the email message
SigString = Environ("appdata") & "\Microsoft\Signatures\Signature.htm" ' Outlook signature, change it as necessary
If Dir(SigString) <> "" Then
Signature = GetBoiler(SigString) ' calling above function GetBoiler
Else
Signature = ""
End If

With objMailItem
.To = strTo
.Subject = "Enter yur subject" '
.Body = "Text of your message"
.HTMLBody = .Body & "
" & "
" ' Outlook signature
.Attachments.Add "Path and file name of the file attached"
.send 'sending message
End With

Application.Wait "12:05:00" ' giving enough time Outlook to finish sending message before closing
'Release object variables from system memory.
Set objOutlook = Nothing
Set objNameSpace = Nothing
Set objInbox = Nothing
Set objMailItem = Nothing
End Sub

Finally, open the main file and run your schedule macro stored in Personal.xlsb (don't forget this!). When scheduled time is reached, it will run macro for sending e-mail. Leave your main file open. Outlook does not have to be open.

When you store "ScheduleEmailSending" macro to your Personal.xlsb file, e-mail will be sent only once, not twice. If you put "ScheduleEmailSending" macro into your main file, it could also send itself from recipients' computers on scheduled time.

Private Sub

Private Sub Workbook_Open()

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

Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon

On Error GoTo cleanup
For Each cell In Sheets("Sheet1").Columns("C").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "?*@?*.?*" And LCase(cell.Offset(0, 5).Value) = "yes" And cell.Offset(0, 7) <> "SENT" Then
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = cell.Value
.Subject = cell.Offset(0, 1).Value & " Expring on " & cell.Offset(0, 3).Value
' .cc = "
' .Attachments.Add cell.Offset(0, 6).Value
.Body = "Good Day, " & vbNewLine & vbNewLine & _
"Kindly process documents for renewal" & cell.Offset(0, 1).Value & " Expring on " & cell.Offset(0, 3).Value & _
vbNewLine & vbNewLine & "Regards" & vbNewLine & "Finance Auto Reminder"
.Send 'Or use Display
End With
On Error GoTo 0
strdate = Format(Now, "dd-mm-yyyy-at-hh-mm")
cell.Offset(0, 7) = "SENT"
'cell.Offset(0, 5) = strdate

Set OutMail = Nothing
End If
Next cell
cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
' timer to close file
' Application.OnTime Now() + TimeValue("00:05:00"), "Makro2"

End Sub