Saber que archivos no se enviaron desde excel Corres masivos
Para Dante Amor, buen día tengo una macro que me envía correos automáticamente a diferentes remitentes y con diferentes archivos adjuntos, en este momento Dante me ayudo a generar un Msgbox que me dijera que archivos no se enviaron, pero el msgbox me queda muy corto para cuando son más de 10 archivos que no se enviaron, entonces quisiera saber que forma existe de pasar eso a un form o algo así para que muestre todo el texto con su respectivo scroll
Este es el Código
Dim AppSaliente, CorreoSaliente As Object
Dim HojaCalculo As Worksheet
Dim celda, CeldArchivo, rango As Range
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set HojaCalculo = Sheets("Correo")
Set AppSaliente = CreateObject("Outlook.Application")
For Each celda In HojaCalculo.Columns("B").Cells.SpecialCells(xlCellTypeVisible)
'Poner los nombres en las columnas C:Z de cada fila
Set rango = HojaCalculo.Cells(celda.Row, 1).Range("C1:bZ1")
If celda.Value Like "?*@?*.?*" And _
Application.WorksheetFunction.CountA(rango) > 0 Then
Set CorreoSaliente = AppSaliente.CreateItem(0)
With CorreoSaliente
.to = celda.Value
.Subject = Worksheets("Envio De mensajes").Range("A2").Value
.Body = Worksheets("Envio De mensajes").Range("A6").Value
'.Attachments.Add ActiveWorkbook.FullName
For Each CeldArchivo In rango.SpecialCells(xlCellTypeVisible)
If Trim(CeldArchivo) <> "" Then
If Dir(CeldArchivo.Value) <> "" Then
.Attachments.Add CeldArchivo.Value
Else
CeldArchivo.Interior.ColorIndex = 3
If CeldArchivo.Value = "" Then
Else
cad = cad & CeldArchivo.Value & " "
End If
End If
Else
End If
Next CeldArchivo
'Display
.Send 'para enviar sin comprobar
End With
Set CorreoSaliente = Nothing
End If
Next celda
Set AppSaliente = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
MsgBox ("Pdf no encontrados" & cad)
1 Respuesta
Cambié el msgbox por un listbox en esta parte:
ListBox1. AddItem correo ListBox1. List(ListBox1. ListCount - 1, 1) = cedula
De esa forma puedes saber por correo, cuáles cédulas no tienen archivo y no se enviaron.
La macro completa:
Private Sub UserForm_Activate()
'Por.Dante Amor
Set h1 = Sheets("Envio De mensajes")
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 j = Columns("D").Column To h1.Cells(2, Columns.Count).End(xlToLeft).Column
correo = h1.Cells(2, j)
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 i = 3 To h1.Cells(Rows.Count, j).End(xlUp).Row
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 correo
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
.
