Add a cc field to email code

Hi.

Below i have some code that works with lotus notes and fires off emails.

Im looking to add a cc field

Currently the "to" field searches column K - I can add the cc email addresses to field P

Can anyone tag that onto the below code?

Thanks
Seamus


Public rng As Range, cell As Range

Sub get_data_Sectors()

'testemail

    Dim lrow As Long

    lrow = Cells(Cells.Rows.Count, "k").End(xlUp).Row

    Set rng = Range("K5:K" & lrow)

For Each cell In rng
         If cell.Value <> "" And cell.Offset(0, 1).Value Like "*abc*" Then send_email_Sectors cell.Value, cell.Offset(0, 1).Value
 Next cell
    
    MsgBox "Files sent"

End Sub

Sub send_email_Sectors(str As String, str1 As String)



Dim MailDbName As String
Dim Recipient As Variant
Dim ccRecipient As String
Dim Attachment1 As String
Dim Attachment2 As String
Dim Attachment3 As String
Dim Attachment4 As String
Dim Attachment5 As String
Dim Attachment6 As String
Dim Attachment7 As String
Dim Attachment8 As String
Dim Attachment9 As String
Dim Attachment10 As String
Dim Attachment11 As String
Dim Attachment12 As String
Dim Attachment13 As String
Dim Attachment14 As String
Dim Attachment15 As String
Dim Attachment16 As String
Dim Attachment17 As String
Dim Attachment18 As String
Dim Maildb As Object
Dim MailDoc As Object
Dim AttachME As Object
Dim AttachME2 As Object
Dim AttachME3 As Object
Dim AttachME4 As Object
Dim AttachME5 As Object
Dim AttachME6 As Object
Dim AttachME7 As Object
Dim AttachME8 As Object
Dim AttachME9 As Object
Dim AttachME10 As Object
Dim AttachME11 As Object
Dim AttachME12 As Object
Dim AttachME13 As Object
Dim AttachME14 As Object
Dim AttachME15 As Object
Dim AttachME16 As Object
Dim AttachME17 As Object
Dim AttachME18 As Object
Dim Session As Object
Dim EmbedObj1 As Object
Dim EmbedObj2 As Object
Dim EmbedObj3 As Object
Dim EmbedObj4 As Object
Dim EmbedObj5 As Object
Dim EmbedObj6 As Object
Dim EmbedObj7 As Object
Dim EmbedObj8 As Object
Dim EmbedObj9 As Object
Dim EmbedObj10 As Object
Dim EmbedObj11 As Object
Dim EmbedObj12 As Object
Dim EmbedObj13 As Object
Dim EmbedObj14 As Object
Dim EmbedObj15 As Object
Dim EmbedObj16 As Object
Dim EmbedObj17 As Object
Dim EmbedObj18 As Object

Dim stSignature As String

With Application
.ScreenUpdating = False
.DisplayAlerts = False

' Open and locate current LOTUS NOTES User

Set Session = CreateObject("Notes.NotesSession")
UserName = Session.UserName
Set Maildb = Session.GetDatabase("", MailDbName)
If Maildb.IsOpen = True Then
Else
Maildb.OPENMAIL
End If

' Create New Mail and Address Title Handlers

Set MailDoc = Maildb.CREATEDOCUMENT


MailDoc.Form = "Memo"


' Select range of e-mail addresses
Recipient = Array(str1)
MonthDate = Format(ActiveSheet.Range("O5"), "MMMM yyyy")
MailDoc.Principal = Range("R5").Value
MailDoc.SendTo = Recipient
MailDoc.Subject = "Sector Horis Report " & MonthDate

Set mailbody = MailDoc.CreateRichTextItem("Body")
Call mailbody.AppendText("Please find attached your Sector Loris Reports for " & MonthDate & ". ")
Call mailbody.Addnewline(1)
Call mailbody.Addnewline(1)
Call mailbody.AppendText("I. ")
Call mailbody.Addnewline(1)
Call mailbody.Addnewline(1)
Call mailbody.AppendText("")
Call mailbody.Addnewline(1)
Call mailbody.Addnewline(1)
Call mailbody.AppendText(":")
Call mailbody.Addnewline(1)
Call mailbody.Addnewline(1)
Call mailbody.AppendText("f")
Call mailbody.Addnewline(1)
Call mailbody.Addnewline(1)
Call mailbody.AppendText("If you have received this email in error, please delete and contact the regional mailbox in order for you to be removed from future monthly automated mailings.")
Call mailbody.Addnewline(2)

' Select Workbook to Attach to E-Mail

Dim stfilename1 As String, stfilename2 As String, stfilename3 As String, stfilename4 As String, stfilename5 As String, stfilename6 As String, stfilename7 As String, stfilename8 As String, stfilename9 As String, stfilename10 As String, stfilename11 As String, stfilename12 As String, stfilename13 As String, stfilename14 As String, stfilename15 As String, stfilename16 As String, stfilename17 As String, stfilename18 As String
Dim stpath As String



stpath = "R:\abc\loris Info\loris_Project\xyz\" & Format(Cells(5, 15).Value, "mmm-yy") & "\Output\Sector\" & Cells(5, 13).Value & ""

'For Each stItem In Array("GB-CORP", "GB-FI", "CMB-LC", "CMB-MME")
 '   stFilenameTmp = str & " - " & stItem & " (" & Format(Cells(5, 15).Value, "mmm-yy") & ") - "" .pdf"
    'stFilenameTmp = str & " - " & stItem & " (" & Format(Cells(5, 15).Value, "mmm-yy") & ") - Booked .pdf"
    'stFilenameTmp = str & " - " & stItem & " (" & Format(Cells(5, 15).Value, "mmm-yy") & ") - Booked Region .pdf"
    'stFilenameTmp = str & " - " & stItem & " (" & Format(Cells(5, 15).Value, "mmm-yy") & ") - Managed.xlsx"
    'stFilenameTmp = str & " - " & stItem & " (" & Format(Cells(5, 15).Value, "mmm-yy") & ") - Booked.xlsx"
    'stFilenameTmp = str & " - " & stItem & " (" & Format(Cells(5, 15).Value, "mmm-yy") & ") - Booked Region.xlsx"
  '  If Len(Dir(stpath & "\" & stFilenameTmp)) > 0 Then
   '     stComp = stItem
   '     Exit For
   ' End If
'Next
    stfilename1 = str & stComp & Cells(5, 22) & " (" & Format(Cells(5, 15).Value, "mmm-yy") & ") - Managed .pdf"
    stfilename2 = str & stComp & Cells(5, 22) & " (" & Format(Cells(5, 15).Value, "mmm-yy") & ") - Booked .pdf"
    stfilename4 = str & stComp & Cells(5, 22) & " (" & Format(Cells(5, 15).Value, "mmm-yy") & ") - Managed.xlsx"
    stfilename5 = str & stComp & Cells(5, 22) & " (" & Format(Cells(5, 15).Value, "mmm-yy") & ") - Booked.xlsx"
  

MailDoc.SaveMessageOnSend = True
Attachment1 = stpath & "\" & stfilename1

If Attachment1 <> "" Then
On Error Resume Next
Set AttachME = MailDoc.CreateRichTextItem("attachment1")
Set EmbedObj1 = AttachME.EmbedObject(1454, "attachment1", Attachment1, "") 'Required File Name
On Error Resume Next
End If

Attachment2 = stpath & "\" & stfilename2 '"C:\YourFile.xls" ' Required File Name

If Attachment2 <> 0 Then
On Error Resume Next
Set AttachME2 = MailDoc.CreateRichTextItem("attachment2")
Set EmbedObj2 = AttachME.EmbedObject(1454, "attachment2", Attachment2, "") 'Required File Name
On Error Resume Next
End If

Attachment3 = stpath & "\" & stfilename3 '"C:\YourFile.xls" ' Required File Name

If Attachment3 <> "" Then
On Error Resume Next
Set AttachME3 = MailDoc.CreateRichTextItem("attachment3")
Set EmbedObj3 = AttachME.EmbedObject(1454, "attachment3", Attachment3, "") 'Required File Name
On Error Resume Next
End If

Attachment4 = stpath & "\" & stfilename4 '"C:\YourFile.xls" ' Required File Name

If Attachment4 <> "" Then
On Error Resume Next
Set AttachME = MailDoc.CreateRichTextItem("attachment4")
Set EmbedObj4 = AttachME.EmbedObject(1454, "attachment4", Attachment4, "") 'Required File Name
On Error Resume Next
End If

Attachment5 = stpath & "\" & stfilename5 '"C:\YourFile.xls" ' Required File Name

If Attachment5 <> 0 Then
On Error Resume Next
Set AttachME5 = MailDoc.CreateRichTextItem("attachment5")
Set EmbedObj5 = AttachME.EmbedObject(1454, "attachment5", Attachment5, "") 'Required File Name
On Error Resume Next
End If

Attachment6 = stpath & "\" & stfilename6 '"C:\YourFile.xls" ' Required File Name

If Attachment6 <> "" Then
On Error Resume Next
Set AttachME6 = MailDoc.CreateRichTextItem("attachment6")
Set EmbedObj6 = AttachME.EmbedObject(1454, "attachment6", Attachment6, "") 'Required File Name
On Error Resume Next
End If



Attachment7 = stpath & "\" & stfilename6 '"C:\YourFile.xls" ' Required File Name

If Attachment7 <> "" Then
On Error Resume Next
Set AttachME7 = MailDoc.CreateRichTextItem("attachment7")
Set EmbedObj7 = AttachME.EmbedObject(1454, "attachment7", Attachment7, "") 'Required File Name
On Error Resume Next
End If

Attachment8 = stpath & "\" & stfilename8 '"C:\YourFile.xls" ' Required File Name

If Attachment8 <> "" Then
On Error Resume Next
Set AttachME8 = MailDoc.CreateRichTextItem("attachment8")
Set EmbedObj6 = AttachME.EmbedObject(1454, "attachment8", Attachment8, "") 'Required File Name
On Error Resume Next
End If

Attachment9 = stpath & "\" & stfilename9 '"C:\YourFile.xls" ' Required File Name

If Attachment9 <> "" Then
On Error Resume Next
Set AttachME9 = MailDoc.CreateRichTextItem("attachment9")
Set EmbedObj9 = AttachME.EmbedObject(1454, "attachment9", Attachment9, "") 'Required File Name
On Error Resume Next
End If

Attachment10 = stpath & "\" & stfilename10 '"C:\YourFile.xls" ' Required File Name

If Attachment10 <> "" Then
On Error Resume Next
Set AttachME10 = MailDoc.CreateRichTextItem("attachment10")
Set EmbedObj10 = AttachME.EmbedObject(1454, "attachment10", Attachment10, "") 'Required File Name
On Error Resume Next
End If

Attachment11 = stpath & "\" & stfilename11 '"C:\YourFile.xls" ' Required File Name

If Attachment11 <> "" Then
On Error Resume Next
Set AttachME11 = MailDoc.CreateRichTextItem("attachment11")
Set EmbedObj11 = AttachME.EmbedObject(1454, "attachment11", Attachment11, "") 'Required File Name
On Error Resume Next
End If

Attachment12 = stpath & "\" & stfilename12 '"C:\YourFile.xls" ' Required File Name

If Attachment12 <> "" Then
On Error Resume Next
Set AttachME12 = MailDoc.CreateRichTextItem("attachment12")
Set EmbedObj12 = AttachME.EmbedObject(1454, "attachment12", Attachment12, "") 'Required File Name
On Error Resume Next
End If

Attachment13 = stpath & "\" & stfilename13 '"C:\YourFile.xls" ' Required File Name

If Attachment13 <> "" Then
On Error Resume Next
Set AttachME13 = MailDoc.CreateRichTextItem("attachment13")
Set EmbedObj13 = AttachME.EmbedObject(1454, "attachment13", Attachment13, "") 'Required File Name
On Error Resume Next
End If

Attachment14 = stpath & "\" & stfilename14 '"C:\YourFile.xls" ' Required File Name

If Attachment14 <> "" Then
On Error Resume Next
Set AttachME14 = MailDoc.CreateRichTextItem("attachment14")
Set EmbedObj14 = AttachME.EmbedObject(1454, "attachment14", Attachment14, "") 'Required File Name
On Error Resume Next
End If

Attachment15 = stpath & "\" & stfilename15 '"C:\YourFile.xls" ' Required File Name

If Attachment15 <> "" Then
On Error Resume Next
Set AttachME15 = MailDoc.CreateRichTextItem("attachment15")
Set EmbedObj15 = AttachME.EmbedObject(1454, "attachment15", Attachment15, "") 'Required File Name
On Error Resume Next
End If

Attachment16 = stpath & "\" & stfilename16 '"C:\YourFile.xls" ' Required File Name

If Attachment16 <> "" Then
On Error Resume Next
Set AttachME16 = MailDoc.CreateRichTextItem("attachment16")
Set EmbedObj16 = AttachME.EmbedObject(1454, "attachment16", Attachment16, "") 'Required File Name
On Error Resume Next
End If

Attachment17 = stpath & "\" & stfilename17 '"C:\YourFile.xls" ' Required File Name

If Attachment17 <> "" Then
On Error Resume Next
Set AttachME17 = MailDoc.CreateRichTextItem("attachment17")
Set EmbedObj17 = AttachME.EmbedObject(1454, "attachment17", Attachment17, "") 'Required File Name
On Error Resume Next
End If

Attachment18 = stpath & "\" & stfilename18 '"C:\YourFile.xls" ' Required File Name

If Attachment18 <> "" Then
On Error Resume Next
Set AttachME18 = MailDoc.CreateRichTextItem("attachment18")
Set EmbedObj18 = AttachME.EmbedObject(1454, "attachment18", Attachment18, "") 'Required File Name
On Error Resume Next
End If

Attachment19 = stpath & "\" & stfilename19 '"C:\YourFile.xls" ' Required File Name

If Attachment19 <> "" Then
On Error Resume Next
Set AttachME19 = MailDoc.CreateRichTextItem("attachment19")
Set EmbedObj19 = AttachME.EmbedObject(1454, "attachment19", Attachment19, "") 'Required File Name
On Error Resume Next
End If

Attachment20 = stpath & "\" & stfilename20 '"C:\YourFile.xls" ' Required File Name

If Attachment20 <> "" Then
On Error Resume Next
Set AttachME20 = MailDoc.CreateRichTextItem("attachment20")
Set EmbedObj20 = AttachME.EmbedObject(1454, "attachment20", Attachment20, "") 'Required File Name
On Error Resume Next
End If

Attachment21 = stpath & "\" & stfilename21 '"C:\YourFile.xls" ' Required File Name

If Attachment21 <> "" Then
On Error Resume Next
Set AttachME21 = MailDoc.CreateRichTextItem("attachment21")
Set EmbedObj21 = AttachME.EmbedObject(1454, "attachment21", Attachment21, "") 'Required File Name
On Error Resume Next
End If

Attachment22 = stpath & "\" & stfilename22 '"C:\YourFile.xls" ' Required File Name

If Attachment22 <> "" Then
On Error Resume Next
Set AttachME22 = MailDoc.CreateRichTextItem("attachment22")
Set EmbedObj22 = AttachME.EmbedObject(1454, "attachment22", Attachment22, "") 'Required File Name
On Error Resume Next
End If

Attachment23 = stpath & "\" & stfilename23 '"C:\YourFile.xls" ' Required File Name

If Attachment23 <> "" Then
On Error Resume Next
Set AttachME23 = MailDoc.CreateRichTextItem("attachment23")
Set EmbedObj23 = AttachME.EmbedObject(1454, "attachment23", Attachment23, "") 'Required File Name
On Error Resume Next
End If

Attachment24 = stpath & "\" & stfilename24 '"C:\YourFile.xls" ' Required File Name

If Attachment24 <> "" Then
On Error Resume Next
Set AttachME24 = MailDoc.CreateRichTextItem("attachment24")
Set EmbedObj24 = AttachME.EmbedObject(1454, "attachment24", Attachment24, "") 'Required File Name
On Error Resume Next
End If





   If Dir(Attachment1) <> "" Or Dir(Attachment2) <> "" Or Dir(Attachment3) <> "" Or Dir(Attachment4) <> "" Or Dir(Attachment5) <> "" Or Dir(Attachment6) <> "" Or Dir(Attachment7) <> "" Or Dir(Attachment8) <> "" Or Dir(Attachment9) <> "" Or Dir(Attachment10) <> "" Or Dir(Attachment11) <> "" Or Dir(Attachment12) <> "" Or Dir(Attachment13) <> "" Or Dir(Attachment14) <> "" Or Dir(Attachment15) <> "" Or Dir(Attachment16) <> "" Or Dir(Attachment17) <> "" Or Dir(Attachment18) <> "" Or Dir(Attachment19) <> "" Or Dir(Attachment20) <> "" Or Dir(Attachment21) <> "" Or Dir(Attachment22) <> "" Or Dir(Attachment23) <> "" Or Dir(Attachment24) <> "" Then
            MailDoc.PostedDate = Now()
            On Error GoTo errorhandler1
            MailDoc.SEND 0, Recipient
        Else
            Cells(cell.Row, "t").Value = "Email attachment is missing for this name"

        End If

Set Maildb = Nothing
Set MailDoc = Nothing
Set AttachME = Nothing
Set AttachME2 = Nothing
Set AttachME3 = Nothing
Set AttachME4 = Nothing
Set AttachME5 = Nothing
Set AttachME6 = Nothing
Set AttachME7 = Nothing
Set AttachME8 = Nothing
Set AttachME9 = Nothing
Set AttachME10 = Nothing
Set AttachME11 = Nothing
Set AttachME12 = Nothing
Set AttachME13 = Nothing
Set AttachME14 = Nothing
Set AttachME15 = Nothing
Set AttachME16 = Nothing
Set AttachME17 = Nothing
Set AttachME18 = Nothing
Set AttachME19 = Nothing
Set AttachME20 = Nothing
Set AttachME21 = Nothing
Set AttachME22 = Nothing
Set AttachME23 = Nothing
Set AttachME24 = Nothing
Set Session = Nothing
Set EmbedObj1 = Nothing
Set EmbedObj2 = Nothing
Set EmbedObj3 = Nothing
Set EmbedObj4 = Nothing
Set EmbedObj5 = Nothing
Set EmbedObj6 = Nothing
Set EmbedObj7 = Nothing
Set EmbedObj8 = Nothing
Set EmbedObj9 = Nothing
Set EmbedObj10 = Nothing
Set EmbedObj11 = Nothing
Set EmbedObj12 = Nothing
Set EmbedObj13 = Nothing
Set EmbedObj14 = Nothing
Set EmbedObj15 = Nothing
Set EmbedObj16 = Nothing
Set EmbedObj17 = Nothing
Set EmbedObj18 = Nothing
Set EmbedObj19 = Nothing
Set EmbedObj20 = Nothing
Set EmbedObj21 = Nothing
Set EmbedObj22 = Nothing
Set EmbedObj23 = Nothing
Set EmbedObj24 = Nothing
.ScreenUpdating = True
.DisplayAlerts = True
End With

errorhandler1:

Set Maildb = Nothing
Set MailDoc = Nothing
Set AttachME = Nothing
Set AttachME2 = Nothing
Set AttachME3 = Nothing
Set AttachME4 = Nothing
Set AttachME5 = Nothing
Set Session = Nothing
Set EmbedObj1 = Nothing
Set EmbedObj2 = Nothing
Set EmbedObj3 = Nothing
Set EmbedObj4 = Nothing
Set EmbedObj5 = Nothing

End Sub

Open in new window

Seamus2626Asked:
Who is Participating?

[Product update] Infrastructure Analysis Tool is now available with Business Accounts.Learn More

x
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Ryan ChongBusiness Systems Analyst , ex-Senior Application EngineerCommented:
Sjef BosmanGroupware ConsultantCommented:
indeed:
     maildoc.CopyTo= ...
     maildoc.BlindCopyTo= ...

In both cases, use arrays if you want to set multiple addresses.

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
Seamus2626Author Commented:
Im a novice VB programmer - is it possible to put this into my code, or instruct me where it should go?


Thanks
Determine the Perfect Price for Your IT Services

Do you wonder if your IT business is truly profitable or if you should raise your prices? Learn how to calculate your overhead burden with our free interactive tool and use it to determine the right price for your IT services. Download your free eBook now!

Sjef BosmanGroupware ConsultantCommented:
I'm not a VB programmer at all, but here my guesses:

Sub send_email_Sectors(str As String, str1 As String, str2 As String)

Dim CC As Variant
:
:

' Select range of e-mail addresses
Recipient = Split(str1, ",")
CC= Split(str2, ",")
MonthDate = Format(ActiveSheet.Range("O5"), "MMMM yyyy")
MailDoc.Principal = Range("R5").Value
MailDoc.SendTo = Recipient
MailDoc.CopyTo = CC
MailDoc.Subject = "Sector Horis Report " & MonthDate

Open in new window


If you use Split() you can use commas in your recipient or CC strings to separate multiple recipients.
Seamus2626Author Commented:
Hi,

I have attached the structure of my spreadsheet to give more colour to the problem!

Thanks
Email-Burst-Tool-SPT.xlsm
Sjef BosmanGroupware ConsultantCommented:
EE-rules: you do the programming, we give the advice.

The code I gave above contains the modifications required to make it work.

1) add a parameter to the mail function, so you can pass the CC string
2) add the CopyTo field to the document, and set its value

You'll have to adapt the call to the mail function yourself (add the 3rd parameter, CC).
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Lotus IBM

From novice to tech pro — start learning today.