Macro para enviar Correos masivos, saber cuales se enviaron!
Dante escribo amablemente para solicitar una ayuda con respecto a una macro que conseguí en internet, lo que hace esta macro es enviar correos masivos a diferentes correos y con diferentes adjuntos, lo que quiero hacer, es saber que pdf's no se enviaron por que quizás no los encontró.
1 respuesta
Supongo que tienes esta macro.
Le hice un cambio para que te pinte la celda de rojo si el archivo no existe
Sub Enviar_Correos() '--- ' Por.Dante Amor '--- '***Macro Para enviar correos 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 Cells(i, j).Interior.ColorIndex = xlNone archivo = Cells(i, j).Value If Dir(archivo) <> "" Then dam.Attachments.Add archivo Else Cells(i, j).Interior.ColorIndex = 3 End If Next 'dam. Send 'El correo se envía en automático dam. Display 'El correo se muestra Next MsgBox "Correos enviados", vbInformation, "SALUDOS" End Sub
.
'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias
.
Avísame cualquier duda
.
Utiliza esta:
Sub Enviar_Correos() '--- ' Por.Dante Amor '--- '***Macro Para enviar correos 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 Cells(i, j).Interior.ColorIndex = xlNone archivo = Cells(i, j).Value If Dir(archivo) <> "" Then dam.Attachments.Add archivo Else Cells(i, j).Interior.ColorIndex = 3 End If Next Dam. Send 'El correo se envía en automático 'dam. Display 'El correo se muestra Next MsgBox "Correos enviados", vbInformation, "SALUDOS" End Sub
.
'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias
.
Avísame cualquier duda
.
Dante pues en realidad tengo este 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("Hoja1").Range("A2")
.Body = ""
'.Attachments.Add ActiveWorkbook.FullName
For Each CeldArchivo In rango.SpecialCells(xlCellTypeVisible)
If Trim(CeldArchivo) <> "" Then
If Dir(CeldArchivo.Value) <> "" Then
.Attachments.Add CeldArchivo.Value
End If
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
End If
Pues quisiera editar ese así como lo que dices de que se marque en rojo
Te anexo la macro actualizada
Sub Correo() 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("Hoja1").Range("A2") .Body = "" '.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 End If 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 End If End Sub
.
'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias
.
Avísame cualquier duda
.
Dante, buen día, ¿El código funciona Excelente pero no se podría hacer para que envíe un msgbox con los pdf que no encontraron o algo así?
Te anexo la macro con el mensaje
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("Hoja1").Range("A2") .Body = "" '.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 cad = cad & CeldArchivo.Value & " " End If 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
.
'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias
.
- Compartir respuesta