Enviar correos desde una lista en excel insertando una imagen en el cuerpo del correo
Quisiera que me ayudaran con una macro que estoy intentando generar para envío de correos en excel pero no puedo insertar una imagen en el cuerpo del correo, esto es lo que tengo:
Private Sub Enviar_Mail()
'Envios Masivos de Email
Dim appOutlook As Outlook.Application
Dim message As Outlook.MailItem
Dim myRecipient As Object
Set appOutlook = CreateObject("outlook.application")
Set message = appOutlook.CreateItem(olMailItem)
With message
.Subject = Range("A10")
.Body = Range("A11")
Range("J2:K3").Copy
Set dam = CreateObject("outlook.application").CreateItem(0)
.Recipients.Add (Range("A1"))
Set dam = Nothing
.Send
End With
End Sub
1 Respuesta
H o l a:
En el foro han realizado varias solicitudes de enviar correos masivos, es por eso que he creado una aplicación para enviar correos de forma masiva.
Con la aplicación puedes enviar correos a varias destinatarios, con diferentes asuntos, con diferentes cuerpos de correo y con diferentes archivos, puedes anexar uno o varios archivos.
Puedes enviar copia o copias ocultas.
La aplicación utiliza outlook para enviar los correos.
Otra mejora que tiene la aplicación es que puedes enviar una imagen en el cuerpo del correo. La imagen puede ir insertada en una "firma" del correo.
Este es el código:
'***Macro Para enviar correos con adjunto diferente y firma
Sub correo()
'Por.Dante Amor
col = Range("H1").Column
ruta = ThisWorkbook.Path & "\"
For i = 3 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"
Cuerpo = 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
'
logo = [L2]
dam.Attachments.Add ruta & logo
dam.HTMLBody = _
"<HTML> " & _
"<BODY>" & _
"<P>" & Cuerpo & "</P>" & _
"<img src=cid:" & logo & " height=40 width=40>" & _
"<br>" & "<b>" & [I2] & "</b>" & _
"<br>" & [J2] & _
"<br>" & [K2] & _
"</BODY> " & _
"</HTML>"
'dam.Display 'El correo se muestra
dam.send 'El correo se envía en automático
Next
MsgBox "Correos enviados", vbInformation, "SALUDOS"
End SubEn la celda L2 tienes que poner el nombre del archivo que contiene la imagen.
Para anexar los archivos a la hoja, para que después sean agregados esos archivos al correo, se tiene que poner el siguiente código en los eventos de la hoja:
Private Sub Worksheet_Change(ByVal Target As Range)
'Por.Dante Amor
On Error Resume Next
If Target.Count > 1 Then Exit Sub
If Target.Row < 3 Then Exit Sub
If Not Intersect(Target, Range("B:B")) Is Nothing Then
For Each t In Target
If t.Value <> "" Then
Cells(t.Row, "G").Select
ActiveSheet.Hyperlinks.Add _
Anchor:=Selection, _
Address:="", _
SubAddress:="Hoja1!C" & t.Row, _
TextToDisplay:="Insertar archivo"
End If
Next
Cells(Target.Row, 3).Select
End If
End Sub
'
Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
'Por.Dante Amor
linea = ActiveCell.Row
'col = Range("H1").Column
col = Cells(linea, Columns.Count).End(xlToLeft).Column + 1
If col < 8 Then col = 8
With Application.FileDialog(msoFileDialogFilePicker)
.Title = "Seleccione uno o varios archivos"
.Filters.Clear
.Filters.Add "archivos pdf", "*.pdf*"
.Filters.Add "archivos de excel", "*.xls*"
.Filters.Add "Todos los archivos", "*.*"
.FilterIndex = 2
.AllowMultiSelect = True
.InitialFileName = ThisWorkbook.Path & "\"
If .Show Then
For Each ar In .SelectedItems
'rutaarchivo = .SelectedItems.Item(i)
Cells(linea, col) = ar
col = col + 1
Next
End If
End With
End SubLa estructura de la hoja debe ser así:
Este es un ejemplo del correo enviado:
Avísame si tienes dudas para adaptarla a tu archivo.
Buenos días Dante, gracias por tu atención.
Verificando la aplicación, no me manda ningún correo, tal vez será porque tengo 3 cuentas activas en outlook, otra cuestión es que, la imagen que quiero enviar es un rango de celdas de un libro activo. Lo de adjuntar los archivos aun no lo puedo comprobar, hasta que me envíe un correo.
Espero me puedas ayudar.
ademas hace unos momentos me salió un error
'-2147417851(80010105)' en tiempo de ejecución:
Error en el método 'To' de objeto '_MailItem'
Antes de entrar en toda la complejidad de las macro que te puse, realiza una prueba sencilla para abrir un correo.
Pon la siguiente macro en un módulo y ejecuta la macro:
Sub EnviarCorreo()
'Por.Dante Amor
Set Dam = CreateObject("outlook.application").createitem(0)
Dam.to = "[email protected]" 'Destinatarios
Dam.Subject = "Una hoja en correo" '"Asunto"
Dam.Body = "Cuerpo del correo" 'Cuerpo
Dam.Display
End SubTe debe abrir un correo. No lo va a enviar, solamente lo va a presentar en pantalla.
Avísame del resultado de la prueba.
