Actualización código VBA para enviar adjunto en correo masivos
Quisiera solicitar el favor de automatizar un poco el siguiente código el cual fue creado por el ingeniero Dante, para enviar adjuntos en en correos masivos, la macro funciona muy bien sin embargo si llegamos a tener un correo mal digitado la macro se detiene y es un poco complejo identificar hasta que correo fue enviado si se trata del envío de varios correos. ¿Por lo cual agradecería si podemos actualizar el código que permita realizar todo el envío y al final nos muestre que correos no se pudieron enviar?
Este es el código del ingeniero.
'***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)
'On Error Resume Next
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
De antemano mil gracias... Por su ayuda.
1 respuesta
Te anexo la actualización. En la columna Z escribirá si el correo no fue enviado
Sub Enviar_Correos()
'---
' Por.Dante Amor
'---
'***Macro Para enviar correos
col = Range("H1").Column
Columns("Z").Clear
For i = 2 To Range("B" & Rows.Count).End(xlUp).Row
Set dam = CreateObject("Outlook.Application").CreateItem(0)
'
dam.To = Range("B" & i).Value 'Destinatarios
dam.Cc = Range("C" & i).Value 'Con copia
dam.Bcc = Range("D" & i).Value 'Con copia oculta
dam.Subject = Range("E" & i).Value '"Asunto"
dam.Body = Range("F" & i).Value '"Cuerpo del mensaje"
'
For j = col To Cells(i, Columns.Count).End(xlToLeft).Column
archivo = Cells(i, j).Value
If archivo <> "" Then dam.Attachments.Add archivo
Next
On Error Resume Next
dam.Send 'El correo se envía en automático
werr = Err.Number
If werr <> 0 Then
Range("Z" & i).Value = "Correo no enviado"
End If
Err.Number = 0
On Error GoTo 0
'dam.Display 'El correo se muestra
Next
MsgBox "Correos enviados", vbInformation, "SALUDOS"
End Sub.
'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias
.
Avísame cualquier duda
.
Dante nuevamente te doy las gracias por tu pronta respuesta y además eficaz, con esta actualización se automatizo el proceso mil veces
Muchas gracias.
