Macro excel para enviar paquetes de que correos (mensajes) cada t segundos
Se tiene un archivo xlsm con n registros o líneas, se requiere macro excel que envié cada 10 segundos un paquete de 20 registros hasta el registro n, cada registro o línea contiene un mensaje y cada mensaje lleva un archivo adjunto.
Es decir, envía el primer paquete de las 20 líneas iniciales, "espera" 10 segundos y envía los siguientes 20 líneas. Así sucesivamente, hasta el registro n; donde n no necesariamente es múltiplo de 20
1 Respuesta
'***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) 'Destinatarios
dam.CC = Range("C" & i) 'Con copia
dam.Bcc = Range("D" & i) 'Con copia oculta
dam.Subject = Range("E" & i) '"Asunto"
dam.body = Range("F" & i) '"Cuerpo del mensaje"
'
For j = col To Cells(i, Columns.Count).End(xlToLeft).Column
archivo = Cells(i, j)
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 SubNuevamente muchas Gracias Dam
Prueba lo siguiente:
[code]Sub correo()'Por.Dante Amor
Dim col As Long, i As Long, j As Long, n As Long
Dim dam As Object, archivo As String
'
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) 'Destinatarios
dam.CC = Range("C" & i) 'Con copia
dam.Bcc = Range("D" & i) 'Con copia oculta
dam.Subject = Range("E" & i) '"Asunto"
dam.body = Range("F" & i) '"Cuerpo del mensaje"
'
For j = col To Cells(i, Columns.Count).End(xlToLeft).Column
archivo = Cells(i, j)
If archivo <> "" Then dam.Attachments.Add archivo
Next
DoEvents
n = n + 1
If n = 20 Then
n = 0
Application.Wait Now + TimeValue("0:00:10")
End If
Next
MsgBox "Correos enviados", vbInformation, "
Muchas ¡Gracias! Dam
Aaghhh! Otra vez el editor del foro recortó el código. Yo estoy solicitando que pongan el código con el icono para Insertar código; y al parecer yo mismo no lo hago.
He visto en este foro otras respuestas con palabras indecentes y no permiten la palabra:
"s a l u d o s". Es bastante ilógico, espero que Todoexpertos revise nuevamente sus palabras reservadas Víctor Fernández Portero .
Va de nuevo el código:
Sub correo()
'Por.Dante Amor
Dim col As Long, i As Long, j As Long, n As Long
Dim dam As Object, archivo As String
'
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) 'Destinatarios
dam.CC = Range("C" & i) 'Con copia
dam.Bcc = Range("D" & i) 'Con copia oculta
dam.Subject = Range("E" & i) '"Asunto"
dam.body = Range("F" & i) '"Cuerpo del mensaje"
'
For j = col To Cells(i, Columns.Count).End(xlToLeft).Column
archivo = Cells(i, j)
If archivo <> "" Then dam.Attachments.Add archivo
Next
DoEvents
n = n + 1
If n = 20 Then
n = 0
Application.Wait Now + TimeValue("0:00:10")
End If
Next
MsgBox "Correos enviados", vbInformation, "slds"
End Sub
