'******************************************************
' *
' * Name:         clsCdoEmail
' *
' * Design Phase:
' *     Author:   John Miner
' *     Date:     06/01/2011
' *     Purpose:  Send an email via SMTP relaying using
'*		  the CDO object.
' *
' ******************************************************


'
' Class Usage
'
' 1.0  Must set the following required properties
'      - SMTP_SVR
'      - FROM_EMAIL
'      - TO_EMAIL
'      - MSG_SUBJECT
'      - MSG_BODY - text or html
'
' 2.0  set the following optional properties
'      - CC_EMAIL
'      - BCC_EMAIL
'      - BODY_TYPE = text or html
'      - MSG_ATT = tilda seperated list of full file names
'
' 3.0  Call the SEND_EMAIL method to release the email.
'

' Define all variables
Option Explicit

' Define constants
Public Const LOCAL_SVR = 1
Public Const REMOTE_SVR = 2
Public Const SMTP_PORT = 25

' Define constants
Public Const MSG_LOW = 1
Public Const MSG_MED = 2
Public Const MSG_HIGH = 3

' Define Importance Values
Private Const cdoLow = 0
Private Const cdoNormal = 1
Private Const cdoHigh = 2

' Define Priority  Values
Private Const cdoPriorityNonUrgent = -1
Private Const cdoPriorityNormal = 0
Private Const cdoPriorityUrgent = 1


'
' Define the class
'

Class clsCdoEmail


    ' -- Data element 1 --
    Private strSmtpServer
        
    Public Property Get SMTP_SVR
        SMTP_SVR = strSmtpServer
    End Property
    
    Public Property Let SMTP_SVR(varSmtpServer)
        strSmtpServer = varSmtpServer
    End Property


    ' -- Data element 2 --
    Private strFromEmail
        
    Public Property Get FROM_EMAIL
        FROM_EMAIL = strFromEmail
    End Property
    
    Public Property Let FROM_EMAIL(varFromEmail)
        strFromEmail = varFromEmail
    End Property


    ' -- Data element 3 --
    Private strToEmail
        
    Public Property Get TO_EMAIL
        TO_EMAIL = strToEmail
    End Property
    
    Public Property Let TO_EMAIL(varToEmail)
        strToEmail = varToEmail
    End Property


    ' -- Data element 4 --
    Private strCcEmail
        
    Public Property Get CC_EMAIL
        CC_EMAIL = strCcEmail
    End Property
    
    Public Property Let CC_EMAIL(varCcEmail)
        strCcEmail = varCcEmail
    End Property


    ' -- Data element 5 --
    Private strBccEmail
        
    Public Property Get BCC_EMAIL
        BCC_EMAIL = strBccEmail
    End Property
    
    Public Property Let BCC_EMAIL(varBccEmail)
        strBccEmail = varBccEmail
    End Property


    ' -- Data element 6 --
    Private strMsgSubject
        
    Public Property Get MSG_SUBJECT
        MSG_SUBJECT = strMsgSubject
    End Property
    
    Public Property Let MSG_SUBJECT(varMsgSubject)
        strMsgSubject = varMsgSubject
    End Property


    ' -- Data element 7 --
    Private strMsgBody
        
    Public Property Get MSG_BODY
        MSG_BODY = strMsgBody
    End Property
    
    Public Property Let MSG_BODY(varMsgBody)
        strMsgBody = varMsgBody
    End Property


    ' -- Data element 8 --
    Private strBodyType
        
    Public Property Get BODY_TYPE
        BODY_TYPE = strBodyType
    End Property
    
    Public Property Let BODY_TYPE(varBodyType)
        If UCASE(varBodyType) = "TEXT" or UCASE(varBodyType) = "HTML" Then
            strBodyType = UCASE(varBodyType)
        End If
    End Property


    ' -- Data element 9 --
    Private strMsgAtt
        
    Public Property Get MSG_ATT
        MSG_ATT = strMsgAtt
    End Property
    
    Public Property Let MSG_ATT(varMsgAtt)
        strMsgAtt = varMsgAtt
    End Property


    ' -- Data element 10 --
    Private strMsgPriority
        
    Public Property Get MSG_PRIORITY
        MSG_PRIOIRITY = strMsgPriority
    End Property
    
    Public Property Let MSG_PRIORITY(varMsgPriority)
        strMsgPriority = varMsgPriority
    End Property


    '
    '  Initialize the class
    '
    
    Private Sub Class_Initialize()
    
	strSmtpServer = ""
        strFromEmail = ""
        strToEmail = ""
        strCcEmail = ""
        strBccEmail = ""
        strMsgSubject = ""
        strMsgBody = ""
        strBodyType = "TEXT"
        strMsgAtt = ""
        strMsgPriority = MSG_MED

    End Sub


    '
    '  Interface for sending email
    '
    Public Sub SEND_EMAIL()


        ' Create the cdo object
        Dim objMsg
        Set objMsg = CreateObject("CDO.Message")

        ' Grab email properties
        objMsg.Sender = strFromEmail
        objMsg.From = strFromEmail       
        objMsg.To = strToEmail 
        objMsg.Cc = strCcEmail
        objMsg.Bcc = strBccEmail

        ' Set the subject of the message        
        objMsg.Subject = strMsgSubject

        ' Regular or html text for the message body?
        If strBodyType = "TEXT" Then
            objMsg.TextBody = strMsgBody
        Else
            objMsg.HtmlBody = strMsgBody
        End If

        ' Low priority
        If strMsgPriority = MSG_LOW Then

            ' Message priority
            objMsg.Fields.Item _
            ("urn:schemas:mailheader:X-Priority") = cdoPriorityNonUrgent

            objMsg.Fields.Item _
           ("urn:schemas:mailheader:X-MSMail-Priority") = cdoPriorityNonUrgent

            objMsg.Fields.Item _
           ("urn:schemas:httpmail:importance") = cdoLow

            objMsg.Fields.Update
        End If


        ' Medium priority
        If strMsgPriority = MSG_MED Then

            ' Message priority
            objMsg.Fields.Item _
            ("urn:schemas:mailheader:X-Priority") = cdoPriorityNormal

            objMsg.Fields.Item _
           ("urn:schemas:mailheader:X-MSMail-Priority") = cdoPriorityNormal

            objMsg.Fields.Item _
           ("urn:schemas:httpmail:importance") = cdoNormal

            objMsg.Fields.Update
        End If


        ' High priority
        If strMsgPriority = MSG_HIGH Then

            ' Message priority
            objMsg.Fields.Item _
            ("urn:schemas:mailheader:X-Priority") = cdoPriorityUrgent

            objMsg.Fields.Item _
           ("urn:schemas:mailheader:X-MSMail-Priority") = cdoPriorityUrgent

            objMsg.Fields.Item _
           ("urn:schemas:httpmail:importance") = cdoHigh

            objMsg.Fields.Update
        End If

        ' Configure how to send the email
        objMsg.Configuration.Fields.Item _
        ("http://schemas.microsoft.com/cdo/configuration/sendusing") = REMOTE_SVR
        objMsg.Configuration.Fields.Update

        ' Remote SMTP Server (Name Or Ip)
        objMsg.Configuration.Fields.Item _
        ("http://schemas.microsoft.com/cdo/configuration/smtpserver") = strSmtpServer
        objMsg.Configuration.Fields.Update

        ' Server port 25 (SMTP protocol)
        objMsg.Configuration.Fields.Item _
        ("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = SMTP_PORT
        objMsg.Configuration.Fields.Update


        ' Break attachments down by ~
        Dim aryAtch   
        aryAtch = Split(strMsgAtt, "~")

        ' Only attach existing files, zero byte files are fine
        Dim intCnt
        For intCnt = LBound(aryAtch) to UBound(aryAtch)
            If FileExists(aryAtch(intCnt)) Then
                objMsg.AddAttachment aryAtch(intCnt)
            End If
        Next

        ' Send the email
        objMsg.Send

        ' Release the object
        set objMsg = nothing

    End sub


    '
    '  Interface for loading HTML/TEXT message bodies
    '

    Public Sub LOAD_BODY(strFile)
        If FileExists(strFile) Then
            strMsgBody = ReadFile2Str(strFile)
        End If
    End Sub


    '
    '  Check file attachment existence
    '

    Private Function FileExists(strFile)
   
        ' Default value
        FileExists = False
       
        ' Create a file system object
        Dim objFso
        Set objFso = CreateObject("Scripting.FileSystemObject")
   
        ' Set return values
        If (objFso.FileExists(strFile)) Then
            FileExists = True
        End If
   
        ' Release the object
        Set objFso = nothing
   
    End Function


    '
    '  Load up the file into a string buffer
    '

    Private Function ReadFile2Str(strPath)

        ' Declare file constants
        const C_READ = 1
        const C_WRITE = 2
        const C_APPEND = 8

        ' Variables to get request
        Dim objFso
        Dim objFile

        ' Load the requested file
        Set objFso = CreateObject("Scripting.FileSystemObject")
        Set objFile = objFso.OpenTextFile(strPath, C_READ)

        ' Return the file as a variable
        ReadFile2Str = objFile.ReadAll

        ' Release the object
        objFile.Close
        Set objFile = nothing
        Set objFso = nothing    

    End Function

End Class