Excel - Envío de correos masivos sin caer en "posible spam".

Hola a todos, necesito de vuestra ayuda.

Tenemos un problema en nuestro proveedor de hosting para enviar correos masivos pues los marca a todos como "posible spam". Esto da como resultado que todos nuestros correos masivos van a a parar a las bandejas de correos no deseados de nuestros clientes y debido a ello no los leen.

El tema es que he querido usar macros para enviar de a uno en uno y cada 30 segundos, pero se me complicó el tema porque yo no estudié programación en visual básic, las macros que he hecho en el pasado ha sido modificando partes de otras macros.

Creo que mi idea de hacer que los correos se envíen de a uno no es mala y sería beneficiosa para todos. No encontré la forma de crear una macro efectiva desde el mismo Outlook porque no encontré como dirigir el código a cada una de las direcciones de correo por separado. Mi solución fue exportar los contactos a un archivo de excel .csv, y en ello he seleccionado sólo exportar la dirección de mail, ni siquiera es necesario exportar el nombre u otro dato,por lo que luego obtengo un listado en excel de una sola columna a la que le agrego la columna subject y la columna cuerpo del mensaje en cual auto copio hacia abajo para repetir el mismo mensaje. Ya con esto también he creado el botón y el código, el cual sería:




Sub enviarcorreo()
Dim i, j As Integer
Dim Contactos As Worksheet
Set Contactos = ActiveWorkbook.Worksheets("Contactos")
Dim OutApp As Object
Dim Correo As Object
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
'Comprobar si Outlook esta abierto y en caso de no estarlo abrirlo
On Error Resume Next
Set OutApp = GetObject("", "Outlook.Application")
Err.Clear
If OutApp Is Nothing Then Set OutApp = CreateObject("Outlook.Application")
OutApp.Visible = True
Set Correo = OutApp.CreateItem(0)
'Crear el correo y mostrarlo
With Correo
.To = Contactos.Range("A1").Value
.Subject = Contactos.Range("B1").Value
.HTMLBody = Contactos.Range("C1").Value
' .Display
.Send
End With
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub

EL CÓDIGO FUNCIONA, SÍ SE ENVÍA EL CORREO




Sub esperar()
newHour = Hour(Now())
newMinute = Minute(Now())
newSecond = Second(Now()) + 30
waitTime = TimeSerial(newHour, newMinute, newSecond)
Application.Wait waitTime
End Sub

ME PARECE QUE TAMBIÉN FUNCIONA, PERO COMO AÚN NO TIENE EL LOOP NO PUEDO CORROBORARLO


Y A CONTINUACIÓN TENGO DOS CÓDIGOS PARA PASAR A LA FILA SIGUIENTE Y QUE SE ENVIÉ EL SEGUNDO CORREO TRAS LOS 30 SEGUNDOS DE ESPERA Y LUEGO EL TERCERO, ETC. PERO NO SÉ COMO IMPLEMENTARLOS

Sub IncrementarFila()
Dim Seleccionar As Integer
Escribir = 1
Do While Seleccionar < 7
ActiveCell.FormulaR1C1 = "Excel"
lastrow = Cells(Rows.Count, 1).End(xlUp).Row
Cells(lastrow, 1).Offset(1, 0).Select
Escribir = Escribir + 1
Loop
End Sub


Sub IncrementarFila()
ActiveCell.Offset(1, 0).Activate
End Sub





ALGUIEN CON TIEMPO, DE BUEN CORAZÓN Y ALMA BONDADOSA QUE ME TIRE UN SALVAVIDAS, PLEASE :D

TAL VEZ SEA MEJOR PASARLO TODO A ACCESS, NO SÉ... ¿ALGUNA IDEA? GRACIAS.

Aquí tienes un código que funciona. Básicamente es el tuyo retocado para incluirle un bucle que recorre las filas. Espero que te sirva


Saludos,

Genial, gracias Paco, funciona y funciona perfecto. Muchísimas gracias por tu ayuda.

Hola estimado, puedes enviar el archivo corregido? Me gustaría adaptarlo para GMAIL

Hice un sistema de notificación de emisión de facturas y enviábamos alrededor de 800 mensajes de un tirón.

Para no saturar la cuenta de Outlook, puse un retardo de 500 milisegundos, que es tiempo suficiente como para recibir los mensajes del servidor entrante en caso de "fuera de la oficina" o errores de entrega.

30 segundos entre mensaje y mensaje es mucho tiempo, a no ser que tengas un equipo dedicado a ello.

Hola. Puedes subir el archivo?