CSendMail.cls

Option Explicit

'
' CSendMail.cls - wraps CDO allowing to send email messages
'                 using an SMTP server; supports attachments
'                 and HTML emails
'


' SMTP authentication modes
Public Enum enAuthMode
  amAnonymous = 0             ' anonymous
  amBasic = 1                 ' basic (standard)
  amNTLM = 2                  ' NTLM (only supported by Exchange)
End Enum

' return receipt flags
Public Enum enReceiptFlags
  rfDefault = 0               ' use defaults
  rfNever = 1                 ' no receipt/notification
  rfFailure = 2               ' failure notification
  rfSuccess = 4               ' success notification
  rfDelay = 8                 ' delay notification
  rfAll = 14                  ' all notifications
End Enum

' HTML body type
Public Enum enHtmlBodyType
  htNone = 0                  ' no HTML body
  htHTML = 1                  ' HTML body from string
  htURL = 2                   ' HTML body from URL
  htFile = 3                  ' HTML body from file
End Enum

' events
Public Event Failure(ByVal lNum As Long, ByVal sMsg As String, ByVal sInfo As String)
Public Event Warning(ByVal sMsg As String)
Public Event Notice(ByVal sMsg As String)

' internal constants
Private Const DEFAULT_SERVER As String = "localhost"
Private Const DEFAULT_PORT As Long = 0
Private Const DEFAULT_TIMEOUT As Long = 30
Private Const FILE_URL As String = "file://"
Private Const MSG_HEADERS As String = "urn:schemas:mailheader:"
Private Const CDO_CONFIG As String = "http://schemas.microsoft.com/cdo/configuration/"
Private Const SMTP_PORT As Long = 25
Private Const SMTP_SSL_PORT As Long = 465
Private Const SMTP_SEND_MODE As Long = 2 ' cdoSendUsingPort

' server configuration
Private msServer    As String     ' SMTP server name or IP
Private mlPort      As Long       ' SMTP server port
Private mlTimeOut   As Long       ' server connection timeout
Private mbUseSSL    As Boolean    ' True = use SSL (not TLS!)
Private mnAuthMode  As enAuthMode ' authentication mode
Private msUser      As String     ' user name for auth
Private msPass      As String     ' password for auth

' last error data
Private mlErrNum    As Long       ' last error number
Private msErrMsg    As String     ' last error description
Private msErrInfo   As String     ' additional error informations

' CDO configuration
Private mbReconfig  As Boolean    ' True if CDO reconfig is needed
Private mobjCDOcfg  As Object     ' object containing the CDO config

' other stuff
Private objFSO      As Object     ' object used to access the filesystem

' ================================================================
' CLASS INSTANCE
' ================================================================

' constructor
Private Sub Class_Initialize()
  On Local Error Resume Next
  mbReconfig = True
  msServer = DEFAULT_SERVER
  mlPort = DEFAULT_PORT
  mlTimeOut = DEFAULT_TIMEOUT
  mbUseSSL = False
  mnAuthMode = amAnonymous
  msUser = ""
  msPass = ""
  SetError 0, "", ""
  Err.Clear
  Set objFSO = CreateObject("Scripting.FileSystemObject")
  If Err.Number <> 0 Then
    SetError Err.Number, Err.Description, "Initialize"
  End If
End Sub

' destructor
Private Sub Class_Terminate()
  Set mobjCDOcfg = Nothing
  Set objFSO = Nothing
End Sub

' ================================================================
' PUBLIC PROPERTIES
' ================================================================

' server name or IP
Public Property Let Server(ByVal sServer As String)
  msServer = Trim(sServer)
  If Len(msServer) < 1 Then
    msServer = DEFAULT_SERVER
  End If
  mbReconfig = True
End Property

' port number, 0=autoconfig
Public Property Let Port(ByVal lPort As Long)
  mlPort = lPort
  If (mlPort < 1) Or (mlPort > 65535) Then
    mlPort = DEFAULT_PORT
  End If
  mbReconfig = True
End Property

' connection timeout
Public Property Let ConnTimeOut(ByVal lTimeOut As Long)
  mlTimeOut = lTimeOut
  If mlTimeOut < 0 Then
    mlTimeOut = DEFAULT_TIMEOUT
  End If
  mbReconfig = True
End Property

' true to use SSL (not TLS, CDO doesn't support it)
Public Property Let UseSSL(ByVal bYesNo As Boolean)
  mbUseSSL = bYesNo
  mbReconfig = True
End Property

' authentication mode
Public Property Let AuthMode(ByVal nMode As enAuthMode)
  mnAuthMode = nMode
  mbReconfig = True
End Property

' user name
Public Property Let User(ByVal sUser As String)
  msUser = Trim(sUser)
  mbReconfig = True
End Property

' password
Public Property Let Password(ByVal sPassword As String)
  msPass = Trim(sPassword)
  mbReconfig = True
End Property

' last error number
Public Property Get ErrNum() As Long
  ErrNum = mlErrNum
End Property

' last error message
Public Property Get ErrMsg() As String
  ErrMsg = msErrMsg
End Property

' last error informations
Public Property Get ErrInfo() As String
  ErrInfo = msErrInfo
End Property

' ================================================================
' PUBLIC METHODS
' ================================================================

' send an email message
Public Function SendMail(ByVal sFrom As String, _
                         ByVal sTo As String, _
                         ByVal sCc As String, _
                         ByVal sBCc As String, _
                         ByVal sSubject As String, _
                         ByVal sTextBody As String, _
                         Optional ByVal nReceipt As enReceiptFlags = rfDefault, _
                         Optional ByVal nHtmlType As enHtmlBodyType = htNone, _
                         Optional ByVal sHtmlData As String = "", _
                         Optional ByVal colAttach As Collection _
                         ) As Boolean
  Dim objMsg As Object
  Dim sConf As String, sFile As String, sURL As String
  Dim vItem As Variant
  Dim bResult As Boolean

  ' init
  bResult = False
  SendMail = bResult
  SetError 0, "", ""


  ' check if the config needs to be initialized
  ' this is done once so that sending multiple
  ' mail messages will be faster, the config is
  ' only recreated if some propery is changed
  If Not InitConfig() Then
    Exit Function
  End If

  On Local Error GoTo Catch

  ' perform some sanity checks and raise
  ' warning in case of missing parameters
  If Len(Trim(sFrom)) = 0 Then
    RaiseEvent Warning("No sender address")
  End If
  sConf = Trim(sTo) & Trim(sCc) & Trim(sBCc)
  If Len(sConf) = 0 Then
    RaiseEvent Warning("No recipient address")
  End If
  If Len(Trim(sSubject)) < 1 Then
    RaiseEvent Warning("Empty subject")
  End If
  If Len(Trim(sTextBody)) < 1 Then
    RaiseEvent Warning("Empty text body")
    If nHtmlType <> htNone Then
      sTextBody = vbCrLf & "Please use an HTML capable e-mail reader" & vbCrLf
    End If
  End If

  ' create the new email message
  RaiseEvent Notice("Creating a new e-mail message")
  Set objMsg = CreateObject("CDO.Message")
  With objMsg
    Set .Configuration = mobjCDOcfg
    ' base infos
    .From = sFrom
    .To = sTo
    .Cc = sCc
    .BCc = sBCc
    .Subject = sSubject
    .TextBody = sTextBody
    ' handle HTML body (if any)
    If nHtmlType <> htNone Then
      Select Case nHtmlType
        Case htHTML
          ' straight HTML code string
          .HTMLBody = sHtmlData
        Case Else
          sURL = sHtmlData
          If nHtmlType = htFile Then
            sFile = GetFileName(sURL)
            If Len(sFile) > 0 Then
              ' file://x:/path/name/file.xyz
              sURL = FILE_URL & Replace(sFile, "\", "/")
            Else
              RaiseEvent Warning("HTML file not found: " & sURL)
              sURL = ""
            End If
          End If
          If Len(sURL) > 0 Then
            RaiseEvent Notice("Creating HTML body from " & sURL)
            .CreateMHTMLBody sURL
          End If
      End Select
    End If
    ' Add attachments (if any)
    If Not IsMissing(colAttach) Then
      If Not colAttach Is Nothing Then
        For Each vItem In colAttach
          sFile = Trim(vItem)
          If Len(sFile) > 0 Then
            sFile = GetFileName(sFile)
            If Len(sFile) > 0 Then
              RaiseEvent Notice("Adding attachment " & sFile)
              .Addattachment sFile
            Else
              RaiseEvent Warning("Attachment not found: " & vItem)
            End If
          End If
        Next
      End If
    End If
    ' Return receipts / notify
    If (nReceipt <> rfNever) And (nReceipt <> rfDefault) Then
      sConf = MSG_HEADERS
      .Fields(sConf & "disposition-notification-to") = sFrom
      .Fields(sConf & "return-receipt-to") = sFrom
    End If
    .DSNOptions = nReceipt
    .Fields.Update
  End With

  ' send the message
  RaiseEvent Notice("Sending the e-mail message")
  objMsg.Send
  bResult = True
  RaiseEvent Notice("E-mail message successfully sent")

BailOut:
  ' common exit
  Set objMsg = Nothing
  SendMail = bResult
  Exit Function

Catch:
  ' got an error
  SetError Err.Number, Err.Description, "CDO message"
  bResult = False
  Resume BailOut
End Function

' ================================================================
' PRIVATE CODE
' ================================================================

' initialize the CDO configuration
Private Function InitConfig() As Boolean
  Dim sConf As String
  Dim objFlds As Object
  Dim bResult As Boolean

  ' need to reconfigure the CDO ?
  If mbReconfig = False Then
    InitConfig = True
    Exit Function
  End If

  On Local Error GoTo Catch

  ' initialize, notice how the server port is automatically
  ' selected (if set to 0) according to the SSL flag
  bResult = False
  If mlPort = DEFAULT_PORT Then
    If mbUseSSL Then
      mlPort = SMTP_SSL_PORT  ' SMTP over SSL
    Else
      mlPort = SMTP_PORT      ' standard SMTP
    End If
  End If


  RaiseEvent Notice("Configuring SMTP server " & msServer & ":" & mlPort)

  ' instance the configuration object
  Set mobjCDOcfg = Nothing
  Set mobjCDOcfg = CreateObject("CDO.Configuration")

  ' set configuration
  sConf = CDO_CONFIG
  Set objFlds = mobjCDOcfg.Fields
  With objFlds
    .Item(sConf & "sendusing") = SMTP_SEND_MODE
    .Item(sConf & "smtpserver") = msServer
    .Item(sConf & "smtpusessl") = IIf(mbUseSSL, 1, 0)
    .Item(sConf & "smtpserverport") = mlPort
    .Item(sConf & "smtpconnectiontimeout") = mlTimeOut
    .Item(sConf & "smtpauthenticate") = mnAuthMode
    If mnAuthMode = amAnonymous Then
      ' no authentication
      .Item(sConf & "sendusername") = ""
      .Item(sConf & "sendpassword") = ""
    Else
      ' use authentication
      .Item(sConf & "sendusername") = msUser
      .Item(sConf & "sendpassword") = msPass
      If (Len(msUser) < 1) Or (Len(msPass) < 1) Then
        RaiseEvent Warning("Empty Username or Password")
      End If
    End If
    .Update
  End With

  ' all ok
  RaiseEvent Notice("Configuration complete")
  mbReconfig = False
  bResult = True

BailOut:
  ' common exit
  Set objFlds = Nothing
  InitConfig = bResult
  Exit Function

Catch:
  ' got an error
  SetError Err.Number, Err.Description, "CDO configuration"
  bResult = False
  Resume BailOut
End Function

' store and signal an error
Private Sub SetError(ByVal lNum As Long, _
                     ByVal sMsg As String, _
                     ByVal sInfo As String)
  mlErrNum = lNum
  msErrMsg = sMsg
  msErrInfo = sInfo
  If lNum <> 0 Then
    msErrMsg = Trim(Replace(msErrMsg, vbCrLf, " "))
    RaiseEvent Failure(mlErrNum, msErrMsg, msErrInfo)
  End If
End Sub

' get the full pathname for a given file
Function GetFileName(ByVal sPathName As String) As String
  Dim fi As Object
  Dim sFullName As String

  On Local Error Resume Next
  GetFileName = ""
  If Not objFSO.FileExists(sPathName) Then
    Exit Function
  End If
  Set fi = objFSO.GetFile(sPathName)
  sFullName = fi.Path

  Set fi = Nothing
  GetFileName = sFullName
End Function