Solved: Sending E-mail with Multiple CCs

[bee]

Hi. I'm using Microsoft Outlook 2000 to send e-mails with multiple recipients, multiple CCs and multiple attachments. I was able to make this code work. It can now send to multiple recipients but I cannot add multiple CCs in the e-mail. The code only adds the last email address that I pass as a parameter. How to I make it add all the CCs?

[vba]Option Compare Database

Public Sub SendMultiple(ByVal aSubject As String, ByVal aRecipients As String, ByVal aRecipients2 As String, _
Optional ByVal aBody As String = "", Optional ByVal aAttachments As String = "", Optional ByVal aRootPath As String = "")

Dim myO As Outlook.Application
Dim mobjNewMessage As Outlook.MailItem
Dim sRecipient, sAttachment, sRecipient2, sDisplayName As String
Dim iMarker, iMarker2, iMarker3 As Integer

On Error GoTo Error_SendEMail
Set myO = CreateObject("Outlook.Application")
Set mobjNewMessage = myO.CreateItem(olMailItem)
mobjNewMessage.subject = aSubject
mobjNewMessage.Body = aBody

' Loop through ; separated recipients
Do
iMarker = InStr(1, aRecipients, ";", vbTextCompare)
If iMarker = 0 Then
sRecipient = aRecipients
Else
sRecipient = Mid(aRecipients, 1, iMarker - 1)
aRecipients = Mid(aRecipients, iMarker + 1)
End If
If Len(sRecipient) <> 0 Then mobjNewMessage.Recipients.Add sRecipient
Loop While iMarker <> 0

' Loop through ; separated CCs
Do
iMarker3 = InStr(1, aRecipients2, ";", vbTextCompare)
If iMarker3 = 0 Then
sRecipient2 = aRecipients2
Else
sRecipient2 = Mid(aRecipients2, 1, iMarker3 - 1)
aRecipients2 = Mid(aRecipients2, iMarker3 + 1)
End If
If Len(sRecipient2) <> 0 Then mobjNewMessage.CC = sRecipient2

Loop While iMarker3 <> 0


' Loop through ; separated attachments - also look for ***DisplayName
Do
iMarker = InStr(1, aAttachments, ";", vbTextCompare)
If iMarker = 0 Then
sAttachment = aAttachments
Else
sAttachment = Mid(aAttachments, 1, iMarker - 1)
aAttachments = Mid(aAttachments, iMarker + 1)
End If
If Len(sAttachment) <> 0 Then
' Is there an embedded display name?
iMarker2 = InStr(1, sAttachment, "***", vbTextCompare)
If iMarker2 <> 0 Then
sDisplayName = Mid(sAttachment, iMarker2 + 3)
sAttachment = aRootPath + Mid(sAttachment, 1, iMarker2 - 1)
If StrComp(Dir(sAttachment), "", vbTextCompare) <> 0 Then _
mobjNewMessage.Attachments.Add sAttachment, , , sDisplayName
Else
If StrComp(Dir(aRootPath + sAttachment), "", vbTextCompare) <> 0 Then _
mobjNewMessage.Attachments.Add aRootPath + sAttachment
End If
End If
Loop While iMarker <> 0

' Send the message
mobjNewMessage.Display

Exit_SendEMail:

Set mobjNewMessage = Nothing
Set myO = Nothing
Exit Sub

Error_SendEMail:
MsgBox Err.Description, , "Send Mail Error"
Resume Exit_SendEMail
End Sub[/vba]

I call this function to send e-mail
[vba]Call SendMultiple("Subject", "recipient1@email.com; recipient2@email.com", _
"carbon1@email.com; carbon2@email.com", "Body here", _
"C:\Documents and Settings\user\Desktop\attachment.xls; C:\Documents and Settings\user\Desktop\attachment2.xls ")[/vba]

[Charlize]

If your list (variable) is separated with a semicolon, why looping through it. Just add your list to the .CC property.

If you feel the need to do a cross post, please let us know, so I wouldn't give you the same advice that you received from somewhere else (or just loose some of my precious time).

http://visualbasic.ittoolbox.com/gro...hments-2192825

Charlize

[bee]

I apologize for not mentioning it.

I'm sorry but I don't think I understood you correctly. You're saying that I do not need a loop to be able to add multiple CCs? The code below only adds carbon2@email.com. It completely disregards carbon1@email.com. Is there a way I can add them both? When I followed what was done in adding multiple recipients in the To field, mobjNewMessage.Recipients.Add sRecipient, it did not work for the CC field. CC does not have a property that lets me add multiple e-mail addresses in the CC field.

[Charlize]

A little variation on your theme. Don't promise a thing and it's not tested ...[VBA]Public Sub SendMultiple(ByVal aSubject As String, ByVal aRecipients As String, _
ByVal aRecipients2 As String, Optional ByVal aBody As String = "", _
Optional ByVal aAttachments As String = "", Optional ByVal aRootPath As String = "")
Dim myO As Outlook.Application
Dim mobjNewMessage As Outlook.MailItem
'If you declare your variables like this, only
'sDisplayName will be String type, other will be variant
Dim sRecipient, sAttachment, sRecipient2, sDisplayName As String
Dim iMarker, iMarker2, iMarker3 As Integer
'*** added this to manipulate the recipient
Dim objOutlookRecip As Outlook.Recipient
'***
On Error GoTo Error_SendEMail
Set myO = CreateObject("Outlook.Application")
Set mobjNewMessage = myO.CreateItem(olMailItem)
mobjNewMessage.Subject = aSubject
mobjNewMessage.Body = aBody

' Loop through ; separated recipients
Do
iMarker = InStr(1, aRecipients, ";", vbTextCompare)
If iMarker = 0 Then
sRecipient = aRecipients
Else
sRecipient = Mid(aRecipients, 1, iMarker - 1)
aRecipients = Mid(aRecipients, iMarker + 1)
End If
If Len(sRecipient) <> 0 Then
'*** added a little bit here
'*** define what kind of type your recipient is
Set objOutlookRecip = mobjNewMessage.Recipients.Add(sRecipient)
objOutlookRecip.Type = olTo
End If
Loop While iMarker <> 0
' Loop through ; separated CCs
Do
iMarker3 = InStr(1, aRecipients2, ";", vbTextCompare)
If iMarker3 = 0 Then
sRecipient2 = aRecipients2
Else
sRecipient2 = Mid(aRecipients2, 1, iMarker3 - 1)
aRecipients2 = Mid(aRecipients2, iMarker3 + 1)
End If
If Len(sRecipient2) <> 0 Then
'*** added a little bit here
'*** define what kind of type your recipient is
Set objOutlookRecip = mobjNewMessage.Recipients.Add(sRecipient)
objOutlookRecip.Type = olCC
End If
Loop While iMarker3 <> 0
' Loop through ; separated attachments - also look for ***DisplayName
Do
iMarker = InStr(1, aAttachments, ";", vbTextCompare)
If iMarker = 0 Then
sAttachment = aAttachments
Else
sAttachment = Mid(aAttachments, 1, iMarker - 1)
aAttachments = Mid(aAttachments, iMarker + 1)
End If
If Len(sAttachment) <> 0 Then
' Is there an embedded display name?
iMarker2 = InStr(1, sAttachment, "***", vbTextCompare)
If iMarker2 <> 0 Then
sDisplayName = Mid(sAttachment, iMarker2 + 3)
sAttachment = aRootPath + Mid(sAttachment, 1, iMarker2 - 1)
If StrComp(Dir(sAttachment), "", vbTextCompare) <> 0 Then
mobjNewMessage.Attachments.Add sAttachment, , , sDisplayName
End If
Else
If StrComp(Dir(aRootPath + sAttachment), "", vbTextCompare) <> 0 Then
mobjNewMessage.Attachments.Add aRootPath + sAttachment
End If
End If
End If
Loop While iMarker <> 0

' Send the message
mobjNewMessage.Display

Exit_SendEMail:

Set mobjNewMessage = Nothing
Set myO = Nothing
Exit Sub

Error_SendEMail:
MsgBox Err.Description, , "Send Mail Error"
Resume Exit_SendEMail
End Sub[/VBA]Charlize

[bee]

Wow! You're amazing Charlize. Thanks so much. Your solution worked. It was able to add multiple e-mail address in the CC field. It never crossed my mind to indicate the type of recipient. I tried mobjNewMessage.CC = sRecipient2 but it only reads the last part. Thanks so much for your help.

[Charlize]

Wow! You're amazing Charlize. Thanks so much. Your solution worked. It was able to add multiple e-mail address in the CC field. It never crossed my mind to indicate the type of recipient. I tried mobjNewMessage.CC = sRecipient2 but it only reads the last part. Thanks so much for your help.

Your welcome. Remember to let the other forum know that your problem is solved (maybe even posting the solution).

Charlize

[bee]

Thanks again. I just did.