Outlook VBA - recurring task to send email

ajm

Well-known Member
Joined
Feb 5, 2003
Messages
1,762
hi folks,

I have found a great way to send out reminders to submit work to a group of people based on a recurring task.

https://www.datanumen.com/blogs/auto-send-recurring-email-periodically-outlook-vba/

in ThisOutlookSession, you paste the following code:

Code:
Private Sub Application_Reminder(ByVal Item As Object)
    Dim objPeriodicalMail As MailItem
 
    If Item.Class = olTask Then
       If InStr(LCase(Item.Subject), "send an email periodically") Then
          Set objPeriodicalMail = Outlook.Application.CreateItem(olMailItem)
          'Change the following email information as per your actual needs
          With objPeriodicalMail
               .Subject = "Test"
               .To = "boss@datanumen.com"
               .HTMLBody = "<HTML>******>type body here</HTML></BODY>"
               .Attachments.Add ("C:\Attachments\DataNumen.docx")
               .Importance = olImportanceHigh
               .ReadReceiptRequested = True
               .Send
          End With
       End If
    End If
End Sub

In attempting to add email signature and line breaks, i adjusted it by including parts of Ron Debruin's work from

https://www.rondebruin.nl/win/s1/outlook/signature.htm

Example 2 : Insert the signature that you want without picture

Code:
Sub Mail_Outlook_With_Signature_Html_2()
' Don't forget to copy the function GetBoiler in the module.
' Working in Office 2000-2016
    Dim OutApp As Object
    Dim OutMail As Object
    Dim strbody As String
    Dim SigString As String
    Dim Signature As String

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    strbody = "Dear Customer Ron de Bruin" & _
              "Please visit this website to download the new version." & _
              "Let me know if you have problems." & _
              "<A HREF=""http://www.rondebruin.nl/tips.htm"">Ron's Excel Page</A>" & _
              "Thank you"

    'Change only Mysig.htm to the name of your signature
    SigString = Environ("appdata") & _
                "\Microsoft\Signatures\Mysig.htm"

    If Dir(SigString) <> "" Then
        Signature = GetBoiler(SigString)
    Else
        Signature = ""
    End If

    On Error Resume Next

    With OutMail
        .To = "ron@debruin.nl"
        .CC = ""
        .BCC = ""
        .Subject = "This is the Subject line"
        .HTMLBody = strbody & "<br>" & Signature
        .Send    'or use .Display
    End With

    On Error GoTo 0
    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub


Function GetBoiler(ByVal sFile As String) As String
'**** Kusleika
    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

I have ended up with:

Code:
Private Sub Application_Reminder(ByVal Item As Object)
    Dim objPeriodicalMail As MailItem
    Dim strbody As String, strSubject As String
    Dim SigString As String
    Dim Signature As String
 
    If Item.Class = olTask Then
       If InStr(LCase(Item.Subject), "Reminder: Radiology partnership distribution changes") Then
          Set objPeriodicalMail = Outlook.Application.CreateItem(olMailItem)
          
          strbody = "Good morning doctors.<br><br>" & _
              "Please provide any distribution changes for end of month processing by <I><u>the end of next week</u></I>.<br><br>" & _
              "Let me know if you have problems." & _
              "<br><br>Thank you"
              
          strSubject = "Reminder: Radiology partnership distribution changes"
              
    'Change only Mysig.htm to the name of your signature
   ' SigString = Environ("appdata") & _
                "\Microsoft\Signatures\sig.htm"

    'If Dir(SigString) <> "" Then
       ' Signature = GetBoiler(SigString)
    'Else
        'Signature = ""
    'End If

    On Error Resume Next

    With objPeriodicalMail
    'Change the following email addresses as needed
        .SentOnBehalfOfName = "me@work"
        .Subject = "Reminder: Radiology partnership distribution changes"
        .To = "me2@work"
        .CC = ""
        .BCC = ""
        .Subject = strSubject
        .HTMLBody = strbody & "<br>" & Signature
        .Importance = olImportanceHigh
        .ReadReceiptRequested = True
        .Send    'or use .Display
    End With

    On Error GoTo 0
          
          
          
       End If
    End If
End Sub


'Function GetBoiler(ByVal sFile As String) As String
'**** Kusleika
   ' 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

I have commented out the signature parts while trying to work out why it doesn't work. Ron's macro is entered into a standard module while the Datanum work is meant for the ThisOutlookSession” project.

I am using Excel 2016
 
Last edited:

Some videos you may like

Excel Facts

Difference between two dates
Secret function! Use =DATEDIF(A2,B2,"Y")&" years"&=DATEDIF(A2,B2,"YM")&" months"&=DATEDIF(A2,B2,"MD")&" days"

ajm

Well-known Member
Joined
Feb 5, 2003
Messages
1,762
this worked:

Code:
Private Sub Application_Reminder(ByVal Item As Object)
    Dim objPeriodicalMail As MailItem
    Dim strbody As String, strSubject As String
    Dim SigString As String
    Dim Signature As String
 
    If Item.Class = olTask Then
       If InStr(LCase(Item.Subject), "reminder: radiology partnership distribution changes") Then
          Set objPeriodicalMail = Outlook.Application.CreateItem(olMailItem)
          
          strbody = "Good morning doctors.<br><br>" & _
              "Please provide any distribution changes for end of month processing by <I><u>the end of next week</u></I>.<br><br>" & _
              "Let me know if you have problems." & _
              "<br><br>Thank you"
              
          strSubject = "Reminder: Radiology partnership distribution changes"
              
    'Change only Mysig.htm to the name of your signature
   SigString = Environ("appdata") & _
                "\Microsoft\Signatures\sig.htm"

    If Dir(SigString) <> "" Then
        Signature = GetBoiler(SigString)
    Else
        Signature = ""
    End If

    On Error Resume Next

    With objPeriodicalMail
    'Change the following email addresses as needed
        .SentOnBehalfOfName = "email@whereiwork.com.au"
        .Subject = "Reminder: Radiology partnership distribution changes"
        .To = "bloke1@whereiwork.com.au; bloke2@whereiwork.com.au"
        .CC = "bloke3@whereiwork.com.au"
        .BCC = ""
        .Subject = strSubject
        .HTMLBody = strbody & "<br>" & Signature
        .Importance = olImportanceHigh
        .ReadReceiptRequested = True
        .Send    'or use .Display
    End With

    On Error GoTo 0
          
          
          
       End If
    End If
End Sub


Function GetBoiler(ByVal sFile As String) As String
'**** Kusleika
    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
 
Last edited:

Watch MrExcel Video

Forum statistics

Threads
1,118,863
Messages
5,574,720
Members
412,615
Latest member
John_W_Excel
Top