Macro para Excel emaling con adjunto personalizado a través de Outlook365
Necesito una macro para envío masivo de emails, con adjuntos personalizados y funcionando con Outlook365, web access. Hay una macro, del colaborador Dante Amor, que funciona a la perfección con la version instalada de Outlook . ¿seria posible modificarla para usar el Outlook 365 OWA (Outlook web access)?
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.
A eso me refiero, cambien la cuenta por la nueva y prueban
