MailWrapper class version5

Option Compare Database
'MailWrapperVersion=5
Option Explicit
'Do Not Move the above line
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Version 1 - 13/Mar/2017 - Changed the mail module to a class module         '
' Version 2 - 09/Feb/2018 - Added a parameter for the attachment in the       '
'                           CreateMessage function.                           '
' Version 3 - 15/May/2018 - Added CSS constants to make it easier to create   '
'                           HTML based emails. Also added Properties for those'
'                           constants.                                        '
' Version 4 - 16/May/2018 - Added a tab to use without needing to code it out '
'                           every time style inline,added font-size: 100% to  '
'                           pCSS_PRE                                          '
' Version 5 - 17/May/2018 - fixed HtmlTab, pre was not properly using the     '
'                           display: inline; property                         '
'                                                                             '
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Requirements                                                                '
' -iwshruntimelibrary                                                         '
' -vbsendmail.dll installed                                                   '
' dbo_Email_Error_Log table                                                   '
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Uncomment below line after update
'Private WithEvents objSendMail As vbSendMail.clsSendMail
'Enumerations''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Enum EmailListType
    StringArray = 0
    TableNameString = 1
    QueryNameString = 2
End Enum

'CSS Constants'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Const pCSS_Table As String = "table{border-collapse: collapse;}table, th, td{border: 1px solid black;}th, td{padding: 5px;}"
Const pCSS_Pre As String = "pre{display: inline;font-family: calabri;font-size: 100%;}"

Const pCSS_ALL As String = pCSS_Table & pCSS_Pre

'Other text constants''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Const pHtmlTab As String = "<span style=" & """" & "white-space: pre;" & """" & ">" & vbTab & "</span>"



'Custom properties'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Property Get CSS_ALL_WithStyleTags()
    CSS_ALL_WithStyleTags = "<style>" & pCSS_ALL & "</style>"
End Property

Public Property Get CSS_ALL_NoStyleTags()
    CSS_ALL_NoStyleTags = pCSS_ALL
End Property

Public Property Get CSS_TABLE()
    CSS_TABLE = pCSS_Table
End Property

Public Property Get CSS_PRE()
    CSS_PRE = pCSS_Pre
End Property

Public Property Get HtmlTab()
    HtmlTab = pHtmlTab
End Property

'Events''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Sub objSendMail_SendSuccessful()
    Debug.Print "Email Success"
End Sub

Private Sub objSendMail_SendFailed(Explanation As String)
    Debug.Print "Email Failed"
    Debug.Print Explanation
    LogEmailError AppSpecific.AppID, Environ("COMPUTERNAME"), 4, , Explanation
End Sub

Private Sub objSendMail_Status(Status As String)
    'Debug.Print Status
End Sub

Private Sub objSendMail_Progress(PercentComplete As Long)
    'Debug.Print PercentComplete
End Sub

Private Sub Class_Initialize()
    Set objSendMail = New vbSendMail.clsSendMail
    Debug.Print "Initilizing"
End Sub

Private Sub Class_Terminate()
    Set objSendMail = Nothing
    Debug.Print "Terminating"
End Sub

'Functions'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Function CreateMessage(ByVal argSubject As String, argMessage As String, argReplyto As String, argDisplay As String, argFrom As String, argEmailListSource As Variant, Optional argEmailListType As EmailListType = StringArray, Optional argAsHTML As Boolean = False, Optional argAttach As String) As Long
    'sets all nessecery fields for a proper e-mail then passes the e-mail list to the function that compiles them into the format needed on a mail server.
    'this function uses a string array as the e-mail source
    'Outputs
    '0 - function closed normally without any errors
    '1 - vb send mail is not installed
    '2 - somehow the destination emails is empty
    '3 - Mail server unreachable
    '4 - Send error with error sent via send failed event
    '5 - unknown error
    Dim ErrorCode As Long: ErrorCode = 0
    If Not BasicInclude.DebugMode Then On Error GoTo Error_Handler Else On Error GoTo 0
    Dim strMailTo As String
    strMailTo = FormatList(argEmailListSource, argEmailListType)
    If strMailTo & "" = "" Then
        Err.Raise vbObjectError + 1, "Email", "Email List Source is invalid"
    End If

    If Not objSendMail.Ping("192.168.10.4") Then
        Err.Raise vbObjectError + 2, "Email", "Unable to contact e-mail server"
    End If
    objSendMail.SMTPHost = "192.168.10.4"
    objSendMail.UseAuthentication = False
    objSendMail.RecipientDisplayName = strMailTo
    objSendMail.ReplyToAddress = argReplyto
    objSendMail.from = argFrom
    objSendMail.FromDisplayName = argDisplay
    objSendMail.Recipient = strMailTo
    objSendMail.Subject = argSubject
    objSendMail.Message = argMessage
    objSendMail.AsHTML = argAsHTML
    If Not IsNull(argAttach) Then
        objSendMail.Attachment = argAttach
    End If
    objSendMail.Send
Error_Handler_Exit:
    CreateMessage = ErrorCode
    Exit Function
Error_Handler:
    If Err.Number = vbObjectError + 1 Then
        ErrorCode = 2
    ElseIf Err.Number = vbObjectError + 2 Then
        ErrorCode = 3
    Else
        ErrorCode = 5
    End If
    'nofail = False
    MsgBox "The following error has occured" & vbCrLf & vbCrLf & _
           "Error Number: " & Err.Number & vbCrLf & _
           "Error Source: MailWrapper.CreateMessage" & vbCrLf & _
           "Error Description: " & Err.Description _
           , vbOKOnly + vbCritical, "An Error has Occured!"
    Resume Error_Handler_Exit
End Function

Public Function FormatList(argListSource As Variant, argListType As EmailListType) As String
    'this compiles a list of e-mails from a string array
    Dim strMailTo As String: strMailTo = ""
    Dim rs As DAO.Recordset
    Select Case argListType
    Case StringArray
        Dim v As Variant
        For Each v In argListSource
            strMailTo = strMailTo & ";" & v
        Next
    Case TableNameString
        Set rs = dbLocal.TableDefs(argListSource).OpenRecordset(dbOpenDynaset, dbSeeChanges)
        With rs
            If .RecordCount > 0 Then
                .MoveFirst
                While Not .EOF
                    strMailTo = strMailTo & ";" & .Fields(0).Value
                    .MoveNext
                Wend
            End If
        End With
    Case QueryNameString
        Set rs = dbLocal.QueryDefs(argListSource).OpenRecordset(dbOpenDynaset, dbSeeChanges)
        With rs
            If .RecordCount > 0 Then
                .MoveFirst
                While Not .EOF
                    strMailTo = strMailTo & ";" & .Fields(0).Value
                    .MoveNext
                Wend
            End If
        End With
    End Select
    If strMailTo & "" <> "" Then
        strMailTo = Mid(strMailTo, 2)
    End If
    FormatList = strMailTo
End Function

Public Function LogEmailError(argAppID As Long, argHostName As String, argErrorCode As Long, Optional argUserID As String = "", Optional argExplination As String = "") As Long
    Dim rs As DAO.Recordset
    If Not BasicInclude.DebugMode Then On Error GoTo Error_Handler Else On Error GoTo 0
    Set rs = dbLocal.TableDefs("dbo_Email_Error_Log").OpenRecordset(dbOpenDynaset, dbSeeChanges)
    With rs
        .AddNew
        .Fields("ApplicationID").Value = argAppID
        .Fields("HostName").Value = argHostName
        .Fields("ErrorCode").Value = argErrorCode
        .Fields("DateTime").Value = Now()
        .Fields("UserID").Value = argUserID
        .Fields("Explination").Value = argExplination
        .Update
    End With
    LogEmailError = 0
Error_Handler_Exit:
    Set rs = Nothing
    Exit Function
Error_Handler:
    LogEmailError = -1
    'nofail = False
    MsgBox "The following error has occured" & vbCrLf & vbCrLf & _
           "Error Number: " & Err.Number & vbCrLf & _
           "Error Source: MailWrapper.LogEmailError" & vbCrLf & _
           "Error Description: " & Err.Description _
           , vbOKOnly + vbCritical, "An Error has Occured!"
    Resume Error_Handler_Exit

End Function