Envio mail personalizado desde OUTLOOK con adjuntos
Necesito hacer un envío personalizado de correos (combinación de correspondencia) con Outlook de muchos correos, pero me gustaría saber si se puede hacer alguna macro que me permitiese por ejemplo poner todos los campos en distintas columnas y en una de ellas el archivo que se ha de enviar con su ruta. Esto me permitiría enviar distintos archivos a diferentes destinatarios.
1 Respuesta
Respuesta de Dante Amor
1
H o l a: Te anexo la macro
'***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 SubEscríbeme un correo, para reenviarte mi archivo con los ejemplos y las instrucciones.
Mi correo [email protected]
En el asunto del correo escribe tu nombre de usuario “Enrique Garcia” y el título de esta pregunta.
'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias
Enviado.
En los eventos de la hoja van un par de macros, sirven para poner los nombres de los archivos con su ruta en la celda.
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, "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 Sub'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias
