Public Sub CorreoHTML(Destinatario As String, Asunto As String, Texto As String, HTML As String)
Dim Fecha As String
Dim Id As String
lblEnviando.Caption = "Enviando correo a" + Destinatario
StatusBar.SimpleText = "Preparando los datos a enviar"
Barra.Value = 0
Me.Refresh
DoEvents
Fecha = Date
wsDestinatario = Destinatario
Randomize
' Preparamos el mensaje para ser enviado más adelante
Id = Format(Fecha, "DDMMYYYY") + Format(Time, "HHMMSS") + Format(Int(Rnd * 10000000), "#######")
Frontera = "_Separador_" + Id
Fecha = DiaDeLaSemana(Weekday(Fecha)) + ", " + CStr(Day(Fecha)) + " " + MesDelAno(Month(Fecha)) + " " + CStr(Year(Fecha)) + Format(Time, " hh:dd:ss")
Mime = "Message-ID: <" + Id + "@InfoShop>" + vbCrLf + _
"Reply-To: """ + CorreoRespuesta + """ <" + CorreoDescripcion + ">" + vbCrLf + _
"From: """ + CorreoRemitente + """ <" + CorreoDescripcion + ">" + vbCrLf + _
"To: <" + wsDestinatario + ">" + vbCrLf + _
"Subject: " + Asunto + vbCrLf + _
"Date: " + Fecha + " +0200" + vbCrLf + _
"MIME-Version: 1.0" + vbCrLf + _
"Content-Type: multipart/alternative;" + vbCrLf + _
vbTab + "boundary=""" + Frontera + """" + vbCrLf + _
"X-Mailer: InfoSHOP by InterCOM Redes Informaticas" + vbCrLf + _
vbCrLf
Mime = Mime + "--" + Frontera + vbCrLf + _
"Content-Type: text/plain; charset=""iso-8859-1""" + vbCrLf + _
"Content-Transfer-Encoding: quoted-printable" + vbCrLf + _
vbCrLf + _
Quoted(Texto) + vbCrLf + vbCrLf
Mime = Mime + "--" + Frontera + vbCrLf + _
"Content-Type: text/html; charset=""iso-8859-1""" + vbCrLf + _
"Content-Transfer-Encoding: quoted-printable" + vbCrLf + _
vbCrLf + _
"" + vbCrLf + _
Quoted(HTML) + vbCrLf + _
vbCrLf + "--" + Frontera + "--" + vbCrLf + vbCrLf + "." + vbCrLf
StatusBar.SimpleText = "Conectando a " + ServidorSMTP
' Conectamos el socket.. y dejamos trabajar la máquina de estados
On Error GoTo Error_Tx
wsCorreo.Connect
On Error GoTo 0
Exit Sub
Error_Tx:
MsgBox "Error conectando con el servidor de correo", vbExclamation
Unload Me
End Sub
Este es parte del código de un módulo hecho por mí que envia páginas web. Si deseas adjuntar fotos,
sólo tienes q codificar en base64 la imagen y añadirla como un campo Mime más.
Digamos que cuando se selecciona el "boundary" o frontera entre campos Mime, lo primero q envías es
el texto en plano, luego el texto con formato (HTML) y posteriormente los archivos que desees.
Aquí te mando algunas funciones para codificar el texto en formato iso-8859-1:
Private Function Quoted(ByVal Cadena As String) As String
' Hacemos el cambio para la compatibilidad con la norma ISO-8859-1
Cadena = Replace(Cadena, "=", "=3D")
Cadena = Replace(Cadena, """", "=22")
Cadena = Replace(Cadena, "á", "=E1")
Cadena = Replace(Cadena, "é", "=E9")
Cadena = Replace(Cadena, "í", "=ED")
Cadena = Replace(Cadena, "ó", "=F3")
Cadena = Replace(Cadena, "ú", "=FA")
Cadena = Replace(Cadena, "Á", "=C1")
Cadena = Replace(Cadena, "É", "=C9")
Cadena = Replace(Cadena, "Í", "=CD")
Cadena = Replace(Cadena, "Ó", "=D3")
Cadena = Replace(Cadena, "Ú", "=DA")
Cadena = Replace(Cadena, "ñ", "=F1")
Cadena = Replace(Cadena, "Ñ", "=D1")
Quoted = Cadena
End Function
Y aquí una pequeña utilidad para pasar textos a HTML:
Public Function Marcar(ByVal Cadena As String) As String
Cadena = Replace(Cadena, "á", "á")
Cadena = Replace(Cadena, "é", "é")
Cadena = Replace(Cadena, "í", "í")
Cadena = Replace(Cadena, "ó", "ó")
Cadena = Replace(Cadena, "ú", "ú")
Cadena = Replace(Cadena, "Á", "Á")
Cadena = Replace(Cadena, "É", "É")
Cadena = Replace(Cadena, "Í", "Í")
Cadena = Replace(Cadena, "Ó", "Ó")
Cadena = Replace(Cadena, "Ú", "Ú")
Cadena = Replace(Cadena, "ñ", "ñ")
Cadena = Replace(Cadena, "Ñ", "Ñ")
Marcar = Cadena
End Function
Ahora mismo no tengo el código a mano del codificador Base64 para las imágenes, pero mandame email y
te lo paso en cuanto lo encuentre ;) Espero q te sean útil esas funciones al menos para crear una
página con un enlace a la página que desees, quizá un javascript que cargue tras x segundos una página
web... échale imaginación mientras te pillo lo que falta ;)