VBA Access. Módulo de clase clsMail para enviar correo usando CDO.

Option Compare Database
Option Explicit

Const CONNECTION_TIMEOUT = 60

Private m_ServidorSMTP As String
Private m_PuertoSMTP As Integer
Private m_MetodoEnvio As Integer
Private m_UsarAutenticacion As Integer
Private m_UsarSSL As Boolean
Private m_Usuario As String
Private m_Contrasena As String
Private m_From As String
Private m_ToAddress As String
Private m_CC As String
Private m_BCC As String

Public Enum formatBody
    Html = 1
    Text = 2
End Enum

Public Enum cdoSendMethod
    cdoSendUsingPickup = 1
    cdoSendUsingPort = 2
End Enum

Public Enum cdoUseAuthentication
    cdoAnonymous = 1
    cdoBasic = 2
    cdoNTLM = 3
End Enum

Private Sub Class_Initialize()
    'initialize values
    m_ServidorSMTP = ""
    m_PuertoSMTP = 25
   
    '1=cdoSendUsingPickup / 2=cdoSendUsingPort
    m_MetodoEnvio = cdoSendUsingPort
   
    '0=cdoAnonymous / 1=cdoBasic / 2=cdoNTLM
    m_UsarAutenticacion = cdoBasic
   
    m_UsarSSL = False
    m_Usuario = ""
    m_Contrasena = ""
    m_From = ""
    m_ToAddress = ""
    m_CC = ""
    m_BCC = ""

End Sub

Private Sub Class_Terminate()
    'deallocate if needed
End Sub

Public Property Get ServidorSMTP() As String
    ServidorSMTP = m_ServidorSMTP
End Property

Public Property Let ServidorSMTP(ByVal Value As String)
    m_ServidorSMTP = Value
End Property

Public Property Get PuertoSMTP() As Integer
    PuertoSMTP = m_PuertoSMTP
End Property

Public Property Let PuertoSMTP(ByVal Value As Integer)
    m_PuertoSMTP = Value
End Property

Public Property Get MetodoEnvio() As cdoSendMethod
    MetodoEnvio = m_MetodoEnvio
End Property

Public Property Let MetodoEnvio(ByVal Value As cdoSendMethod)
    m_MetodoEnvio = Value
End Property

Public Property Get UsarAutenticacion() As cdoUseAuthentication
    UsarAutenticacion = m_UsarAutenticacion
End Property

Public Property Let UsarAutenticacion(ByVal Value As cdoUseAuthentication)
    m_UsarAutenticacion = Value
End Property

Public Property Get UsarSSL() As Boolean
    UsarSSL = m_UsarSSL
End Property

Public Property Let UsarSSL(ByVal Value As Boolean)
    m_UsarSSL = Value
End Property

Public Property Get Usuario() As String
    Usuario = m_Usuario
End Property

Public Property Let Usuario(ByVal Value As String)
    m_Usuario = Value
End Property

Public Property Get Contrasena() As String
    Contrasena = m_Contrasena
End Property

Public Property Let Contrasena(ByVal Value As String)
    m_Contrasena = Value
End Property

Public Property Get From() As String
    From = m_From
End Property

Public Property Let From(ByVal Value As String)
    m_From = Value
End Property

Public Property Get ToAddress() As String
    ToAddress = m_ToAddress
End Property

Public Property Let ToAddress(ByVal Value As String)
    m_ToAddress = Value
End Property

Public Property Get CC() As String
    CC = m_CC
End Property

Public Property Let CC(ByVal Value As String)
    m_CC = Value
End Property

Public Property Get BCC() As String
    BCC = m_BCC
End Property

Public Property Let BCC(ByVal Value As String)
    m_BCC = Value
End Property

Public Function SendMail(ByVal sSubject As String, ByVal sBody As String, Optional fBody As formatBody = Text, Optional ByRef sAttachmentsArray As Variant) As String
On Error GoTo error
    Dim iMsg As Object
    Dim iConf As Object
    Dim Flds As Variant

    Set iMsg = CreateObject("CDO.Message")
    Set iConf = CreateObject("CDO.Configuration")

    'cdo  valores por defecto
    iConf.Load -1
   
    Set Flds = iConf.Fields
    With Flds
        .item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = m_ServidorSMTP
        .item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = m_PuertoSMTP

        '1=cdoSendUsingPickup / 2=cdoSendUsingPort
        .item("http://schemas.microsoft.com/cdo/configuration/sendusing") = m_MetodoEnvio
       
        '0=cdoAnonymous / 1=cdoBasic /2=cdoNTLM
        .item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = m_UsarAutenticacion
       
        'True/False
        .item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = m_UsarSSL

        .item("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = CONNECTION_TIMEOUT

        .item("http://schemas.microsoft.com/cdo/configuration/sendusername") = m_Usuario
        .item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = m_Contrasena

        .Update
    End With

    With iMsg
        Set .Configuration = iConf
        .To = m_ToAddress
        .CC = m_CC
        .BCC = m_BCC
        .From = m_From
        .Subject = sSubject
       
        If fBody = Text Then
            .TextBody = sBody
        Else
            .HtmlBody = sBody
        End If

        If Not IsMissing(sAttachmentsArray) Then
            If IsArray(sAttachmentsArray) Then
                Dim i As Integer
                For i = LBound(sAttachmentsArray) To UBound(sAttachmentsArray)
                    .AddAttachment sAttachmentsArray(i)
                Next i
            End If
        End If
        .Send
    End With

    Set iMsg = Nothing
    Set iConf = Nothing
    Set Flds = Nothing
   
    If Err.Number = 0 Then
        Debug.Print "Message sent successfully!"
        SendMail = ""
    End If

Exit Function
Resume
error:
    Debug.Print Err.Number & " " & Err.Description
    SendMail = Err.Number & " " & Err.Description
End Function