Macro para enviar correos de manera masiva con adjunto
Necesito una macro que me permita enviar correos con archivos adjunto de manera masiva teniendo las siguientes características:
El excell podría contener dos botones, uno para cargar la información de los archivos y otro para el envió.
Primer botón.- Realizará lo siguiente:
- Archivo: Se listará consecutivamente la relación de archivos que se encuentre en un carpeta especifica (Siempre estará en la unidad D y con nombre “Archivos para correos”).
- Nombre del adjunto: Se mostrará el nombre del archivo adjunto sin la extensión (.pdf, .xlsx, etc).
- Asunto: Se mostrará un texto más el nombre del archivo adjunto (como prueba lo hice bajo formula ejemplo =”Adjunto”&” “&F2)
- Mensaje: El texto del cuerpo será el mismo para todos por tal podría replicarse de acuerdo a la misma cantidad de correos que se enviarán. Lo que por ahora estoy haciendo es poner el texto en una celda y luego con empleando el “=” procedo arrastrarlo para que se replique.
Segundo botón.- Hará lo que ya lo tienes trabajado (enviar los correos con sus adjuntos de manera masiva).
Respuesta de Dante Amor
1
H o l a:
Te anexo las macros actualizadas.
En los eventos de la hoja1:
Private Sub Worksheet_Change(ByVal Target As Range)
'Por.Dante Amor
On Error Resume Next
If Not Intersect(Target, Range("B:B")) Is Nothing Then
For Each t In Target
If t.Value <> "" Then
Cells(t.Row, "H").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
Set h2 = Sheets("Hoja2")
linea = ActiveCell.Row
col = Range("I1").Column
h2.Rows(linea).Clear
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 = "D:\archivos para correos\" 'ThisWorkbook.Path
If .Show Then
For Each ar In .SelectedItems
h2.Cells(linea, col) = ar
diago = InStrRev(ar, "\")
archivo = Mid(ar, diago + 1)
punto = InStrRev(archivo, ".")
archivo = Left(archivo, punto - 1)
Cells(linea, col) = archivo
Cells(linea, "E") = Cells(linea, "E") & " " & archivo
col = col + 1
Next
End If
End With
End SubEn el módulo:
'***Macro Para enviar correos
Sub correo()
'Por.Dante Amor
col = Range("I1").Column
Set h2 = Sheets("Hoja2")
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"
Cuerpo = Range("F" & i).Value '"Cuerpo del mensaje"
If Range("G" & i).Value = "" Or Not IsNumeric(Range("G" & i).Value) Then
n = 1
Else
n = Range("G" & i).Value
End If
'dam.SendUsingAccount = dam.Session.Accounts.Item(n) '
'
For j = col To h2.Cells(i, Columns.Count).End(xlToLeft).Column
archivo = h2.Cells(i, j).Value
If archivo <> "" Then dam.Attachments.Add archivo
Next
ruta = "C:\trabajo\fotos\"
arch = "imagen.gif"
dam.Attachments.Add ruta & arch
dam.Display 'El correo se muestra
dam.HtmlBody = _
"<HTML> " & _
"<BODY>" & _
"<P>" & Cuerpo & dam.HtmlBody & "</P>" & _
"<img src=cid:" & arch & " height=40 width=40>" & _
"</BODY> " & _
"</HTML>" 'Con esta parte se agrega la firma
dam. Display 'El correo se muestra
dam. Send 'El correo se envía en automático
Next
MsgBox "Correos enviados", vbInformation, "SALUDOS"
End SubTe envié el archivo con las macros.
' : ) 'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias ' : )
