Macro para enviar correos gmail desde VBA
Comunidad buenos dias/tarde o noches, soy nuevo en el lenguaje VBA y he tratado de escribir una macro para enviar gmail. Dice que ya se envío pero al revisar el correo de destino no le ha llegado nada
Si me podrían ayudar estaría muy agradecido. Este es el código:
Private Sub CommandButton1_Click()
Dim CORREOS As CDO.Message
Dim DESTINATARIO As String
Dim ASUNTO As String
Dim CONTENIDO As String
Dim EMISOR As String
Dim MENSAJE As String
Dim I As Long
Dim FILA As Long
MENSAJE = MsgBox("¿ESTAS SEGURA DE ENVIAR ESTE CORREO?", 32 + 4, "ENVIAR CORREO")
If MENSAJE = 6 Then
'ENVIAR SOLO A UNA PERSONA
If Me.una_persona = True Then
Me.destino = Me.LISTA3.List(Me.LISTA3.ListIndex - 0, 3)
DESTINATARIO = Me.LISTA3.List(Me.LISTA3.ListIndex - 0, 3)
ASUNTO = Me.ASUNTO_1
CONTENIDO = Me.COMENTARIO_1
EMISOR = Me.REMITENTE
Set CORREOS = New CDO.Message
With CORREOS.Configuration.Fields
.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/smtpserver") = "smtp.gmail.com"
.ITEM("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 465
.ITEM("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
.ITEM("http://schemas.microsoft.com/cdo/configuration/sendusername") = "[email protected]"
.ITEM("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "12345RDj"
.Update
End With
With CORREOS
.Subject = ASUNTO
.From = EMISOR
.To = DESTINATARIO
.TextBody = CONTENIDO
.AddAttachment Me.ADJUNTO
End With
'CORREOS.Send
On Error Resume Next
CORREOS.Send
Set CORREOS = Nothing
MsgBox "CORREO ENVIADO CON EXITO"
End If
'ENVIAR A VARIAS PERSONAS
If Me.TODOS Then
If Me.ASUNTO_1 = Empty Or Me.REMITENTE = Empty Or Me.LISTA3.ListCount = Empty Then
MsgBox "ES NECESARIO COMPLETAR LOS CAMPOS ESCENCIALES", 16
Exit Sub
Else
For I = 0 To Me.LISTA3.ListCount - 1
Me.destino = Me.LISTA3.List(Me.LISTA3.ListIndex - 0, 4)
DESTINATARIO = Me.LISTA3.List(Me.LISTA3.ListIndex - 0, 4)
ASUNTO = Me.ASUNTO_1
CONTENIDO = Me.COMENTARIO_1
EMISOR = Me.REMITENTE
Set CORREOS = New CDO.Message
With CORREOS.Configuration.Fields
.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/smtpserver") = "smtp.gmail.com"
.ITEM("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 465
.ITEM("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
.ITEM("http://schemas.microsoft.com/cdo/configuration/sendusername") = "[email protected]"
.ITEM("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "12345RDj"
.Update
End With
With CORREOS
.Subject = ASUNTO
.From = EMISOR
.To = DESTINATARIO
.TextBody = CONTENIDO
.AddAttachment Me.ADJUNTO
End With
'CORREOS.Send
On Error Resume Next
CORREOS.Send
Next I
End If
End If
End If
End Sub
No se en que me equivocado o que me faltara.