Sending an Outlook task to multiple recipients

[Vonsteiner]

Hello,

I have code set up to create and send a task to one recipient, but am having trouble getting to send to multiple recipients.

   With CreateObject("Outlook.Application").CreateItem(3)
        .Assign
        .Subject = Cells(2, 1) & " XXX Completed"
        .StartDate = Now
        .DueDate = (Now + 7)
        .ReminderSet = True
        .ReminderTime = .DueDate - 1 + TimeValue("8:30AM")
        .Body = "Please create the folder for " & Cells(2, 1) & ". Make sure to include " & _
        "all the necessary folders.  Thank you."
        .Recipients.Add ("name@generic.com")
        .Save
    End With

This works perfectly for one recipient, but not for multiple. I have tried duplicating the above code with a different name in the '.Reciepients.Add' area in the second set, but that didn't work. I have tried adding a second name to the '.Recipients.Add' code, both in the () and outside to no avail. Any help would be greatly appreciated.

Thank you
Michael

 

[navic]

Try some of this below

Sub Mail_workbook_Outlook()
'Working in 2000-2010
'This example send the last saved version of the Activeworkbook
'https://www.rondebruin.nl/win/s1/outlook/amail1.htm
    Dim OutApp As Object
    Dim OutMail As Object
    Dim emailRng As Range, cl As Range
    Dim sTo As String

    Set emailRng = Worksheets("YourSheetNameTab").Range("O2:O10") 'email addresses

    For Each cl In emailRng
        sTo = sTo & ";" & cl.Value
    Next

    sTo = Mid(sTo, 2)

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

    On Error Resume Next
    With OutMail
        .To = sTo
        .CC = "person1@email.com;person2@email.com"
        .BCC = ""
        .Subject = "Subject: #" & Worksheets("YourSheetNameTab").Range("Q2") 'this is cell where is subject of message
        .Body = "Attached to this email is file #" & _
        Worksheets("YourSheetNameTab").Range("Q2") & _
        ". This is my fixed text"
        .Attachments.Add ActiveWorkbook.FullName 'attached file - complete workbook
         'You can add other files also like this
         '.Attachments.Add ("C:\test.txt")
        .Display ' or Send
    End With
    On Error GoTo 0

    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub

or

'Option Explicit

Sub Mail_Selection_Range_Outlook_Body()
'https://www.rondebruin.nl/win/s1/outlook/amail1.htm
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object

Set rng = Nothing
' Only send the visible cells in the selection.

Set rng = Sheets("YourSheetNameTab").Range("I1:M20").SpecialCells(xlCellTypeVisible)

If rng Is Nothing Then
    MsgBox "The selection is not a range or the sheet is protected. " & _
           vbNewLine & "Please correct and try again.", vbOKOnly
    Exit Sub
End If

With Application
    .EnableEvents = False
    .ScreenUpdating = False
End With

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


With OutMail
    .To = ThisWorkbook.Sheets("YourSheetNameTab").Range("O2").Value
    .CC = ThisWorkbook.Sheets("YourSheetNameTab").Range("O3").Value
    .BCC = ""
    .Subject = "This is the Subject line"
    .HTMLBody = RangetoHTML(rng)
    ' In place of the following statement, you can use ".Display" to
    ' display the e-mail message.
    .Display 'Send
End With
On Error GoTo 0

With Application
    .EnableEvents = True
    .ScreenUpdating = True
End With

Set OutMail = Nothing
Set OutApp = Nothing
End Sub


Function RangetoHTML(rng As Range)
' By Ron de Bruin.
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook

    TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

    'Copy the range and create a new workbook to past the data in
    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With

    'Publish the sheet to a htm file
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With

    'Read all data from the htm file into RangetoHTML
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.ReadAll
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")

    'Close TempWB
    TempWB.Close savechanges:=False

    'Delete the htm file we used in this function
    Kill TempFile

    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function

or

Sub Mail_sheets()
'https://docs.microsoft.com/en-us/previous-versions/office/developer/office-2003/aa203718(v=office.11)
    Dim MyArr As Variant
    Dim last As Long
    Dim shname As Long
    Dim a As Integer
    Dim Arr() As String
    Dim N As Integer
    Dim strdate As String
    For a = 1 To 253 Step 3
        If ThisWorkbook.Sheets("mail").Cells(1, a).Value = "" Then 
            Exit Sub
        End
        Application.ScreenUpdating = False
        last = ThisWorkbook.Sheets("mail").Cells(Rows.Count, _
            a).End(xlUp).Row
        N = 0
        For shname = 1 To last
            N = N + 1
            ReDim Preserve Arr(1 To N)
            Arr(N) = ThisWorkbook.Sheets("mail").Cells(shname, a).Value
        Next shname
        ThisWorkbook.Sheets(Arr).Copy
        strdate = Format(Date, "dd-mm-yy") & " " & _
            Format(Time, "h-mm-ss")
        ActiveWorkbook.SaveAs "Part of " & ThisWorkbook.Name _
            & " " & strdate & ".xls"
        With ThisWorkbook.Sheets("mail")
            MyArr = .Range(.Cells(1, a + 1), .Cells(Rows.Count, _
                a + 1).End(xlUp))
        End With
        ActiveWorkbook.SendMail MyArr, ThisWorkbook.Sheets("mail").Cells(1, a + 2).Value
        ActiveWorkbook.ChangeFileAccess xlReadOnly
        Kill ActiveWorkbook.FullName
        ActiveWorkbook.Close False
        Application.ScreenUpdating = True
    Next a
End Sub