Agregar correos en copia en una macro que envía correos a gmail
Estoy creando un código que me envía un correo de gmail desde excel, lo que hace la macro es trabajar con el cdo library crea un archivo Pdf temporal de un rango de celdas y le da el nombre a ese archivo segun otra celda y hoja en especifico, luego lo adjunta y pone como contenido del correo otra celda especifica. Mi problema radica aqui:
'Información para el correo
Set Email = New CDO.Message
Remitente = "[email protected]"
Pass = "xxxx"
Destinatario = "[email protected]"
Asunto = Sheets("203-301").Range("G3")
Cuerpo = Sheets("203-301").Range("G6")
La macro solo envía el correo a un destinatario, es decir de 1 persona a 1 persona. Yo quiero que también tenga la opción de poner con copia (CC) y con copia oculta (CCO) les adjunto el código completo. Ojala puedan ayudarme, muchas gracias.
MACRO:
Sub ENVIO_DE_CORREOS()
'Definiciones para el correo
Dim Email As CDO.Message
Dim Remitente As String
Dim Pass As String
Dim Destinatario As String
Dim Asunto As String
Dim Cuerpo As String
'Definiciones para archivo
Dim RutaTemporal As String
Dim NombreTemporal As String
Dim RutaCompleta
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'Creación del archivo temporal
RutaTemporal = Environ$("temp") & "\"
NombreTemporal = Sheets("203-301").Range("G8") & ".pdf"
RutaCompleta = RutaTemporal & NombreTemporal
On Error GoTo Err
Sheets("203-301").Range("A1:F17").ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=RutaCompleta, _
quality:=xlQualityStandard, _
includedocproperties:=True, _
ignoreprintareas:=False, _
openafterpublish:=False
'Información para el correo
Set Email = New CDO.Message
Remitente = "[email protected]"
Pass = "xxxx"
Destinatario = "[email protected]"
Asunto = Sheets("203-301").Range("G3")
Cuerpo = Sheets("203-301").Range("G6")
Email.Configuration.Fields(cdoSMTPServer) = "smtp.gmail.com"
Email.Configuration.Fields(cdoSendUsingMethod) = 2
With Email.Configuration.Fields
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = CLng(25)
.Item("http://schemas.microsoft.com/cdo/" & "configuration/smtpauthenticate") = Abs(1)
.Item("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = 30
.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = Remitente
.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = Pass
.Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
End With
With Email
.To = Destinatario
.From = Remitente
.Subject = Asunto
.TextBody = Cuerpo
.AddAttachment RutaCompleta
.Configuration.Fields.Update
On Error Resume Next
.Send
End With
If Err.Number = 0 Then
MsgBox "Se enviaron los correos a Tipuanas con Exito", vbInformation, "RODACORP S.A.C"
Else
MsgBox "Se produjo el siguiente error: " & vbNewLine & _
Err.Description, vbCritical, "Error No. " & Err.Number
End If
On Error GoTo 0
Kill RutaCompleta
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
Exit Sub
Err:
MsgBox Err.Description, vbCritical + vbOKOnly, Err.Number
End Sub