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

I have more than two email recipients, how do I get them in there. I tried to seperate them with ";" but still won't work. Thanks for looking at it.


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

Sub SendEmail()
'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)
'*********************************************************NEED HELP HERE OR FURTHER DOWN
If Forwarder1 = "AGI" Then
Email = "Packingslip@limitedbrands.com"
Else
Email = "rlambotte@limitedbrands.com"
End If


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

'*************************************This would work for one more, do I just repeet 2nd and 3rd line below
'Add CC recipient
'Set objRecipient = .Recipients.Add("")
'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

kasimir2008Asked:
Who is Participating?
 
zorvek (Kevin Jones)ConsultantCommented:
When the Preserve phrase is used with a Redim the current array contents are not lost.

Change:

.Recipients.Add ToAddresses

To:

.To = Join(ToAddresses, "; ")

Kevin
0
 
zorvek (Kevin Jones)ConsultantCommented:
Try putting a space after the semicolon. I use semicolons to separate email address and it works.

Kevin
0
 
kasimir2008Author Commented:
I get a "Run Time Error, Automation Error" when I do that.
0
Free Tool: Subnet Calculator

The subnet calculator helps you design networks by taking an IP address and network mask and returning information such as network, broadcast address, and host range.

One of a set of tools we're offering as a way of saying thank you for being a part of the community.

 
kasimir2008Author Commented:
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
0
 
Patrick MatthewsCommented:
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.
0
 
zorvek (Kevin Jones)ConsultantCommented:
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
0
 
kasimir2008Author Commented:
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
0
 
zorvek (Kevin Jones)ConsultantCommented:
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
0
 
kasimir2008Author Commented:
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.
0
 
zorvek (Kevin Jones)ConsultantCommented:
  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
0
 
kasimir2008Author Commented:
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
0
 
kasimir2008Author Commented:
Thank you so much.
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.