Enviar múltiples correos con archivos adjuntos
Para Dante Amor. Vi una respuesta tuya y te agradecería que puedas ayudarme con una aplicación de macro en excel, para enviar archivos por e-mail.
Cada mes tengo que enviar de 1 a 3 archivos adjuntos (.pdf, .xls, .doc, .jpg, etc.) a unos 25 contactos, con correos individuales y con algunas diferencias en el asunto y en el cuerpo o texto de algunos de ellos.
Los archivos los tengo en subcarpetas de cada mes, en la misma ruta.
Quedaré super agradecido.
1 Respuesta
Respuesta de Dante Amor
2
H o l a:
Te anexo las macros de la aplicación para enviar los correos masivamente:
En un módulo
'***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).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
dam.send 'El correo se envía en automático
'dam.display 'El correo se muestra
Next
MsgBox "Correos enviados", vbInformation, "SALUDOS"
End SubEn los eventos de la hoja
Private Sub Worksheet_Change(ByVal Target As Range)
'Por.Dam
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, "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.Dam
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 SubEn la hoja encuentras unos comentarios para utilizar el envío masivo.
'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias
