Consulting

Results 1 to 5 of 5

Thread: Send multiple emails in same event

  1. #1
    VBAX Newbie
    Joined
    Mar 2008
    Posts
    5
    Location

    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

  2. #2
    VBAX Newbie
    Joined
    Mar 2008
    Posts
    5
    Location
    Not to worry guys, I have managed to work this one out. Thanks.

  3. #3
    VBAX Contributor
    Joined
    Jun 2019
    Posts
    124
    Location
    Dear Andy,

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

    My code is here

    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

  4. #4
    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. The article: https://thinkmobiles.com/blog/best-adblockers/ describes this process in detail.

  5. #5
    VBAX Newbie
    Joined
    May 2020
    Posts
    1
    Location
    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/

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •