Send multiple emails in same event

Greetings everyone

I would like to automatically send two completely separate emails using two Outlook "Application_Reminder" events. However, I understand that it's only possible to have one of this type of event. Therefore, is there a way to combine two, or more, emails in a single event?
This is the sort of thing I'm trying to do:

Private Sub Application_Reminder(ByVal Item As Object)
Dim xMailItem As MailItem
Dim strbody As String

If Item.Class <> OlObjectClass.olTask Then Exit Sub
If Item.Categories <> "Recurring Email" Then Exit Sub
Set xMailItem = Outlook.Application.CreateItem(olMailItem)

'1st email
With xMailItem
.Subject = "Monthly Reminder"
.To = "address1-dot-com"
.Body = "Text for team A to read."
.SendUsingAccount = Session.Accounts("an-address-dot-com")
.Send
End With

'2nd email
With xMailItem
.Subject = "Monthly Reminder"
.To = "address2-dot-com"
.Body = "Text for team B to read."
.SendUsingAccount = Session.Accounts("a-different-address.com")
.Send
End With

'3rd email ….etc…
End Sub

Not to worry guys, I have managed to work this one out. Thanks.

Dear Andy,

How you managed your above code. Can you please explain me. Because I am doing the same concept.

My code is here

Code:

---

Option ExplicitSub EmailTrainingValue()
 
 'Variable declaration
Dim oApp As Object, _
oMail As Object, _
WB As Workbook, _
FileName As String
Dim MailSub As String
Dim MailTxt As String
Dim MailTo As String
Dim MailSub1 As String
Dim MailTxt1 As String
Dim Mail1To1 As String
Dim lRow As Long
Dim lCol As Long
Dim MR As Range, Cell As Range
Dim mySheet As String
Dim TempFilePath As String
Dim TempFileName As String
Dim FileFullPath As String
 
 
 '-----------------------Creatte Email List---------------
 Dim sh As Worksheet, rng As Range, c As Range, s As String
 Set sh = Sheets("Data")
 s = ""
 With sh
 Set rng = .Range("O9") '.SpecialCells(xlCellTypeConstants, 23)
 For Each c In rng.Cells
 s = s & c & ";"
 Next c
 End With
 s = Left(s, Len(s) - 1)
 '--------------------End Email List-----------------------
 '************************************************* ********
 'Set email details; Comment out if not required
 MailTo = s
 Const MailCC = "some2@someone.com"
 Const MailBCC = "some3@someone.com"
 MailSub = " Oil Service for your  " & mySheet & " Machine"
 MailTxt = "Dear Sir," & vbLf & vbLf & "Please fine here with attached Training conducted details on  for "
 '************************************************* ********
 
  '************************************************* ********
 'Set email details; Comment out if not required
 Mail1To1 = "spares.bangalore@gmail.com"
 'Const MailCC = "some2@someone.com"
 'Const MailBCC = "some3@someone.com"
 MailSub1 = " Quotation required for oil service"
 MailTxt1 = "Dear Team," & vbLf & vbLf & "Please send quotation for the attachment "
 '************************************************* ********
 
 'Turns off screen updating
 Application.ScreenUpdating = False
 
 'Makes a copy of the active sheet and save it to a temporary file
 Dim wks As Worksheet
 
    mySheet = Worksheets("Data").Cells(9, 2).Value
    TempFilePath = Environ$("temp") & "\"
    TempFileName = mySheet & "Service details.pdf"
    FileFullPath = TempFilePath & TempFileName
    lCol = Cells(9, Columns.Count).End(xlToLeft).Column
    Set MR = Range("C9:N9" & lCol)
    For Each Cell In MR
    If Cell.Value > 25 And Cell.Value <= 50 Then
        'Cell.Interior.Color = VBA.ColorConstants.vbGreen
        Worksheets(mySheet).Range("B2:F24").ExportAsFixedFormat _
        Type:=xlTypePDF, _
        FileName:=FileFullPath, _
        Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, _
        IgnorePrintAreas:=False, _
        OpenAfterPublish:=False
    ElseIf Cell.Value > 400 And Cell.Value <= 500 Then
        'Cell.Interior.Color = VBA.ColorConstants.vbGreen
        Worksheets(mySheet).Range("B26:F65").ExportAsFixedFormat _
        Type:=xlTypePDF, _
        FileName:=FileFullPath, _
        Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, _
        IgnorePrintAreas:=False, _
        OpenAfterPublish:=False
    ElseIf Cell.Value > 900 And Cell.Value <= 1000 Then
        'Cell.Interior.Color = VBA.ColorConstants.vbGreen
        Worksheets(mySheet).Range("B67:F115").ExportAsFixedFormat _
        Type:=xlTypePDF, _
        FileName:=FileFullPath, _
        Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, _
        IgnorePrintAreas:=False, _
        OpenAfterPublish:=False
  End If
  On Error GoTo 0
    Next Cell
   
   
 
 'Creates and shows the outlook mail item
 Set oApp = CreateObject("Outlook.Application")
 Set oMail = oApp.CreateItem(0)
 '1st email
 With oMail
 .To = MailTo
 .Subject = MailSub
 .Body = MailTxt
 .Attachments.Add FileFullPath
 .Display
 End With
 
 '2nd email
 With oMail
 .To = Mail1To1
 .Subject = MailSub1
 .Body = MailTxt1
 .Attachments.Add FileFullPath
 .Display
 End With


 'Restores screen updating and release Outlook
 Application.ScreenUpdating = True
 Set oMail = Nothing
 Set oApp = Nothing
End Sub

---

But i am getting second mail only on the above code.

Can you please correct the code for me

You need to open each letter you need to send and save, usually they are saved by a file with the extension ".eml". Then you need to create a letter and add the saved letters as an attachment, after which you can send. The recipient will receive all letters that need to be forwarded.
Thanks for sharing this process. This really helps me a lot. If you are looking for best antivirus software for your pc then check out the quick comparison of macafee vs avast which is here. https://windowsradar.com/mcafee-vs-avast/