Need to add multiple (more than two) email recipients in vba code...

Try putting a space after the semicolon. I use semicolons to separate email address and it works.

Kevin

I get a "Run Time Error, Automation Error" when I do that.

Tried this, doesn't work with the THIRD one.

If Forwarder1 = "AGI" Then
Email = "Packingslip@limitedbrands.com"
Email2 = "rlambotte@limitedbrands.com"
Eamil3 = "6142076873@cingularme.com"
Else
Email = "rlambotte@limitedbrands.com"
Email2 = ""
End If


Set objMsg = objNS.Application.CreateItem(olMailItem)
With objMsg
.Display
'Adds main recipient
'.Recipients.Add "lambotte, ronny"
.Recipients.Add Email
'Add CC recipient

If Email2 <> Null Then
Set objRecipient = .Recipients.Add(Email2)
objRecipient.Type = olCC
End If

If Email3 <> Null Then
Set objRecipient = .Recipients.Add(Email3)
objRecipient.Type = olCC
End If

Semicolons almost always work.  If it still gives you trouble, just add your recipients one at a time using
the Add method of the Recipients collection.

Here is the routine I use to send emails through Outlook. It works with any number of email address passed as variant arrays.

Public Sub SendOutlookMail( _
      ByVal ToRecipients As Variant, _
      ByVal CCRecipients As Variant, _
      ByVal BCCRecipients As Variant, _
      ByVal Subject As String, _
      ByVal Body As String, _
      Optional ByVal UseHTML As Boolean = False _
   )

' Send an email using Outlook. The email is placed in Outlook's Drafts folder. Each
' generated email has to be opened and sent manually.

   Dim OutlookApplication As Object
   Dim Mail As Object
   
   If Not IsArray(ToRecipients) Then ToRecipients = Array(ToRecipients)
   If Not IsArray(CCRecipients) Then CCRecipients = Array(CCRecipients)
   If Not IsArray(BCCRecipients) Then BCCRecipients = Array(BCCRecipients)
   
   Set OutlookApplication = CreateObject("Outlook.Application")
   
   Set Mail = OutlookApplication.CreateItem(olMailItem)
   With Mail
      .To = Join(ToRecipients, "; ")
      .CC = Join(CCRecipients, "; ")
      .BCC = Join(BCCRecipients, "; ")
      .Subject = Subject
      On Error Resume Next
      .EditorType = 1 ' 2000
      .BodyFormat = 1 ' 2002, olFormatPlain
      On Error GoTo 0
      If UseHTML Then
         .HTMLBody = Body
      Else
         .Body = Body
      End If
      .Save
   End With
   
   Set Mail = Nothing
   Set OutlookApplication = Nothing

End Sub

Kevin

How do I do that, matthewspatrick:

I tried this...

If Email2 <> Null Then
 Set objRecipient = .Recipients.Add(Email2)
  If Email3 <> Null Then
    .Recipients.Add (Email3)
  End If
End If
objRecipient.Type = olCC

To create a variant array on the fly:

   Dim ToAddresses As Variant
   ToAddresses = Array()
   Redim Preserve ToAddresses(LBound(ToAddresses) To UBound(ToAddresses) + 1)
   ToAddresses(UBound(ToAddresses)) = EMail
   If Email2 <> Null Then
      Redim Preserve ToAddresses(LBound(ToAddresses) To UBound(ToAddresses) + 1)
      ToAddresses(UBound(ToAddresses)) = Email2
   End If
   If Email3 <> Null Then
      Redim Preserve ToAddresses(LBound(ToAddresses) To UBound(ToAddresses) + 1)
      ToAddresses(UBound(ToAddresses)) = Email3
   End If

Kevin

zorvek:
Thanks for helping, I think this might be a solution, but I am getting a Type mismatch error, and when I step through the code, After IF EMAIL2<> Null Then, it skips the IF part right after. Same with EMAIL3, it thinks it is FALSE.  I declared EMAIL, 2 and 3 and String.

  Dim ToAddresses As Variant
   ToAddresses = Array()
   Redim Preserve ToAddresses(LBound(ToAddresses) To UBound(ToAddresses) + 1)
   ToAddresses(UBound(ToAddresses)) = EMail
   If Len(Email2) > 0 Then
      Redim Preserve ToAddresses(LBound(ToAddresses) To UBound(ToAddresses) + 1)
      ToAddresses(UBound(ToAddresses)) = Email2
   End If
   If Len(Email3) > 0 Then
      Redim Preserve ToAddresses(LBound(ToAddresses) To UBound(ToAddresses) + 1)
      ToAddresses(UBound(ToAddresses)) = Email3
   End If

Kevin

The code for the email part doesn't error out any more, thanks. But the Run Time Error 13, Type mismatch is still there.
Issue 1:
  ReDim Preserve ToAddresses(
the ToAddesses goes to empty and adds the next email after that in line. Looses the previous email address.
Issue2:
Also, the code throws an error
here with the Run Time Error, Type mismatch...using the array in the recipients line...
.Recipients.Add ToAddresses


Public objOutlook As Object
Public objNS As Outlook.Namespace
Public objMsg As Outlook.MailItem
Public objRecipient As Outlook.Recipient

Sub SendEmail()
Dim Email As String
Dim Email2 As String
Dim Email3 As String

'Sets the objOutlook & objNS public variables to the user's Outlook session.
'This will blow up if Outlook is not running.
Set objOutlook = GetObject(, "Outlook.Application")
Set objNS = objOutlook.GetNamespace("MAPI")
'Gets the user's name from Outlook, finds just the first name & places that into
'a public variable (strCurrentUser) & puts the full name (First Last) into
'a public variable (strCurrentUserFull).
'Used in other processes
strCurrentUserFull = objNS.CurrentUser
intChar = InStr(1, strCurrentUserFull, ",")
strCurrentUser = Mid(strCurrentUserFull, intChar + 2)
strCurrentUserFull = strCurrentUser & " " & Left(strCurrentUserFull, intChar - 1)
Dim Forwarder As String
Forwarder1 = "AGI"
Forwarder2 = "BAX"
Dim TodayDate As String
Dim todayyear As String
Dim todaymonth As String
Dim todayday As String
Dim todayhour As String
todaymonth = Month(Date)
todaymonth = IIf(Len(todaymonth) = 2, todaymonth, "0" & todaymonth)
todayday = Day(Date)
todayday = IIf(Len(todayday) = 2, todayday, "0" & todayday)
todayyear = Year(Date)
'todayhour = Hour(Now())
todayhour = 10
TodayDate = todayyear & "-" & todaymonth & "-" & todayday & "-" & todayhour


Dim sPath As String, sFileNm As String
sPath = "C:\Dsr\"
sFileNm = Dir(sPath, vbNormal) 'Get the first file from the specified directory

'Start a loop
Do While sFileNm <> ""
 'If the file has a dbf extension then print the file name
  If Right(sFileNm, 3) = "xls" Then
  '     Debug.Print sFileNm
   
Forwarder1 = Left(sFileNm, 3)

If Forwarder1 = "AGI" Then
Email = "Packingslip@limitedbrands.com"
Email2 = "rlambotte@limitedbrands.com"
Email3 = "6142076873@cingularme.com"
Else
Email = "rlambotte@limitedbrands.com"
Email2 = ""
End If

Dim ToAddresses As Variant
   ToAddresses = Array()
   ReDim Preserve ToAddresses(LBound(ToAddresses) To UBound(ToAddresses) + 1)
   ToAddresses(UBound(ToAddresses)) = Email
   If Len(Email2) > 0 Then
      ReDim Preserve ToAddresses(LBound(ToAddresses) To UBound(ToAddresses) + 1)
      ToAddresses(UBound(ToAddresses)) = Email2
   End If
   If Len(Email3) > 0 Then
      ReDim Preserve ToAddresses(LBound(ToAddresses) To UBound(ToAddresses) + 1)
      ToAddresses(UBound(ToAddresses)) = Email3
   End If


Set objMsg = objNS.Application.CreateItem(olMailItem)
With objMsg
.Display
'Adds main recipient
'.Recipients.Add "lambotte, ronny"
.Recipients.Add ToAddresses
'Add CC recipient
'Set objRecipient = .Recipients.Add(Email2)
'objRecipient.Type = olCC

.Subject = "TEST FOR DSR - TEST FOR DSR - EMAIL"
.Body = "Attached are the tracking reports for LATE PO and..." & TodayDate
Dim Name As String
Name = "c:\dsr\" & Forwarder1 & " EDI Mismatch Per DSR  " & TodayDate & ".xls"
.Attachments.Add Name, , 80
.Send
End With
    End If
    sFileNm = Dir
Loop


Set objMsg = Nothing
MsgBox "Emails Done", _
vbInformation, "Email Sent"
End Sub

Thank you so much.