Aquí lo tienes.
'*******************************************************************************
'* mdlEnviarCorreo
'* Envío de email a traves de CDO
'* Búho 01/02/05
'*******************************************************************************
Option Compare Database
Option Explicit
'aqui cambia el servidor de correo saliente, usuario y contraseña segun proceda.
'lo pongo a piñon fijo, que lo cambie el programador de cada applicación
Private Const StrServer As String = "smtp.gmail.com"
Public Const strusuario As String = "info.numisoftware@gmail.com"
Private Const strpassword As String = "************"
Function EnviaCorreo(Optional IntFormato As Integer = 1)
Dim ObjetoMensajeLibre As Object, strHTML As String
Dim strRutaAdjunto As String
Dim strCuerpo As String
strRutaAdjunto = CurrentProject.Path & "\LogErrores.txt"
strCuerpo = "Incidencia de Numisoftware_1.0.0.0, se adjunta fichero."
'Enviando Correo utilizando autentificación remota del server
' Creamos el objeto.
On Error GoTo EnviaCorreoLibre_Err
Set ObjetoMensajeLibre = CreateObject("CDO.Message")
' A quien va el mensaje. Para multimples destinos, separa las direcciones de correo por «;»
ObjetoMensajeLibre.To = "info.numisoftware@gmail.com"
' Aquí va el asunto
ObjetoMensajeLibre.Subject = "Incidencia en el programa, Numisoftware_2.5.0."
'Quien envía el correo. ! ojo ! solo funciona con esta sitaxis:
' Nombre <tucuenta@tuservidor.com>
'es decir, por ejemplo: Francisco Javier garcía Aguado<paco@nemo.es>
'Ojo al dato pues
' OJO OJO OJO OJO :
ObjetoMensajeLibre.FROM = "Numisoftware_2.5.0<info.numisoftware@gmail.com>"
'se rechaza si no se recibe una cadena tipo <algo@algo.es>
Select Case IntFormato
Case 1
'Aqui va el cuerpo sin formato
ObjetoMensajeLibre.TextBody = "Incidencia de Numisoftware_2.5.0, se adjunta fichero."
Case 2
' Si quieres formato HTML:
' Formato HTML en el cuerpo del mensaje.
strHTML = "<HTML>"
strHTML = strHTML & "<HEAD>"
strHTML = strHTML & "<BODY>"
strHTML = strHTML & _
"<b>" & Replace(strCuerpo, vbCrLf, "<Br>") & "</b></br>"
strHTML = strHTML & "</BODY>"
strHTML = strHTML & "</HTML>"
ObjetoMensajeLibre.HTMLBody = strHTML
Case Else
ObjetoMensajeLibre.TextBody = strCuerpo
End Select
' Para fichero adjunto:
If Len(strRutaAdjunto) <> 0 Then
ObjetoMensajeLibre.addattachment ("file://" & strRutaAdjunto)
End If
'****************************************************
'Aqui comienza en si las configuraciones del server de correo remoto
' ****************************************************
ObjetoMensajeLibre.Configuration.Fields.Item( _
"http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
' Aquí puedes poner, bien el literal, bien la IP
'de la maquina remota del server.
ObjetoMensajeLibre.Configuration.Fields.Item( _
"http://schemas.microsoft.com/cdo/configuration/smtpserver") = _
StrServer ' recuerda, _
es tu servidor de correo...lo puedes ver en las configuraciones
' de tu gestor de correo
'Ahora especificamos el tipo de autentificacion que el server espera:
ObjetoMensajeLibre.Configuration.Fields.Item( _
"http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
'ConstanteCDOA_Basica
' Aquí el nombre de usuario que el sever espera recibir(Lo puedes ver en las configuraciones
'de las cuentas de Outlook y Outlook Express:
ObjetoMensajeLibre.Configuration.Fields.Item( _
"http://schemas.microsoft.com/cdo/configuration/sendusername") = _
strusuario
' Aquí el password (Contraseña) del usuario (Tambien la sacas de la configuracion del OE & Outlook)
ObjetoMensajeLibre.Configuration.Fields.Item( _
"http://schemas.microsoft.com/cdo/configuration/sendpassword") = _
strpassword
'Aqui el puerto. Casi siempre el 25.... asi que lo dejo a a piñon fijo
ObjetoMensajeLibre.Configuration.Fields.Item( _
"http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 465
'Si estas usando SSL para la conexión. Valores (False or True)
ObjetoMensajeLibre.Configuration.Fields.Item( _
"http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
' Tiempo en segundos para que se establezca correctamente el protocolo SMTP.
ObjetoMensajeLibre.Configuration.Fields.Item( _
"http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = 60
' Guardamos....
ObjetoMensajeLibre.Configuration.Fields.Update
DoCmd.Hourglass True
' Y ! POR FIN ! enviamos
ObjetoMensajeLibre.Send
Screen.MousePointer = 0
If Not ObjetoMensajeLibre Is Nothing Then
Set ObjetoMensajeLibre = Nothing
End If
MsgBox DaMsg(398)
Screen.MousePointer = vbNormal
EnviaCorreoLibre_Exit:
Exit Function
EnviaCorreoLibre_Err:
MsgBox "Error nº " & Err.Number & vbCrLf & Err.Description & vbCrLf & _
"en procedimiento EnviaCorreoLibre de Módulo ModuloCdo", vbCritical, "Aviso de error"
Resume EnviaCorreoLibre_Exit
End Function