Macro para correo

[MrVera]

Hola a todos, soy nuevo en el foro. Quisiera ver si me puede ayudar.

Actualmente trabajo en call center y tengo que enviar reportes estadisticos. Ya logre hacer la generacion de los repotes y en el envio masivo.

solo me falta el poder enviar imagenes en el cuerpo del correo y poner firma en RTF, esto hasta el momento no lo he podido hacer ¿Alguien me puede ayudar? Se los agradecer mucho.

Este el codigo del envío

Sub Envio()

Application.ScreenUpdating = False

'Declaracion de Dim's

Dim acc As Object

Dim dns As Object

Dim ruta As String

Dim rutaLiga As String

Dim Zerato As Object

Dim OutApp As Object

Dim OutMail As Object

Dim fso As Object

Dim ts As Object

Dim strbody As String

Dim ruta As String

Dim Firma As String

Application.DisplayAlerts = False

'Asignar Valores

Z = 0

ruta = "C:\Documents and Settings\mario.vera\Mis documentos\"

rutaLiga = "http://10.252.195.26/TPK/Seiya/Reportes/Retro/"

Set Zer = Sheets("Fechas").Range("B3")

'Hacer mientras sea diferente que el 1er Set a valga nada

Do While Zer.Offset(Z, 0) <> ""

'Valor de Fecha

Fecha = Zer.Offset(Z, 0)

'Valor de Mes y dia para la creacion de archivo de la liga

mes = Format(Zer.Offset(Z, 0), "MMM")

dia = Format(Day(Zer.Offset(Z, 0)), "00")

Valida_dia = Format(Zer.Offset(Z, 0), "dddd")

'Para mes anterior

Fecha_mes_anterior = Fecha - 1

Mes_anterior = Format(Fecha_mes_anterior, "MMM")

dia_anterior = Format(Day(Fecha_mes_anterior), "00")

Mes_anterior2 = Format(Fecha_mes_anterior, "M")

'Creacion de conexion

Set dns = CreateObject("ADODB.Connection")

dns.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & ruta & "Datos.mdb" & ";Persist Security Info=False"

dns.Open

Set acc = CreateObject("ADODB.Recordset")

Sql = "SELECT * FROM Datos_SD"

acc.Open Sql, dns

acc.MoveFirst

Do While acc.EOF = False 'Hacer hasta que el recorrido de Access sea null

'Declaracion de Valores para Access

campaña = acc.fields("Campaña") 'Campaña

Apli = acc.fields(1) 'Apli

Hora_Ini = acc.fields(2) 'Hora_Ini_Real

Hora_Fin = acc.fields(4) 'Hora_Fin_Real

Hora_Ini2 = acc.fields(3) 'Hora_Ini_Para_Celdas

Hora_Fin2 = acc.fields(6) 'Hora_fin_Para_Celdas

Hora_Media_Adela = acc.fields(5) 'Hora_fin_Media_Adelante

ACCM = acc.fields(7) 'ACM Responsable

MetaSL = acc.fields(8) 'Meta Nivel de Serivicio

MetaOCCY = acc.fields(9) 'Meta Occupancy

NomCampaña = acc.fields(10) 'Nombre de Campaña Real

destinatarios = acc.fields(11) 'Nombre de Campaña Real

'Correo

Set OutApp = CreateObject("Outlook.Application")

OutApp.Session.logon

Set OutMail = OutApp.CreateItem(0)

strbody = "Buen día," & vbNewLine & _

"Anexo los reportes a día vencido" & vbNewLine & _

ruta = "C:\Documents and Settings\mario.vera\Datos de programa\Microsoft\Firmas\Firma.txt"

Set fso = CreateObject("Scripting.FileSystemObject")

Set ts = fso.GetFile(ruta).OpenAsTextStream(1, -2)

Firma = ts.readall

ts.Close

On Error Resume Next

With OutMail

.To = destinatarios

.CC = ""

.BCC = ""

.Subject = "ACD| Reporte " & NomCampaña & " APL " & Apli & " al día " & dia & " de " & mes

.Body strbody & vbNewLine & vbNewLine & Firma

.Attachments.Add "C:\Documents and Settings\mario.vera\Mis documentos\Nuevos Reportes\" & campaña & "\" & Apli & "\" & mes & "\" & campaña & "_" & dia & "_" & mes & ".xls"

.Send

End With

Set OutMail = Nothing

Set OutApp = Nothing

acc.MoveNext

Loop 'Cierre mientras es igual a vacio

Z = Z + 1

Loop 'Cierre de Zer Valga Nada

End Sub