Attribute VB_Name = "modEmail"
Option Compare Database
Option Explicit

Dim aTo As String, aCC As String, aFrom As String, aPath As String
Dim FileList As String, aTextBody As String, aSubject As String

Dim rs As DAO.Recordset
Dim rst As DAO.Recordset
Dim strSubject As String
Dim strMessage As String
Dim strEmailTo As String
Dim strEmailCC As String
Dim strMsg As String
Dim strFrom As String

Dim strFormName As String

Public Sub SendEmail(intType As Integer, stDocName As String, stRecipientList As String, stCCList As String, _
        stSubj As String, stMessage As String, blnEdit As Boolean, strPath As String)

On Error GoTo Err_SendEmail

'CR - use SilentFlag=True to block email success confirmation messages

'NewEmailCode
'==========================
If strFrom = "" Then
    strFrom = "donotreply@dummy.com" 'dummy email address
End If
'Debug.Print strFrom

SendEMailCDO stRecipientList, stCCList, stSubj, stMessage, strFrom, strPath
'==========================

Exit_SendEmail:
    Exit Sub

Err_SendEmail:
    MsgBox "Error " & Err.Number & " " & Err.Description
    Resume Exit_SendEmail
    
End Sub
Public Function CheckEmailSettings() As Boolean

On Error GoTo Err_Handler

    'Checks if email settings exist. If not, output = false
    CheckEmailSettings = True
    
    If Nz(DLookup("ItemValue", "tblProgramSettings", "ItemName='SendUsing'"), "") = "" Or _
        Nz(DLookup("ItemValue", "tblProgramSettings", "ItemName='SMTPServerPort'"), "") = "" Or _
        Nz(DLookup("ItemValue", "tblProgramSettings", "ItemName='SMTPServer'"), "") = "" Or _
        Nz(DLookup("ItemValue", "tblProgramSettings", "ItemName='SMTPAuthenticate'"), "") = "" Or _
        Nz(DLookup("ItemValue", "tblProgramSettings", "ItemName='SendUserName'"), "") = "" Or _
        Nz(DLookup("ItemValue", "tblProgramSettings", "ItemName='SendPassword'"), "") = "" Or _
        Nz(DLookup("ItemValue", "tblProgramSettings", "ItemName='SMTPConnectionTimeout'"), "") = "" Or _
        Nz(DLookup("ItemValue", "tblProgramSettings", "ItemName='SMTPUseSSL'"), "") = "" Then
            
        CheckEmailSettings = False
    End If
    
Exit_Handler:
    Exit Function

Err_Handler:
    MsgBox "Error " & Err.Number & " in CheckDefaultEmailSettings procedure : " & Err.Description
    Resume Exit_Handler
    
End Function

Public Function ClearEmailSettings()

On Error GoTo Err_Handler

    'clear all default email settings stored in tblProgramSettings

        Dim db As DAO.Database
        Set db = CurrentDb()
    
        db.Execute "UPDATE tblProgramSettings SET ItemValue = '' WHERE (((ItemName)='SendUserName'));", dbFailOnError
        db.Execute "UPDATE tblProgramSettings SET ItemValue = '' WHERE (((ItemName)='SendUsing'));", dbFailOnError
        db.Execute "UPDATE tblProgramSettings SET ItemValue = '' WHERE (((ItemName)='SMTPServerPort'));", dbFailOnError
        db.Execute "UPDATE tblProgramSettings SET ItemValue = '' WHERE (((ItemName)='SMTPServer'));", dbFailOnError
        db.Execute "UPDATE tblProgramSettings SET ItemValue = '' WHERE (((ItemName)='SMTPAuthenticate'));", dbFailOnError
        db.Execute "UPDATE tblProgramSettings SET ItemValue = '' WHERE (((ItemName)='SendUserName'));", dbFailOnError
        db.Execute "UPDATE tblProgramSettings SET ItemValue = '' WHERE (((ItemName)='SendPassword'));", dbFailOnError
        db.Execute "UPDATE tblProgramSettings SET ItemValue = '' WHERE (((ItemName)='SMTPConnectionTimeout'));", dbFailOnError
        db.Execute "UPDATE tblProgramSettings SET ItemValue = '' WHERE (((ItemName)='SMTPUseSSL'));", dbFailOnError
        db.Execute "UPDATE tblProgramSettings SET ItemValue = 'No' WHERE (((ItemName)='EMailUseOutlook'));", dbFailOnError
    
Exit_Handler:
    Exit Function

Err_Handler:
    MsgBox "Error " & Err.Number & " in ClearEmailSettings procedure : " & Err.Description
    Resume Exit_Handler
    
End Function

Public Function SendEmailDisplayOutlook(strSendTo As String, strCopyTo As String, strSubject As String, strMessage As String, strAttachment As String)

On Error GoTo ErrHandler

'Uses late binding to send email(so that a reference to Outlook library is not needed)

Dim objOutlook As Object
Dim objOutlookMsg As Object
Dim sAPPPath        As String

' Create the Outlook session.
Set objOutlook = CreateObject("Outlook.Application")

' Create the message.
Set objOutlookMsg = objOutlook.CreateItem(0)
' Add the To/Subject/Body/Attachments to the message then display the message for editing
With objOutlookMsg
    .To = strSendTo
    .CC = strCopyTo
    .Subject = strSubject
    .Body = strMessage
    If Nz(strAttachment, "") <> "" Then
        .Attachments.Add strAttachment
    End If
    .display
    '.Send
End With

Set objOutlook = Nothing
Set objOutlookMsg = Nothing

ErrHandlerExit:
   Exit Function

ErrHandler:
   If Err = -2147418113 Then
        MsgBox "ERROR: Cannot open Microsoft Outlook.                  " & vbCrLf & vbCrLf & _
            "For support, please contact: " & vbCrLf & " - " & GetSupportEMail() & vbCrLf & _
            "using your default email application    ", vbCritical, "Outlook not available"
        Exit Function
   Else
        MsgBox "Error " & Err.Number & " in SendEMailDisplayOutlook routine: " & Err.Description
        Resume ErrHandlerExit
   End If

End Function

Function GetSupportEMail()
    'This would normally reference a settings table
    GetSupportEMail = "123@xyz.com"
End Function

'---------------------------------------------------------------------------------------
' Procedure : StartOutlook
' Author    : Daniel Pineault, CARDA Consultants Inc.
' Website   : http://www.cardaconsultants.com
' Purpose   : Demonstration of how one can start outlook if it isn't already started
'             considering CreateObject("Outlook.Application") not longer works!
' Copyright : The following may be altered and reused as you wish so long as the
'             copyright notice is left unchanged (including Author, Website and
'             Copyright).  It may not be sold/resold or reposted on other sites (links
'             back to this site are allowed).
'
' Usage:
' ~~~~~~
'
'
' Revision History:
' Rev       Date(yyyy/mm/dd)        Description
' **************************************************************************************
' 1         2014-Oct-31                 Initial Release
'---------------------------------------------------------------------------------------
Function StartOutlook()
    On Error GoTo Error_Handler
    Dim oOutlook        As Object
    Dim sAPPPath        As String
 
    If IsAppRunning("Outlook.Application") = True Then    'Outlook was already running
        Set oOutlook = GetObject(, "Outlook.Application")    'Bind to existing instance of Outlook
    Else    'Could not get instance of Outlook, so create a new one
        sAPPPath = GetAppExePath("outlook.exe")    'determine outlook's installation path
        Shell (sAPPPath)    'start outlook
        Do While Not IsAppRunning("Outlook.Application")
            DoEvents
        Loop
        Set oOutlook = GetObject(, "Outlook.Application")    'Bind to existing instance of Outlook
    End If
 
    '    MsgBox "Outlook Should be running now, let's do something"
    Const olMailItem = 0
    Dim oOutlookMsg     As Object
    Set oOutlookMsg = oOutlook.CreateItem(olMailItem)    'Start a new e-mail message
    oOutlookMsg.display    'Show the message to the user

Error_Handler_Exit:
    On Error Resume Next
    Set oOutlook = Nothing
    Exit Function
 
Error_Handler:
    MsgBox "The following error has occured" & vbCrLf & vbCrLf & _
           "Error Number: " & Err.Number & vbCrLf & _
           "Error Source: StartOutlook" & vbCrLf & _
           "Error Description: " & Err.Description _
           , vbOKOnly + vbCritical, "An Error has Occured!"
    Resume Error_Handler_Exit
End Function
 
'---------------------------------------------------------------------------------------
' Procedure : IsAppRunning
' Author    : Daniel Pineault, CARDA Consultants Inc.
' Website   : http://www.cardaconsultants.com
' Purpose   : Determine is an App is running or not
' Copyright : The following may be altered and reused as you wish so long as the
'             copyright notice is left unchanged (including Author, Website and
'             Copyright).  It may not be sold/resold or reposted on other sites (links
'             back to this site are allowed).
'
' Input Variables:
' ~~~~~~~~~~~~~~~~
' sApp      : GetObject Application to verify if it is running or not
'
' Usage:
' ~~~~~~
' IsAppRunning("Outlook.Application")
' IsAppRunning("Excel.Application")
' IsAppRunning("Word.Application")
'
' Revision History:
' Rev       Date(yyyy/mm/dd)        Description
' **************************************************************************************
' 1         2014-Oct-31                 Initial Release
'---------------------------------------------------------------------------------------
Function IsAppRunning(sApp As String) As Boolean
    On Error GoTo Error_Handler
    Dim oApp            As Object
 
    Set oApp = GetObject(, sApp)
    IsAppRunning = True
 
Error_Handler_Exit:
    On Error Resume Next
    Set oApp = Nothing
    Exit Function
 
Error_Handler:
    Resume Error_Handler_Exit
End Function
 
'---------------------------------------------------------------------------------------
' Procedure : GetAppExePath
' Author    : Daniel Pineault, CARDA Consultants Inc.
' Website   : http://www.cardaconsultants.com
' Purpose   : Determine the path for a given exe installed on the local computer
' Copyright : The following may be altered and reused as you wish so long as the
'             copyright notice is left unchanged (including Author, Website and
'             Copyright).  It may not be sold/resold or reposted on other sites (links
'             back to this site are allowed).
'
' Input Variables:
' ~~~~~~~~~~~~~~~~
' sEXEName  : Name of the exe to locate
'
' Usage:
' ~~~~~~
' Call GetAppExePath("msaccess.exe")
' GetAppExePath("firefox.exe")
' GetAppExePath("outlook.exe")
'
' Revision History:
' Rev       Date(yyyy/mm/dd)        Description
' **************************************************************************************
' 1         2014-Oct-31                 Initial Release
'---------------------------------------------------------------------------------------
Function GetAppExePath(ByVal sExeName As String) As String
    On Error GoTo Error_Handler
    Dim WSHShell        As Object
 
    Set WSHShell = CreateObject("Wscript.Shell")
    GetAppExePath = WSHShell.RegRead("HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\App Paths\" & sExeName & "\")
 
Error_Handler_Exit:
    On Error Resume Next
    Set WSHShell = Nothing
    Exit Function
 
Error_Handler:
    If Err.Number = -2147024894 Then
        'Cannot locate requested exe????
    Else
        MsgBox "The following error has occurred." & vbCrLf & vbCrLf & _
               "Error Number: " & Err.Number & vbCrLf & _
               "Error Source: GetAppExePath" & vbCrLf & _
               "Error Description: " & Err.Description, _
               vbCritical, "An Error has Occurred!"
    End If
    Resume Error_Handler_Exit
End Function
Sub SendEMailCDO(aTo, aCC, aSubject, aTextBody, aFrom, aPath)

'==========================================
'Original code by Jeff Blumson
'Adapted by Colin Riddington to include file attachents
'Date: 25/08/2007
'==========================================

On Error GoTo Err_SendEMailCDO

Const CdoBodyFormatText = 1
Const CdoBodyFormatHTML = 0
Const CdoMailFormatMime = 0
Const CdoMailFormatText = 1
    
    Dim Message As Object, SilentFlag  As Boolean
    'Create CDO message object
    Set Message = CreateObject("cdo.Message")
    With Message.Configuration.Fields
            .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = Nz(DLookup("ItemValue", "tblProgramSettings", "ItemName='SendUsing'"), "")
            .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = Nz(DLookup("ItemValue", "tblProgramSettings", "ItemName='SMTPServerPort'"), "")
            .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = Nz(DLookup("ItemValue", "tblProgramSettings", "ItemName='SMTPServer'"), "")
            .Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = Nz(DLookup("ItemValue", "tblProgramSettings", "ItemName='SMTPAuthenticate'"), "")
            .Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = Nz(DLookup("ItemValue", "tblProgramSettings", "ItemName='SendUserName'"), "")
            .Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = Nz(DLookup("ItemValue", "tblProgramSettings", "ItemName='SendPassword'"), "")
            .Item("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = Nz(DLookup("ItemValue", "tblProgramSettings", "ItemName='SMTPConnectionTimeout'"), "")
            .Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = Nz(DLookup("ItemValue", "tblProgramSettings", "ItemName='SMTPUseSSL'"), "")
            .Update
    End With
    
    With Message
        .To = aTo                                   'Set email adress
        .Subject = aSubject                         'Set subject
        .TextBody = aTextBody                       'Set body text
        If Len(aCC) > 0 Then .CC = aCC              'Set copy to
        If Len(aFrom) > 0 Then .FROM = aFrom        'Set sender address if specified.
        
        If Len(aPath) = 0 Then GoTo Send            'No attachment - send the message
       
        'code for 1 attachment (tested 24/08/2007)
        'If Len(aPath) > 0 Then .AddAttachment (aPath) 'Set attachment path if specified.
        
        'code for multiple attachments (tested 25/08/2007)
        'Check file list(aPath)
        If Len(aPath) > 0 Then 'there are attachment(s)
            FileList = aPath
            Do Until FileList = ""
                'If FileList > "" Then
                    If InStr(1, FileList, ";") = 0 Then
                        GoTo Done
                    Else
                        aPath = Left(FileList, InStr(1, FileList, ";") - 1)
                        FileList = Mid(FileList, InStr(1, FileList, ";") + 1)
                    End If
                'End If
                .AddAttachment (aPath) 'Attach this file
                Loop
                        
Done:
            .AddAttachment (FileList) 'Set final attachment path if it exists.
            End If
            
Send:
        'Check valid email addresses
        Dim boFailEmail As Boolean
        boFailEmail = False
        If CheckValidEmail(.To) = False Then boFailEmail = True
        If CheckValidEmail(.FROM) = False Then boFailEmail = True
        If CheckValidEmail(.CC) = False Then boFailEmail = True
        
        If boFailEmail = False Then
            .bcc = Nz(DLookup("ItemValue", "tblProgramSettings", "ItemName='SendUserName'"), "") 'Keep a log of all messages sent by having a copy to the SDA mailbox.
            .Send    'Send the message
            
            If SilentFlag = True Then GoTo EndRoutine 'omit message sent successfully below
            
            MsgBox "The email message has been sent successfully.", vbInformation, "Pastoral referral email message"
        Else
            MsgBox "The email message was not sent, there is a problem with one of the email addresses.    " & vbCrLf & _
                   "Please inform the system administrator.  ", vbCritical, "EMail message error"
        End If
    End With

EndRoutine:
    'Clean up
    Set Message = Nothing

Exit_SendEMailCDO:
    Exit Sub

Err_SendEMailCDO: 'CR - minor change of wording
    
    If MsgBox("The application was unable to send the email message(s).            " & vbCrLf & _
        "Please check the email settings used for the application." & vbCrLf & _
        "The error message shown below should help identify the setting(s) that need to be altered. " & vbCrLf & vbCrLf & _
        "Error " & Err.Number & Chr(13) & Err.Description & vbCrLf & _
        "Click OK to check the email settings now", vbCritical + vbOKCancel, "EMail Error") = vbOK Then
                DoCmd.OpenForm "frmEMailSettings"
                DoCmd.Close acForm, strFormName 'strFormName defined in calling form
    Else
        MsgBox "You clicked CANCEL." & vbCrLf & _
            "REMEMBER to check the email settings later  " & vbCrLf & _
            "This can also be done from the Admin Menu form ", vbInformation, "Email Settings"
    End If
    
    Resume Exit_SendEMailCDO

End Sub

'Use the function below to validate all email addresses before sending
Function IsValidEmail(strEmailAddress As String) As Boolean
    Dim MyRegExp As Object
    Set MyRegExp = CreateObject("vbscript.RegExp")
    MyRegExp.Pattern = "^[a-zA-Z0-9\._-]+@([a-zA-Z0-9_-]+\.)+([a-zA-Z]{2,3})$"
    IsValidEmail = MyRegExp.Test(strEmailAddress)
    Set MyRegExp = Nothing
End Function

Function CheckValidEmail(strEmailList As String) As Boolean
    Dim MyRegExp As Object
    Dim intStart As Integer
    Dim intEnd As Integer
    Dim intMid As Integer
    Dim strEMail As String
    intStart = 1
    
    CheckValidEmail = True
    
    Do While intEnd < Len(strEmailList)
        intEnd = InStr(intStart, strEmailList, ",")
        If intEnd = 0 Then intEnd = Len(strEmailList) + 1
        strEMail = Trim(Mid(strEmailList, intStart, intEnd - intStart))
        
        If Left(strEMail, 1) = """" Then
            strEMail = Mid(strEMail, 2, InStr(2, strEMail, """") - 2)
        End If
        
        'Debug.Print strEmail
        If IsValidEmail(strEMail) = False Then
            MsgBox "Error with email address " & strEMail
            CheckValidEmail = False
        End If

        intStart = intEnd + 1
    Loop
End Function

Function CheckEMailUseOutlook()

    CheckEMailUseOutlook = Nz(DLookup("ItemValue", "tblProgramSettings", "ItemName='EMailUseOutlook'"), "No")
    
End Function

Public Function CloseOutlook()

'CR - use to close all running instances of Outlook

Dim objs As Object
Dim obj As Object
Dim strSQL As String
Dim strWMI As String

strWMI = "winmgmts:"
strSQL = "Select * From Win32_Process "
strSQL = strSQL & "where Name = 'OUTLOOK.EXE'"

Set objs = GetObject(strWMI).ExecQuery(strSQL)
For Each obj In objs
    obj.Terminate
Next
Set objs = Nothing

End Function

Public Function SendEmailUsingOutlook(strSendTo As String, strCopyTo As String, strSubject As String, strMessage As String, strAttachment As String)

On Error GoTo ErrHandler

'CR - Uses late binding to send email without displaying Outlook

Dim objOutlook As Object
Dim objOutlookMsg As Object
Dim StartOutlookFlag As Boolean
Dim Path As String

StartOutlookFlag = False

' Create the Outlook session.
If IsAppRunning("Outlook.Application") = True Then
    'Use existing instance of Outlook
    Set objOutlook = CreateObject("Outlook.Application")
Else
   'Could not get instance of Outlook, so create a new one
        Path = GetAppExePath("outlook.exe")    'determine outlook's installation path
        Shell (Path), vbMinimizedFocus   'start outlook
        Do While Not IsAppRunning("Outlook.Application")
            DoEvents
        Loop
        Set objOutlook = GetObject(, "Outlook.Application") 'Bind to new instance of Outlook
        StartOutlookFlag = True 'needed so Outlook can be closed later
End If

' Create the message.
Set objOutlookMsg = objOutlook.CreateItem(0)

' Add the To/Subject/Body/Attachments to the message then send the message
With objOutlookMsg
    .To = strSendTo
    .CC = strCopyTo
    .Subject = strSubject
    .Body = strMessage
    If Nz(strAttachment, "") <> "" Then
        .Attachments.Add strAttachment
    End If
   ' .Display 'do not display message
    .Save
    .Send
End With

Set objOutlook = Nothing
Set objOutlookMsg = Nothing

'close Outlook if it was opened for this function - may need to add delay time using Sleep API
DoEvents

If StartOutlookFlag = True Then CloseOutlook

ErrHandlerExit:
   Exit Function

ErrHandler:
   If Err.Number <> 287 Then 'And err.Number <> 429 Then
        MsgBox "Error " & Err.Number & " in SendEMailUsingOutlook routine: " & Err.Description
   End If
   Resume ErrHandlerExit

End Function