Automatically Send Emails

Occasional Contributor


I've found a script that sends emails automatically and it seems to work well.

The problem is I have to send more than one automated email a week - and at different times.

Is there a way to manipulate or modify this code (or use a different one that is) so that I can sent multiple emails a week at different times?

Thanks in advance!



Private Sub Application_Reminder(ByVal Item As Object)

Dim objMsg As MailItem
Dim objApp As AppointmentItem
Dim Att As Attachment
Dim tmpFolder As String
Dim filePath As String
Set objMsg = Application.CreateItem(olMailItem)

MsgBox "Appointment Triggered"

'message is appointment
If Item.MessageClass <> "IPM.Appointment" Then Exit Sub
'The appointment is set as "Send Schedule Recurring Email" Category
If Item.Categories <> "Send Schedule Recurring Email" Then Exit Sub

'MsgBox Item.MessageClass
'MsgBox Item.Categories
'MsgBox Item.Location
'MsgBox Item.Subject
'MsgBox objMsg.Body
'MsgBox Environ("USERPROFILE")

'to get the path of the email attachment
tmpFolder = Environ("USERPROFILE")

'Add each attachment to email object to be sent
For Each Att In Item.Attachments
filePath = tmpFolder & "\" & Att.FileName
Att.SaveAsFile (filePath)
objMsg.Attachments.Add filePath
Kill filePath
Next Att

'send email object
objMsg.To = Item.Location
objMsg.Subject = Item.Subject
objMsg.Body = Item.Body
Set objMsg = Nothing

End Sub

0 Replies