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

1 Respuesta

Respuesta
1

Prueba con CC y BCC, as}

Email.From = Trim(UserForm14.ComboBox1) 'remitente
Email.To = Trim(UserForm14.TextBox1) 'destinatario
Email.Subject = UserForm14.TextBox3 'asunto
Email.TextBody = UserForm14.TextBox2 'mensaje
'Email.CC = "[email protected]"
'Email.BCC = "[email protected]"

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas