Enviar Email por el excel vba

He puesto todos los metodos conocidos para enviar email ppor excel pero ninguna funciona, ya que gmail no acepta correos de lugares no confiables, es por ello, que modifique una macro de un amigo, pero no me funciona. Haber si me pueden ayudar, adjunto la macro.

Sub Emails()
Hoja5.Visible = xlSheetVisible
Hoja5.Activate
ActiveSheet.Copy
With ActiveWorkbook
    .SendMail Recipients:="[email protected]", Subject:="Informe diario Acopio"
    .Close savechanges:=False
End With
Hoja1.Activate
MsgBox "Se envio el email"
End Sub

1 Respuesta

Respuesta
1

He solucionado el inconveniente con la siguiente macro:

Sub Enviar_gmail()
' Macro modificado por J.P
Application.ScreenUpdating = False
Dim hoja As Sheets
Dim NewMail As CDO.Message
Dim a, b As String
Dim archivo As Variant
Set NewMail = New CDO.Message
Application.DisplayAlerts = False
' ADJUNTAREMOS LA HOJA GUARDADA EN EL DIA
a = Format(Hoja1.Range("C4"), "DD")
b = Format(Hoja1.Range("C4"), "MMMM")
archivo = "G:\Programa\Archivos\Informe del " & a & " de " & b & ".xlsx"
NewMail.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
NewMail.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
NewMail.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.gmail.com"
NewMail.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
NewMail.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
NewMail.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/sendusername") = "[email protected]"
NewMail.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "xxxxxx"
NewMail.Configuration.Fields.Update
With NewMail
  .Subject = "Informe Diario de Acopio"
  .From = "[email protected]"
  .To = "[email protected]"
  .CC = ""
  .BCC = ""
  .AddAttachment archivo
  .TextBody = "Estimad@ " & Chr(13) _
  & " Se envia el informe del dia " & Hoja1.Range("C4") & Chr(13) & Chr(13) & "Atentamente: " & Chr(13) & " Sr. xxx"
End With
NewMail.Send
MsgBox ("El Informe fue enviado via Email")
Set NewMail = Nothing
End Sub

Y para que funcione, tuve que desactivar la casilla en esta direccion:

https://www.google.com/settings/security/lesssecureapps  

Espero les ayude a algunos que desean enviar email por Gmail y tienen el inconveniente de "no se pudo conectar con el servidor SMTP"

La pregunta no admite más respuestas

Más respuestas relacionadas