Enviar correos masivos con adjunto al lado y que busque pdf por cedula
Dante
Buenas tardes
El ultimo código que me facilitaste estuvo excelente me ha funcionado de maravilla, pero tengo otro dilema
Ahora quiero que se adjunten los pdf's que tengo al lado del correo electrónico con el mismo esquema de que muestre los que no se enviaron y que busque por cedula en la carpeta especifica
Imagen ejemplo
Lo que quiero es que se agreguen los pdfs que se tienen al lado del correo electrónico no como en el código anterior(Que me funciono de maravilla) que adjuntaba los que tenia abajo del correo
1 Respuesta
Te anexo la macro
Private Sub UserForm_Activate()
'Por.Dante Amor
Set h1 = Sheets("Enviar")
Set h2 = Sheets("temp")
h2.Cells.Clear
'
Label3.Caption = "ENVIANDO CORREOS"
ruta = h1.Range("A4")
If ruta = "" Then MsgBox "Ingresa la carpeta": Exit Sub
If Dir(ruta, vbDirectory) = "" Then MsgBox "No existe la carpeta": Exit Sub
If Right(ruta, 1) <> "\" Then ruta = ruta & "\"
'
i = 2
arch = Dir(ruta & "*.pdf")
Do While arch <> ""
h2.Cells(i, "A") = arch
i = i + 1
arch = Dir()
Loop
'
For i = 1 To h1.Range("C" & Rows.Count).End(xlUp).Row
obras = h1.Cells(i, "C").Value
correo = h1.Cells(i, "D").Value
Set dam = CreateObject("Outlook.Application").CreateItem(0)
dam.To = correo 'Destinatarios
dam.Subject = h1.Range("A2").Value '"Asunto"
dam.Body = h1.Range("A6").Value '"Cuerpo del mensaje"
'
For j = 5 To h1.Cells(i, Columns.Count).End(xlToLeft).Column
cedula = h1.Cells(i, j)
Set b = h2.Columns("A").Find(cedula, lookat:=xlPart)
If Not b Is Nothing Then
dam.Attachments.Add ruta & b.Value
Else
ListBox1.AddItem obras
ListBox1.List(ListBox1.ListCount - 1, 1) = cedula
End If
Next
Dam. Send 'El correo se envía en automático
'dam. Display 'El correo se muestra
Next
Label3.Caption = "ARCHIVOS QUE NO FUERON ENVIADOS"
End Sub.
'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias
.
Avísame cualquier duda
.
Muchas gracias, como siempre con excelencia
Tengo un pequeño problema, lo que pasa es que cuando no encuentra el pdf, lo que hace es que envía el mensaje sin el adjunto, entonces quisiera saber si para esos que no encuentra el pdf se pueda hacer que no se envíe el mensaje
Si vas a enviar 5 adjuntos y uno no se encuentra, ¿entonces qué no lo envíe?
¿O si no encuentra ninguno de los 5 adjuntos que no lo envíe?
Es que en esta ultima solo se enviara un ajdunto por correo, entonces: Si no hay adjunto entonces que no se envíe
:D Muchas Gracias Dante
Va
Private Sub UserForm_Activate()
'Por.Dante Amor
Set h1 = Sheets("Enviar")
Set h2 = Sheets("temp")
h2.Cells.Clear
'
Label3.Caption = "ENVIANDO CORREOS"
ruta = h1.Range("A4")
If ruta = "" Then MsgBox "Ingresa la carpeta": Exit Sub
If Dir(ruta, vbDirectory) = "" Then MsgBox "No existe la carpeta": Exit Sub
If Right(ruta, 1) <> "\" Then ruta = ruta & "\"
'
i = 2
arch = Dir(ruta & "*.pdf")
Do While arch <> ""
h2.Cells(i, "A") = arch
i = i + 1
arch = Dir()
Loop
'
For i = 1 To h1.Range("C" & Rows.Count).End(xlUp).Row
obras = h1.Cells(i, "C").Value
correo = h1.Cells(i, "D").Value
Set dam = CreateObject("Outlook.Application").CreateItem(0)
dam.To = correo 'Destinatarios
dam.Subject = h1.Range("A2").Value '"Asunto"
dam.Body = h1.Range("A6").Value '"Cuerpo del mensaje"
'
For j = 5 To h1.Cells(i, Columns.Count).End(xlToLeft).Column
cedula = h1.Cells(i, j)
Set b = h2.Columns("A").Find(cedula, lookat:=xlPart)
If Not b Is Nothing Then
dam.Attachments.Add ruta & b.Value
dam.Send 'El correo se envía en automático
'dam.Display 'El correo se muestra
Else
ListBox1.AddItem obras
ListBox1.List(ListBox1.ListCount - 1, 1) = cedula
End If
Next
Next
Label3.Caption = "ARCHIVOS QUE NO FUERON ENVIADOS"
End Subsal u dos
