Want to protect your cyber security and still get fast solutions? Ask a secure question today.Go Premium

x
  • Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 968
  • Last Modified:

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

0
kasimir2008
Asked:
kasimir2008
  • 6
  • 5
1 Solution
 
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
 
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
Industry Leaders: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

 
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
 
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
 
kasimir2008Author Commented:
Thank you so much.
0

Featured Post

Industry Leaders: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

  • 6
  • 5
Tackle projects and never again get stuck behind a technical roadblock.
Join Now