Usar checkbox para que copie los datos de un textbox al objeto copia de envío de correo

Le envié a su correo copia del archivo del proyecto para que por favor me ayude, con esta situación:

En la hoja envío correo, use un userfrom para digitar previamente el correo y la clave del remitente, de esta manera no queda predefinido ningún correo. Pero no he podido usar un segundo checkbox para que al dar click sobre este automaticamente copie el dato del textbox1 (contiene el correo del remitente) en el objeto .CC. Así que al enviar el correo si se desea una copia del mismo le llegue al remitente.

Private Sub CheckBox1_Click()
If CheckBox1.Value = True Then
    TextBox2.PasswordChar = ""
Else
    TextBox2.PasswordChar = "*"
    End If
End Sub
Private Sub CheckBox2_Click()
End Sub
Private Sub CommandButton1_Click()
If TextBox1.Value = "" Then
MsgBox "Ingrese su correo electrónico para enviarle una respuesta", vbExclamation
Exit Sub
End If
For i = 10 To Range("B" & Rows.Count).End(xlUp).Row
   'Si hay errores, que continúe
    On Error Resume Next
    Set oMsg = CreateObject("CDO.Message")
    Set oconf = CreateObject("CDO.Configuration")
    oconf.Load -1
    Set Flds = oconf.Fields
    With Flds
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
        .Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = TextBox1.Value
        .Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = TextBox2.Value
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.gmail.com"
        .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 465
        .Update
    End With
        Mensaje = Range("B4").Value 'Mensaje del correo
    With oMsg
        Set .Configuration = oconf
        .From = TextBox1.Value
        .To = Cells(i, "B").Value 'listado de destinatarios
        '.CC = TextBox1
        .Subject = Range("B3").Value   'Asunto
        .TextBody = Mensaje
        archivo = Cells(i, "C").Value
            If Dir(archivo) <> "" Then
                .AddAttachment archivo
            End If
        .Send
    End With
    MsgBox "Mensaje enviado exitósamente", vbInformation, "GMail en Excel"
    'Mostramos un mensaje, tanto si hay
    'errores como si no los hay
    'If Err = 0 Then
     '   MsgBox ("Se ha producido un error, y no se ha podido enviar el email.")
    'Else
    '    MsgBox ("El email se ha enviado correctamente.")
    'End If
    If Err.Number = 0 Then
            Cells(i, "D") = "El mail se envió con éxito"
        Else
            Cells(i, "D") = "Se produjo el siguiente error: " & Err.Number & " " & Err.Description
        End If
    'Set Email = Nothing
   Next
End Sub
Private Sub CommandButton2_Click()
Unload Me
End Sub
Private Sub Label10_Click()
End Sub
Private Sub textbox1_Exit(ByVal cancel As MSForms.ReturnBoolean)
If TextBox1.Value <> "" Then
With CreateObject("vbscript.regexp")
.Pattern = "^[\w-\.]+@([\w-]+\.)+[A-Za-z]{2,3}$"
If .test(TextBox1.Value) Then
Else
MsgBox "Ingrese una dirección de correo electrónico válida, No le aplique seguridad y privacidad para no bloquear la app", vbCritical, "Información ATex 3.0"
cancel = True
End If
End With
End If
End Sub
Private Sub TextBox2_Change()
End Sub
Private Sub userform_terminate()
Exit Sub
End Sub

Este es el código del userfrom

Adicional como evitar que salga en msgbox de correo enviado y evitar dar doble click para que continué con el siguiente

1 respuesta

Respuesta
1

Te anexo el código actualizado

Private Sub CommandButton1_Click()
'Act.Por.Dante Amor
    If TextBox1.Value = "" Or TextBox1.Value = "@gmail.com" Then
        MsgBox "Ingrese su correo electrónico para enviarle una respuesta", vbExclamation
        Exit Sub
    End If
    If TextBox2.Value = "" Then
        MsgBox "Ingrese password", vbExclamation
        Exit Sub
    End If
    '
    For i = 10 To Range("B" & Rows.Count).End(xlUp).Row
       'Si hay errores, que continúe
        On Error Resume Next
        Set oMsg = CreateObject("CDO.Message")
        Set oconf = CreateObject("CDO.Configuration")
        oconf.Load -1
        Set Flds = oconf.Fields
        With Flds
            .Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
            .Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
            .Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = TextBox1.Value
            .Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = TextBox2.Value
            .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.gmail.com"
            .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
            .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 465
            .Update
        End With
        '
        Mensaje = Range("B4").Value 'Mensaje del correo
        With oMsg
            Set .Configuration = oconf
            .From = TextBox1.Value
            .To = Cells(i, "B").Value 'listado de destinatarios
            If CheckBox2.Value = True Then
                .CC = TextBox1
            End If
            .Subject = Range("B3").Value   'Asunto
            .TextBody = Mensaje
            archivo = Cells(i, "C").Value
            If Dir(archivo) <> "" Then
                .AddAttachment archivo
            End If
            .Send
        End With
        '
        If Err.Number = 0 Then
            Cells(i, "D") = "El mail se envió con éxito"
        Else
            Cells(i, "D") = "Se produjo el siguiente error: " & Err.Number & " " & Err.Description
        End If
        'Set Email = Nothing
    Next
End Sub

'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas