Macro para Excel emaling con adjunto personalizado a través de Outlook365

H o l a: Prueba la siguiente macro para ver si te funciona enviar un correo desde excel.

Cambia en la macro los siguientes datos:

    correo = "[email protected]"     'correo de office
    passwd = "pwd"                      'password del correo
    destino = "usuario@gmailcom"        'correo del destinatario

---

La macro:

Sub EnviarCorreo()
'Por.Dante Amor
    Correo = "[email protected]"     'correo de office
    passwd = "pwd"                      'password del correo
    destino = "usuario@gmailcom"        'correo del destinatario
    '
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    '
    Dim Email As CDO.Message
    Set Email = New CDO.Message
    Email.Configuration.Fields(cdoSMTPServer) = "smtp.office365.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") = Correo
        .Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = passwd
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
    End With
    With Email
        .To = destino
        .From = Correo
        .Subject = "Asunto"
        .TextBody = "todo lo que quieras Cuerpo del correo"
        '.AddAttachment "archivo.xlsx"
        .Configuration.Fields.Update
        On Error Resume Next
        .Send
    End With
    If Err.Number = 0 Then
        MsgBox "El mail se envió con éxito"
    Else
        MsgBox "Se produjo el siguiente error: " & Err.Number & " " & Err.Description
    End If
    Set Email = Nothing
End Sub

---

Prueba y me comentas.

Buenas tardes,

Gracias por la rápida respuesta . La macro no me funciona o no he sabido hacerla funcionar...

Con otra macro suya, este tema si funciona bien, con la versión instalada de Outlook, pero no con el OWA :

'***Macro Para enviar correos
Sub correo()
'Por.Dante Amor
col = Range("H1").Column
For i = 2 To Range("B" & Rows.Count).End(xlUp).Row
Set dam = CreateObject("outlook.application").createitem(0)
dam.To = Range("B" & i) 'Destinatarios
dam.CC = Range("C" & i) 'Con copia
dam.Bcc = Range("D" & i) 'Con copia oculta
dam.Subject = Range("E" & i) '"Asunto"
dam.body = Range("F" & i) '"Cuerpo del mensaje"
'
For j = col To Cells(i, Columns.Count).End(xlToLeft).Column
archivo = Cells(i, j)
If archivo <> "" Then dam.Attachments.Add archivo
Next
dam.send 'El correo se envía en automático
'dam.display 'El correo se muestra
Next
MsgBox "Correos enviados", vbInformation, "SALUDOS"
End Sub

Gracias por su tiempo .

El código para Outlook y para office es diferente, es por eso que primero vamos a probar para ver si funciona tal como lo quieres.

---

Entra el menú de VBA, Herramientas, Referencias y busca la referencia "Microsoft CDO for Windows 2000 Library", activa la casilla y presiona Aceptar

Vuelve a probar.

¡ Funciona ! 

Prueba la siguiente macro.

Cambia el correo y el password

    correo = "[email protected]"     'correo de office
    passwd = "pwd"                      'password del correo

Revisa lo siguiente. En la columna B pon el destinatario, en la E el asunto, en la F el cuerpo y en la H la ruta con todo y el nombre del archivo.

---

Sub EnviarCorreoPorOffice()
'Por.Dante Amor
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    '
    correo = "[email protected]"     'correo de office
    passwd = "pwd"                      'password del correo
    '
    col = Range("H1").Column
    For i = 2 To Range("B" & Rows.Count).End(xlUp).Row
        '
        Dim Email As CDO.Message
        Set Email = New CDO.Message
        Email.Configuration.Fields(cdoSMTPServer) = "smtp.office365.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") = correo
            .Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = passwd
            .Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
        End With
        With Email
            .To = Range("B" & i).Value          'Destinatarios
            .From = correo                      'correo origen
            .Subject = Range("E" & i).Value     '"Asunto"
            .TextBody = Range("F" & i).Value    '"Cuerpo del mensaje"
            'For j = col To Cells(i, Columns.Count).End(xlToLeft).Column
                archivo = Cells(i, col)
                If archivo <> "" Then .AddAttachment archivo
            'Next
            '.AddAttachment "archivo.xlsx"
            .Configuration.Fields.Update
            On Error Resume Next
            .Send
        End With
        If Err.Number = 0 Then
            MsgBox "El mail se envió con éxito"
        Else
            MsgBox "Se produjo el siguiente error: " & Err.Number & " " & Err.Description
        End If
        Set Email = Nothing
        On Error GoTo 0
    Next
    MsgBox "Correos enviados", vbInformation, "SALUDOS"
End Sub

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

Buenas tardes,

Hay algo que no funciona, la macro parece ir bien, incluso me deveulve el mensaje de "Correos enviados", pero no llega nada .

Cambie en el código según me dijo, correo y pass . Rellene en las columnas B, E, F y H . :(

Tienes que poner datos desde la celda B2 hacia abajo.

Pon una imagen para ver cómo tienes los datos de la hoja.

Buenos días !,

Ese era el problema, había puesto los datos en la primera línea .

Me devuelve 2 mensajes de confirmación, perfecto .Una duda, en un listado de unos 100 correos si diera algún error una línea, ¿seguiría mandando el resto de correos? ¿Habría alguna forma de saber que línea ha dado el error? .

Con esta solución me vale, no quiero abusar de su conocimiento ni tiempo, mil gracias !

Prueba con esta, en la columna M te pondrá el resultado

[code]Sub EnviarCorreoPorOffice()
'Por.Dante Amor
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    '
    correo = "[email protected]"     'correo de office
    passwd = "pwd"                      'password del correo
    '
    col = Range("H1").Column
    For i = 2 To Range("B" & Rows.Count).End(xlUp).Row
        '
        Dim Email As CDO.Message
        Set Email = New CDO.Message
        Email.Configuration.Fields(cdoSMTPServer) = "smtp.office365.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") = correo
            .Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = passwd
            .Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
        End With
        With Email
            .To = Range("B" & i).Value          'Destinatarios
            .From = correo                      'correo origen
            .Subject = Range("E" & i).Value     '"Asunto"
            .TextBody = Range("F" & i).Value    '"Cuerpo del mensaje"
            'For j = col To Cells(i, Columns.Count).End(xlToLeft).Column
                archivo = Cells(i, col)
                If archivo <> "" Then .AddAttachment archivo
            'Next
            '.AddAttachment "archivo.xlsx"
            .Configuration.Fields.Update
            On Error Resume Next
            .Send
        End With
        If Err.Number = 0 Then
            'MsgBox "El mail se envió con éxito"
            Range("M" & i) = "El mail se envió con éxito"
        Else
            Range("M" & i) = "Se produjo el siguiente error: " & Err.Number & " " & Err.Description
        End If
        Set Email = Nothing
        On Error GoTo 0
    Next
    MsgBox "Correos enviados", vbInformation, "

¡Gracias! 

Efectivamente rellena la columna M .

Muchas gracias de nuevo .

Saludos.

Buenos días, de nuevo doy las gracias a Dante por su gran ayuda y nuevamente busco su ayuda o la de quien pudiera ... el caso es que por necesidades que no vienen al caso en el Outlook hemos configurado una segunda cuenta de email . Al ejecutar la macro, Outlook lanza los emails desde la cuenta "secundaria", ¿hay alguna forma de especificar que cuenta usar para lanzar los emais?

Gracias !

Tendrán que cambiar la cuenta predeterminada y probar

Buenos días,

Me temo que la cuenta predeterminada es la correcta.