Envio de correo desde excel a varios destinatarios

[jeladio]

Hola amigos: no tengo muchos conocimientos en excel conseguí en alguna parte de la internet este codigo que me ha servido para enviar correos desde excel con el componente cdo, el caso es que quisiera que me enviara a una lista de destinatarios, pero uno por uno no de golpe, esto para enviar a mi listado de clientes boletines regulares (no spam), tuve la oportunidad de utilizar una aplicacion en access muy buena pero desafortunadamente envia todos los correos de golpe y por tal razon mi IP fue clasificado en la lista negra, por lo que se me ocurria pensar si era posible modificar este codigo para poder hacer los envios uno por uno quiza con un bucle o algo por el estilo, además si existiera la posibilidad de que se pudiera incluir una imagen en el fondo como en outlook o que mejor si se pudiera incluir una foto montada en internet, se que es mucho pedir pero si alguien puede ayudarme se lo voy a agradecer.

saludos desde Guatemala

[jeladio]

Perdon pero no habia incluido el codigo

.

saludos desde Guatemala

CODIGO

Function EnviarMails_CDO() As Boolean
'Este macro es el que envia los correos, notese las configuraciones, que son para gmail, y cuide de ubicar los datos correctos en las celdas correspondientes
'ademas para que funciones tiene que estar activada la funcion CDO for windowsw ubicado en referencias del menu herramientas
' Creo la variable de objeto CDO
Dim Email As CDO.Message
Dim Autentificion As Boolean
' ahora doy vida al objeto
Set Email = New CDO.Message
'indicamos los datos del servidor:
Email.Configuration.Fields(cdoSMTPServer) = Trim(Range("F30").Value)
Email.Configuration.Fields(cdoSendUsingMethod) = 2
'indicamos el nro de puerto. por defecto es el 25, pero gmail usa el 465. hay otro
'(que ahora no recuerdo) pero no me funcionaba... por eso no lo usé mas y lo olvidé
Email.Configuration.Fields.Item _
("[url=http://schemas.microsoft.com/cdo/configuration/smtpserverport]Error[/url]") = CLng(Trim(Range("J30").Value))
'aqui dejamos en claro si el servidor que usamos requiere o nó autentificación.
'1=requiere, 0=no requiere. Para gmail, entonces, 1
Email.Configuration.Fields.Item("[url=http://schemas.microsoft.com/cdo/]Error[/url]" & _
"configuration/smtpauthenticate") = Abs(1)
'segundos para el tiempo maximo de espera. aconsejo no modificarlo:
Email.Configuration.Fields.Item _
("[url=http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout]Error[/url]") = 30

'aqui defino como True (verdadera) a la autentificación para el envío de mails.
Autentificacion = True
'ahora configuramos las opciones de login de gmail:
If Autentificacion Then
'nombre de usuario
Email.Configuration.Fields.Item _
("[url=http://schemas.microsoft.com/cdo/configuration/sendusername]Error[/url]") = Trim(Range("d5").Value)
'contraseña
Email.Configuration.Fields.Item _
("[url=http://schemas.microsoft.com/cdo/configuration/sendpassword]Error[/url]") = Trim(Range("b30").Value)
'si el servidor utiliza SSL (secure socket layer). en gmail: True
Email.Configuration.Fields.Item _
("[url=http://schemas.microsoft.com/cdo/configuration/smtpusessl]Error[/url]") = Trim(Range("H30").Value)
End If
'a partir de ahora tomaremos los datos incluidos en el la hoja de excel:
' Dirección del Destinatario
Email.To = Trim([d7].Value) 'para
Email.CC = Trim([d9].Value)
Email.BCC = "Dirección de correo:
        [TABLE="class: outer_border, width: 75%"]
[TR]
[TD]Únicamente los administradores pueden visualizar esta información.
[/TD]
[/TR]
[/TABLE]
"
' Dirección del remitente
Email.From = Trim(Range("D30").Value)
' Asunto del mensaje se puede poner Trim([d3].Value) donde d3 puede ser dato de celda
Email.Subject = Trim([d11].Value)
' Cuerpo del mensaje se puede poner Trim([b14].Value)despues del signo igual
Email.TextBody = Trim([d13].Value)
'Trim(Workbooks("base.xlsm").Sheets("anexo").Range("j3").Value)
'Ruta del archivo adjunto
If Range("D28").Value <> vbNullString Then
Email.AddAttachment (Trim(Range("D28").Value))
End If
'antes de enviar actualizamos los datos:
Email.Configuration.Fields.Update
'colocamos un capturador de errores, por las dudas:
On Error Resume Next
'enviamos el mail
Email.Send
'si el numero de error es 0 (o sea, no existieron errores en el proceso),
'hago que la función retorne Verdadero
If Err.Number = 0 Then
EnviarMails_CDO = True
Else
'caso contrario, muestro un MsgBox con la descripcion y nro de error
MsgBox "Se produjo el siguiente error: " & Err.Description, vbCritical, "Error nro " & Err.Number
End If
'destruyo el objeto, para liberar los recursos del sistema
If Not Email Is Nothing Then
Set Email = Nothing
End If
'libero posibles errores
On Error GoTo 0
End Function[/PHP]