Solved

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

Posted on 2008-10-06
12
946 Views
Last Modified: 2012-06-21
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
Comment
Question by:kasimir2008
  • 6
  • 5
12 Comments
 
LVL 81

Expert Comment

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

Kevin
0
 

Author Comment

by:kasimir2008
ID: 22653325
I get a "Run Time Error, Automation Error" when I do that.
0
 

Author Comment

by:kasimir2008
ID: 22653367
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
 
LVL 92

Expert Comment

by:Patrick Matthews
ID: 22653379
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
 
LVL 81

Expert Comment

by:zorvek (Kevin Jones)
ID: 22653440
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
 

Author Comment

by:kasimir2008
ID: 22653447
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
Is Your Active Directory as Secure as You Think?

More than 75% of all records are compromised because of the loss or theft of a privileged credential. Experts have been exploring Active Directory infrastructure to identify key threats and establish best practices for keeping data safe. Attend this month’s webinar to learn more.

 
LVL 81

Expert Comment

by:zorvek (Kevin Jones)
ID: 22653483
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
 

Author Comment

by:kasimir2008
ID: 22653586
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
 
LVL 81

Expert Comment

by:zorvek (Kevin Jones)
ID: 22653611
  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
 

Author Comment

by:kasimir2008
ID: 22653754
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
 
LVL 81

Accepted Solution

by:
zorvek (Kevin Jones) earned 500 total points
ID: 22653849
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
 

Author Closing Comment

by:kasimir2008
ID: 31503557
Thank you so much.
0

Featured Post

Is Your Active Directory as Secure as You Think?

More than 75% of all records are compromised because of the loss or theft of a privileged credential. Experts have been exploring Active Directory infrastructure to identify key threats and establish best practices for keeping data safe. Attend this month’s webinar to learn more.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Suggested Solutions

Title # Comments Views Activity
Excel 2016 Not Responding Issues 6 29
Excel printing page management 2 25
Google Sheets - Artificial Intelligence 2 21
Macro Lookup 33 20
I was working on a PowerPoint add-in the other day and a client asked me "can you implement a feature which processes a chart when it's pasted into a slide from another deck?". It got me wondering how to hook into built-in ribbon events in Office.
Some code to ensure data integrity when using macros within Excel. Also included code that helps secure your data within an Excel workbook.
The viewer will learn how to use the =DISCRINV command to create a discrete random variable, use this command to model a set of probabilities and outcomes in a Monte Carlo simulation, and learn how to find the standard deviation of a set of probabil…
Excel styles will make formatting consistent and let you apply and change formatting faster. In this tutorial, you'll learn how to use Excel's built-in styles, how to modify styles, and how to create your own. You'll also learn how to use your custo…

863 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

27 Experts available now in Live!

Get 1:1 Help Now