VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "MailClient"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

#If LIVE = 1 Then
Private mo_Db As Object             'DB Connection
#Else
Private mo_Db As ARMSYSCOMLib.ArmDb 'DB Connection
#End If

Private Const SEP1 As String = "®"
Private Const SEP2 As String = "©"
Private Const SEP As String = SEP1 + SEP2
Private Const C_MODULE_NAME As String = "MailClient"      ' module name used in log table
Private Const SCREEN_NAME As String = "MailClient"

'Mail Status const
Private Const EML_MAILSTATUS_NEW = "N"
Private Const EML_MAILSTATUS_DELETED = "D"
Private Const EML_MAILSTATUS_PROCESSED = "P"
Private Const EML_MAILSTATUS_BLACKLISTED = "B"
Private Const EML_MAILSTATUS_SPAM = "S"
Private Const EML_MAILSTATUS_FAILED = "F"
Private Const EML_MAILSTATUS_INVALID = "I"

'Mail Attachment Storage type
Private Const EML_ATTSTORAGE_DIRECTORY = "D"
Private Const EML_ATTSTORAGE_SQLDATABASE = "S"
Private Const EML_ATTSTORAGE_IGNORE = "I"

'Mail Type consts
Private Const EML_MAILTYPE_DEFAULT = "D"
Private Const EML_MAILTYPE_REPLY = "R"
Private Const EML_MAILTYPE_FORWARD = "F"

'MailBox Type
Private Const EML_MAILBOX_INBOX = "I"
Private Const EML_MAILBOX_OUTBOX = "O"

Public Enum emlEmailAddressErr
    eaeEmailOk = 1
    eaeNoEmailForUCode = 2
    eaeAddressInvalid = 3
End Enum

Public Enum emlEmailType
    etEmailTo = 1
    etEmailCopyTo = 2
    etEmailBlindCopyTo = 3
    etEmailFrom = 4
End Enum


' **************************************************************************************************
' **************************************** USER DEFINED ERRORS *************************************
' **************************************************************************************************
Private Const C_ERRORRAISE As Long = 2500

Private Enum ArmErr
    DBCnxFailed = C_ERRORRAISE + 1             ' Unable to connect to the database
    CPTAlreadyInitialized = C_ERRORRAISE + 2   ' We try to initialize a component that is already initialized
    CPTNotInitialized = C_ERRORRAISE + 3       ' We try to use or free that is not initialized yet
    InvalidArgument = C_ERRORRAISE + 4
    PropertyNotSet = C_ERRORRAISE + 5
    SQLFailure = C_ERRORRAISE + 6               ' A SQL runtime error has occured : syntax wrong....
    SQLBadRowAffectedCount = C_ERRORRAISE + 7   ' A SQL request has not affected the expected rowcount (ex: one Update do nothing)
    SQLBadRowExpectedCount = C_ERRORRAISE + 8   ' A SQL request does not return the expected rowcount : select an item return nothing...
    DrivingError = C_ERRORRAISE + 9
    CompFncFailed = C_ERRORRAISE + 10           ' when component function fail
    GridLoadFailed = C_ERRORRAISE + 11          ' load function failed ... bad sql
    InvalidValue = C_ERRORRAISE + 12          ' load function failed ... bad sql
End Enum

Private Enum ArmCusErr
    DuplicityDetected = C_ERRORRAISE + 2301                ' detected row with same unique id
End Enum

Private Enum ArmSysType
  DBTYPE_EMPTY = 0
  DBTYPE_I4 = 3
  DBTYPE_R4 = 4
  DBTYPE_R8 = 5
  DBTYPE_DATE = 7
  DBTYPE_BSTR = 8 '- UNICODE string
  DBTYPE_BOOL = 11
  DBTYPE_STR = 129
  DBTYPE_BMP = 999
End Enum
' *************************************** USER DEFINED ERRORS **************************************

Private ml_U_code       As Long
Private mb_Initialized  As Boolean  'true if MailClient class is initialized

Private Type tMAIL_ADDRESS
    EMail As String
    Type As emlEmailType
End Type

Private Type tMAIL_ATTACHMENT
    EAT_Code As String ' used only for read
    Storage As String  ' used only for read
    Path As String
    Name As String
    StoredName As String ' used only for read
End Type

Private Type tMAIL_DATA
    EML_Code        As Long
    Subject         As String
    Message         As String
    HTMLMessage     As String
    HTMLCharset     As String
    IsHtml          As Boolean
    DateToSend      As Date
    AppStatus       As String
    Addresses()     As tMAIL_ADDRESS
    Attachments()   As tMAIL_ATTACHMENT
    MailBoxType     As String   ' I = Readed Emails, O - Emails to be sent
End Type

Private ma_MailData() As tMAIL_DATA

Dim mo_FSO As Object                ' filesystem object

Private Type MailBoxDefinition
    EAC_Code            As String
    EAC_Desc            As String
    Name                As String
    Password            As String
    KeyFileName         As String
    Certificate         As String
    MailFile            As String
    Location            As String
    EMailAddress        As String
    Application         As String
    DirectoryInbox      As String
    StorageInbox        As String
    DirectoryOutbox     As String
    StorageOutbox       As String
    ScanEnabled         As String
    CheckInterval       As Long
    Initialized         As Boolean
End Type

Private Type AttachmentInfo
    EAI_Code    As String
    EAT_Code    As String
    FileName    As String
    StoredName  As String
End Type

Dim mo_MailBoxInfo      As MailBoxDefinition

Public Property Set ArmDb(ByRef local_connection As Object)
    If Not (local_connection Is Nothing) Then
        Set mo_Db = local_connection
    End If
End Property

Property Let U_Code(al_Code As Long)
    ml_U_code = al_Code
End Property

' initialize module
Public Function Load_A_COM()

Dim ls_Text As String

    On Error GoTo ErrHandler
    Load_A_COM = False
    
    If mb_Initialized = True Then Call Err.Raise(ArmErr.CPTAlreadyInitialized)
    
    If mo_Db Is Nothing Then Err.Raise ArmErr.PropertyNotSet, "ArmDb not initialized"
    If ml_U_code = 0 Then Err.Raise ArmErr.PropertyNotSet, "UserCode not initialized"
    
    Set mo_FSO = CreateObject("Scripting.FileSystemObject")
    
    ReDim ma_MailData(-1 To -1)
    mo_MailBoxInfo.Initialized = False

    Load_A_COM = True
    mb_Initialized = True
    
    Exit Function
ErrHandler:
    Load_A_COM = False
    Call ErrorMessage(".Load_A_Com")
End Function

' uninitialize module
Public Sub UnLoad_A_COM()
On Error GoTo ErrHandler
    
    If mb_Initialized = False Then Call Err.Raise(ArmErr.CPTNotInitialized)
    
    Set mo_Db = Nothing
    Set mo_FSO = Nothing
    
    Exit Sub

ErrHandler:
    Set mo_Db = Nothing
    Set mo_FSO = Nothing
End Sub

Public Function SetActiveMailBox(ByVal as_EAC_Desc As String) As Boolean
Const SEL_REQ As String = "EXEC EML_GetMailBoxes_lst3 Null,$EAC_Desc$"

On Error GoTo ErrHandler

Dim ls_req      As String
Dim ll_cursor   As Long

    If mb_Initialized = False Then Call Err.Raise(ArmErr.CPTNotInitialized)

    SetActiveMailBox = False
    mo_MailBoxInfo.Initialized = False
    
    ' Get info for mailbox
    ls_req = Replace(SEL_REQ, "$EAC_Desc$", SQLStr(as_EAC_Desc), , , vbTextCompare)
    ll_cursor = OpenSQLSafe(mo_Db, ls_req)
        
        
    If Not mo_Db.EOF(ll_cursor) Then
        
        mo_MailBoxInfo.EAC_Code = mo_Db.GetFields(ll_cursor, "EAC_Code")
        mo_MailBoxInfo.EAC_Desc = mo_Db.GetFields(ll_cursor, "EAC_Desc")
        mo_MailBoxInfo.Application = mo_Db.GetFields(ll_cursor, "EAC_Application")
        mo_MailBoxInfo.Name = mo_Db.GetFields(ll_cursor, "EAC_Name")
        mo_MailBoxInfo.Password = mo_Db.GetFields(ll_cursor, "EAC_Password")
        mo_MailBoxInfo.KeyFileName = mo_Db.GetFields(ll_cursor, "EAC_KeyFileName")
        mo_MailBoxInfo.Certificate = mo_Db.GetFields(ll_cursor, "EAC_CertificateExpChecked")
        mo_MailBoxInfo.MailFile = mo_Db.GetFields(ll_cursor, "EAC_MailFile")
        mo_MailBoxInfo.Location = mo_Db.GetFields(ll_cursor, "EAC_Location")
        mo_MailBoxInfo.EMailAddress = mo_Db.GetFields(ll_cursor, "EAC_EMailAddress")
        mo_MailBoxInfo.DirectoryInbox = mo_Db.GetFields(ll_cursor, "EAC_DirectoryInbox")
        mo_MailBoxInfo.StorageInbox = mo_Db.GetFields(ll_cursor, "EAC_StorageInbox")
        mo_MailBoxInfo.DirectoryOutbox = mo_Db.GetFields(ll_cursor, "EAC_DirectoryOutbox")
        mo_MailBoxInfo.StorageOutbox = mo_Db.GetFields(ll_cursor, "EAC_StorageOutbox")
        mo_MailBoxInfo.ScanEnabled = mo_Db.GetFields(ll_cursor, "EAC_ScanEnabled")
        mo_MailBoxInfo.CheckInterval = mo_Db.GetFields(ll_cursor, "EAC_CheckInterval")
        
        mo_MailBoxInfo.Initialized = True
        SetActiveMailBox = True
    End If
    
    mo_Db.Close (ll_cursor)
    ll_cursor = 0
    Exit Function
    
ErrHandler:
    SetActiveMailBox = False
    
    If ll_cursor > 0 Then
        mo_Db.Close (ll_cursor)
        ll_cursor = 0
    End If
    
    Call ErrorHandler("SetActiveMailBox")
End Function

' add email address or domain into blacklist for active account
' to add email address, set as_Address='info@example.com' and ab_IsDomain = False
' to add domain set as_Address ='example.com' and ab_IsDomain = True
Public Sub AddIntoBlackList(ByVal as_Address As String, ByVal ab_IsDomain As Boolean)
On Error GoTo ErrHandler

Const REQ_INS_BLACK_LIST As String = "EML_BlackList_ins $EAC_Code$, $EBL_Address$, $EBL_Domain$"

Dim ls_req As String
Dim ls_EBL_Domain As String

    If mb_Initialized = False Then Call Err.Raise(ArmErr.CPTNotInitialized)
    
    If mo_MailBoxInfo.Initialized = False Then
        Call Err.Raise(ArmErr.InvalidValue, "AddIntoBlackList", "MailBox is not initialized!")
    End If
    
    If ab_IsDomain = True Then
        ls_EBL_Domain = "X"
    Else
        as_Address = Trim(as_Address)
        
        If IsEmailValid(as_Address) = False Then
            Err.Raise ArmErr.InvalidValue, "AddIntoBlackList", "Invalid email address:" & as_Address
        End If
        
        ls_EBL_Domain = ""
    End If
           
    ls_req = Replace(REQ_INS_BLACK_LIST, "$EAC_Code$", mo_MailBoxInfo.EAC_Code, , , vbTextCompare)
    ls_req = Replace(ls_req, "$EBL_Address$", SQLStr(as_Address), , , vbTextCompare)
    ls_req = Replace(ls_req, "$EBL_Domain$", SQLStr(ls_EBL_Domain), , , vbTextCompare)

    Call ExecuteSQLSafe(mo_Db, ls_req)
   
    Exit Sub
ErrHandler:
    Call ErrorHandler("AddIntoBlackList")
End Sub

' delete email address or domain from blacklist for active account
Public Sub DeleteFromBlackList(ByVal as_Address As String, ByVal ab_IsDomain As Boolean)
On Error GoTo ErrHandler

Const REQ_DEL_BLACK_LIST As String = "EML_BlackList_del $EAC_Code$, $EBL_Address$, $EBL_Domain$"

Dim ls_req As String
Dim ls_EBL_Domain As String

    If mb_Initialized = False Then Call Err.Raise(ArmErr.CPTNotInitialized)
    
    If mo_MailBoxInfo.Initialized = False Then
        Call Err.Raise(ArmErr.InvalidValue, "DeleteFromBlackList", "MailBox is not initialized!")
    End If
    
    If ab_IsDomain = True Then
        ls_EBL_Domain = "X"
    Else
        as_Address = Trim(as_Address)
        
        If IsEmailValid(as_Address) = False Then
            Err.Raise ArmErr.InvalidValue, "DeleteFromBlackList", "Invalid email address:" & as_Address
        End If
        
        ls_EBL_Domain = ""
    End If
           
    ls_req = Replace(REQ_DEL_BLACK_LIST, "$EAC_Code$", mo_MailBoxInfo.EAC_Code, , , vbTextCompare)
    ls_req = Replace(ls_req, "$EBL_Address$", SQLStr(as_Address), , , vbTextCompare)
    ls_req = Replace(ls_req, "$EBL_Domain$", SQLStr(ls_EBL_Domain), , , vbTextCompare)

    Call ExecuteSQLSafe(mo_Db, ls_req)
   
    Exit Sub
ErrHandler:
    Call ErrorHandler("DeleteFromBlackList")
End Sub


Public Function AddEmail(ByVal as_Subject As String, ByVal as_Message As String, ByVal ab_IsHtml As Boolean, _
                         ByVal ad_DateToSend As Date, ByVal as_Charset As String, Optional as_AppStatus As String = "") As Long
            
On Error GoTo ErrHandler

Dim ll_Idx As Long

    If mb_Initialized = False Then Call Err.Raise(ArmErr.CPTNotInitialized)

    If UBound(ma_MailData()) = -1 Then
        ReDim ma_MailData(0)
    Else
        ReDim Preserve ma_MailData(UBound(ma_MailData) + 1)
    End If
    
    ll_Idx = UBound(ma_MailData)
    
    If Len(as_AppStatus) > 1 Then
        Call Err.Raise(ArmErr.InvalidValue, "AddEmail", "AppStatus must be only one character!")
    Else
        ma_MailData(ll_Idx).AppStatus = as_AppStatus
    End If
    
    ma_MailData(ll_Idx).Subject = as_Subject
    ma_MailData(ll_Idx).IsHtml = ab_IsHtml
    If ab_IsHtml = True Then
        ma_MailData(ll_Idx).HTMLMessage = as_Message
        ma_MailData(ll_Idx).HTMLCharset = as_Charset
        ma_MailData(ll_Idx).Message = ""
    Else
        ma_MailData(ll_Idx).Message = as_Message
        ma_MailData(ll_Idx).HTMLMessage = ""
    End If
    ma_MailData(ll_Idx).DateToSend = ad_DateToSend
    
    ReDim ma_MailData(ll_Idx).Addresses(-1 To -1)
    ReDim ma_MailData(ll_Idx).Attachments(-1 To -1)
        
    ma_MailData(ll_Idx).MailBoxType = EML_MAILBOX_OUTBOX

    AddEmail = ll_Idx
    Exit Function
    
ErrHandler:
    AddEmail = -1
    Call ErrorHandler("AddEmail")
End Function

Public Function AddEmailAddress(ByVal al_MailDataIdx As Long, ByVal as_EMail As String, ByVal ae_Type As emlEmailType, Optional as_U_code As Long = 0) As emlEmailAddressErr
On Error GoTo ErrHandler
    
Dim ll_Idx As Long

    If mb_Initialized = False Then Call Err.Raise(ArmErr.CPTNotInitialized)

    ' first make some basic checks
    If CheckMailIndex(al_MailDataIdx) = False Then
        Err.Raise ArmErr.InvalidValue, "SendEmail", "Used Mail index is incorrect. (Out of range) MailIndex = " & al_MailDataIdx
    End If
    
    If ae_Type = emlEmailType.etEmailFrom Then
        Err.Raise ArmErr.InvalidValue, "AddEmailAddress", "Cannot set From Address. From address is set depending on selected account"
    End If
        
    If as_EMail = "" And as_U_code > 0 Then
        as_EMail = GetAddressForUCode(as_U_code)
        If as_EMail = "" Then
            AddEmailAddress = emlEmailAddressErr.eaeNoEmailForUCode
            Exit Function
        End If
    End If
    
    as_EMail = Trim(as_EMail)
    
    If IsEmailValid(as_EMail) = False Then
        Err.Raise ArmErr.InvalidValue, "AddEmailAddress", "Invalid email address:" & as_EMail
    End If
        
    If UBound(ma_MailData(al_MailDataIdx).Addresses) = -1 Then
        ReDim ma_MailData(al_MailDataIdx).Addresses(0)
    Else
        ReDim Preserve ma_MailData(al_MailDataIdx).Addresses(UBound(ma_MailData(al_MailDataIdx).Addresses) + 1)
    End If
    ll_Idx = UBound(ma_MailData(al_MailDataIdx).Addresses)
    
    ma_MailData(al_MailDataIdx).Addresses(ll_Idx).EMail = as_EMail
    ma_MailData(al_MailDataIdx).Addresses(ll_Idx).Type = ae_Type
    
    AddEmailAddress = emlEmailAddressErr.eaeEmailOk
    
    Exit Function

ErrHandler:
    AddEmailAddress = emlEmailAddressErr.eaeAddressInvalid
    Call ErrorHandler("AddEmailAddress")
End Function

Public Sub AddAttachment(ByVal al_MailDataIdx As Long, ByVal as_Path As String, ByVal as_Name As String)
On Error GoTo ErrHandler
    
Dim ll_Idx As Long

    If mb_Initialized = False Then Call Err.Raise(ArmErr.CPTNotInitialized)

    If CheckMailIndex(al_MailDataIdx) = False Then
        Err.Raise ArmErr.InvalidValue, "SendEmail", "Used Mail index is incorrect. (Out of range) MailIndex = " & al_MailDataIdx
    End If

    If UBound(ma_MailData(al_MailDataIdx).Attachments) = -1 Then
        ReDim ma_MailData(al_MailDataIdx).Attachments(0)
    Else
        ReDim Preserve ma_MailData(al_MailDataIdx).Attachments(UBound(ma_MailData(al_MailDataIdx).Attachments) + 1)
    End If
    ll_Idx = UBound(ma_MailData(al_MailDataIdx).Attachments)
    
    ma_MailData(al_MailDataIdx).Attachments(ll_Idx).Name = as_Name
    ma_MailData(al_MailDataIdx).Attachments(ll_Idx).Path = as_Path
    Exit Sub
    
ErrHandler:
    Call ErrorHandler("AddAttachment")
End Sub


Public Function GetEmailData(ByVal al_MailIdx As Long, ByRef ao_MailData As Object) As Boolean
On Error GoTo ErrHandler

Dim ll_Idx As Long

    If mb_Initialized = False Then Call Err.Raise(ArmErr.CPTNotInitialized)
    
    ao_MailData.EAC_Code = mo_MailBoxInfo.EAC_Code
    ao_MailData.EAC_Desc = mo_MailBoxInfo.EAC_Desc
    ao_MailData.EML_Code = ma_MailData(al_MailIdx).EML_Code
    ao_MailData.bIsHTML = ma_MailData(al_MailIdx).IsHtml
    ao_MailData.EML_Body = ma_MailData(al_MailIdx).Message
    ao_MailData.EML_HTMLBody = ma_MailData(al_MailIdx).HTMLMessage
    ao_MailData.EML_Subject = ma_MailData(al_MailIdx).Subject
    ao_MailData.EML_Addresses_Cc = GetEmailAddresses(al_MailIdx, etEmailTo)
    ao_MailData.EML_Addresses_To = GetEmailAddresses(al_MailIdx, etEmailCopyTo)
    ao_MailData.EML_Addresses_From = GetEmailAddresses(al_MailIdx, etEmailFrom)
    
    GetEmailData = True
    
    Exit Function
    
ErrHandler:
    GetEmailData = False
    Call ErrorHandler("GetEmailData")
End Function


Public Function GetEmailAddresses(ByVal al_MailIdx As Long, ByVal ae_Type As emlEmailType, Optional as_Separator As String = ";") As String
On Error GoTo ErrHandler

Dim ll_Idx As Long

    If mb_Initialized = False Then Call Err.Raise(ArmErr.CPTNotInitialized)
    
    GetEmailAddresses = ""
    
    For ll_Idx = 0 To UBound(ma_MailData(al_MailIdx).Addresses)
        If ma_MailData(al_MailIdx).Addresses(ll_Idx).Type = ae_Type Then
        
            If GetEmailAddresses = "" Then
                GetEmailAddresses = ma_MailData(al_MailIdx).Addresses(ll_Idx).EMail
            Else
                GetEmailAddresses = GetEmailAddresses & as_Separator & ma_MailData(al_MailIdx).Addresses(ll_Idx).EMail
            End If
            
        End If
    Next
    
    Exit Function
    
ErrHandler:
    GetEmailAddresses = ""
    Call ErrorHandler("GetEmailAddresses")
End Function

Public Function GetNumberOfAttachments(ByVal al_MailIdx As Long) As Long
On Error GoTo ErrHandler

    If mb_Initialized = False Then Call Err.Raise(ArmErr.CPTNotInitialized)
    
    GetNumberOfAttachments = UBound(ma_MailData(al_MailIdx).Attachments) + 1
    Exit Function
    
ErrHandler:
    GetNumberOfAttachments = 0
    Call ErrorHandler("GetNumberOfAttachments")
End Function

Public Function GetAppStatus(ByVal al_MailIdx As Long) As String
On Error GoTo ErrHandler

    If mb_Initialized = False Then Call Err.Raise(ArmErr.CPTNotInitialized)
    
    GetAppStatus = ma_MailData(al_MailIdx).AppStatus
    Exit Function
    
ErrHandler:
    GetAppStatus = ""
    Call ErrorHandler("GetAppStatus")
End Function

'changes EML_AppStatus and automaticcaly changes also EML_MailStatus = EML_MAILSTATUS_PROCESSED
Public Sub SetAppStatusForReadedEmail(ByVal al_MailIdx As Long, ByVal as_EML_AppStatus As String, Optional al_EML_Code As Long = 0)

Const UPD_REQ As String = "UPDATE EML_Mail SET EML_AppStatus=$EML_AppStatus$,EML_MailStatus='" & EML_MAILSTATUS_PROCESSED & "' WHERE EML_Code=$EML_Code$"

On Error GoTo ErrHandler
Dim ls_req       As String

    If mb_Initialized = False Then Call Err.Raise(ArmErr.CPTNotInitialized)
    
    If Len(as_EML_AppStatus) <> 1 Then
        Call Err.Raise(ArmErr.InvalidValue, "SetAppStatus", "AppStatus must be only one character!")
    End If
        
    ls_req = Replace(UPD_REQ, "$EML_AppStatus$", SQLStr(as_EML_AppStatus))
    
    If al_MailIdx >= 0 Then
        ls_req = Replace(ls_req, "$EML_Code$", ma_MailData(al_MailIdx).EML_Code)
    Else
        ls_req = Replace(ls_req, "$EML_Code$", SqlDbl(al_EML_Code))
    End If
        
    Call ExecuteSQLSafe(mo_Db, ls_req)
    
    If al_MailIdx >= 0 Then
        ma_MailData(al_MailIdx).AppStatus = as_EML_AppStatus
    End If
    Exit Sub
        
ErrHandler:
    Call ErrorHandler("SetAppStatus")
End Sub

' Get attachment
Public Function GetAttachment(ByVal al_MailIdx As Long, ByVal al_AttachmentIdx, ByVal as_destPath As String, _
                             Optional as_DestName As String = "", Optional ab_ClearDestPath As Boolean = False) As Boolean
On Error GoTo ErrHandler

Dim ls_Storage As String
Dim ls_StoredName As String
Dim ls_Name     As String
Dim ls_path     As String
Dim lo_folder   As Object

    If mb_Initialized = False Then Call Err.Raise(ArmErr.CPTNotInitialized)
    
    ls_path = ma_MailData(al_MailIdx).Attachments(al_AttachmentIdx).Path
    ls_Storage = ma_MailData(al_MailIdx).Attachments(al_AttachmentIdx).Storage
    ls_StoredName = ma_MailData(al_MailIdx).Attachments(al_AttachmentIdx).StoredName

    If as_DestName = "" Then
        If ls_Storage = EML_ATTSTORAGE_DIRECTORY Then
            ls_Name = ma_MailData(al_MailIdx).Attachments(al_AttachmentIdx).StoredName
        Else
            ls_Name = ma_MailData(al_MailIdx).Attachments(al_AttachmentIdx).Name
        End If
    Else
        ls_Name = as_DestName
    End If
    
    If ab_ClearDestPath = True Then
    
        ' clear outgoing emails attachments folder
        If Not mo_FSO.FolderExists(as_destPath) Then
            If Not CreateDirStruct(as_destPath, mo_FSO) Then
                Call Err.Raise(CompFncFailed, "GetAttchment", "Folder for email attachments does not exist and cannot be created!")
        End If
        End If
        
        Set lo_folder = mo_FSO.GetFolder(as_destPath)
        Call mo_FSO.DeleteFile(as_destPath & "\*.*", True)
    End If
    
    If ls_Storage = EML_ATTSTORAGE_SQLDATABASE Or ls_Storage = EML_ATTSTORAGE_DIRECTORY Then
           
        If ls_Storage = EML_ATTSTORAGE_SQLDATABASE Then
            'get attachments from database and save them into outgoing directory
            If Not mo_Db.BlobToFileSQL("SELECT EAT_Data FROM EML_Attachment WHERE EAT_Code=" & ma_MailData(al_MailIdx).Attachments(al_AttachmentIdx).EAT_Code, as_destPath & "\" & ls_Name) Then
                Err.Raise ArmErr.SQLFailure, "BlobToFileSQL", "Error reading file from blob: File: " & as_destPath & "\" & ls_Name
            End If
        ElseIf ls_Storage = EML_ATTSTORAGE_DIRECTORY Then
            'copy attachments into outgoing directory
            Call mo_FSO.CopyFile(ls_path & "\" & ls_StoredName, as_destPath & "\" & ls_Name)
        End If
        
    End If

    GetAttachment = True
    Exit Function
    
ErrHandler:
    GetAttachment = False
    Call ErrorHandler("GetAttachment")
End Function

Public Function ReadEmails(Optional as_EML_MailStatus As String = EML_MAILSTATUS_NEW, Optional as_EML_AppStatus As String = "", Optional as_MaxToRead As Long = -1) As Long

Const READ_REQ_ONE As String = "EXEC EML_GetOneIncomingEmail_lst $EAC_Code$, $EML_MailStatus$, $EML_AppStatus$"
Const READ_REQ_ALL As String = "EXEC EML_GetIncomingEmails_lst $EAC_Code$, $EML_MailStatus$, $EML_AppStatus$"

On Error GoTo ErrHandler

Dim ll_cursor               As Long
Dim ll_readedEmails         As Long
Dim lb_Res                  As Boolean
Dim ll_MailIndex            As Long
Dim ls_req                  As String

    ll_MailIndex = 0
    
    If mb_Initialized = False Then Call Err.Raise(ArmErr.CPTNotInitialized)
    
    If mo_MailBoxInfo.Initialized = False Then
        Call Err.Raise(ArmErr.InvalidValue, "ReadEmails", "MailBox is not initialized!")
    End If
    
    If as_MaxToRead = 1 Then
        ls_req = Replace(READ_REQ_ONE, "$EAC_Code$", mo_MailBoxInfo.EAC_Code, , , vbTextCompare)
    Else
        ls_req = Replace(READ_REQ_ALL, "$EAC_Code$", mo_MailBoxInfo.EAC_Code, , , vbTextCompare)
    End If

    ls_req = Replace(ls_req, "$EML_MailStatus$", SQLStr(as_EML_MailStatus), , , vbTextCompare)

    If as_EML_AppStatus = "" Then
        ls_req = Replace(ls_req, "$EML_AppStatus$", "Null", , , vbTextCompare)
    Else
        ls_req = Replace(ls_req, "$EML_AppStatus$", SQLStr(as_EML_AppStatus), , , vbTextCompare)
    End If
    
    ' select outgoing email
    ll_cursor = OpenSQLSafe(mo_Db, ls_req)
        
    If mo_Db.RowCount(ll_cursor) <= 0 Then
        mo_Db.Close (ll_cursor)
        ReadEmails = 0
        Exit Function
    End If
        
    ReDim ma_MailData(mo_Db.RowCount(ll_cursor) - 1)
        
    While Not mo_Db.EOF(ll_cursor) And (as_MaxToRead = -1 Or ll_MailIndex < as_MaxToRead)
                
        ReDim ma_MailData(ll_MailIndex).Addresses(-1 To -1)
        ReDim ma_MailData(ll_MailIndex).Attachments(-1 To -1)
        
        ' read all info for one email
        Call ReadEmail(ll_cursor, ll_MailIndex)
        
        ll_MailIndex = ll_MailIndex + 1
        mo_Db.Next (ll_cursor)
    Wend

    mo_Db.Close (ll_cursor)
    ll_cursor = 0

    ReadEmails = ll_MailIndex
    
    Exit Function
ErrHandler:
    
    ReadEmails = 0
    
    If ll_cursor > 0 Then
        mo_Db.Close (ll_cursor)
        ll_cursor = 0
    End If
    
    Call ErrorHandler("ReadEmails")
End Function

Public Function CheckMailIndex(ByVal al_MailIndex As Long) As Boolean
On Error GoTo ErrHandler

    If mb_Initialized = False Then Call Err.Raise(ArmErr.CPTNotInitialized)
    
    If UBound(ma_MailData) = -1 Then
        CheckMailIndex = False
    End If
    
    If UBound(ma_MailData) < al_MailIndex Then
        CheckMailIndex = False
    End If
    
    CheckMailIndex = True
    Exit Function
ErrHandler:
    CheckMailIndex = False
    Call ErrorHandler("CheckMailIndex")
End Function

Public Function SendEmail(ByVal al_MailDataIdx As Long) As Long

Const REQ_ATT_INFO_INS As String = "exec EML_AttachmentInfo_ins $EAI_Code$,$EAT_Code$,$EML_Code$,'$EAI_Storage$','$EAI_Directory$','$EAI_Name$','$EAI_StoredName$',$Z_Creator$"
Const REQ_ATT_DATA_INS As String = "INSERT INTO EML_Attachment (EAT_Code,EAT_Data) VALUES ($EAT_Code$,?)"
Const REQ_MAIL_INS As String = "exec EML_Mail_ins $EML_Code$,$EAC_Code$,'$EML_Mailbox$','$EML_MailStatus$','$EML_MailType$',$EML_MailLink$,N$EML_Subject$,$EML_Charset$,$EML_AppStatus$,$EML_DateReceived$,$EML_DateToSend$,$EML_DateSent$,$Z_Creator$"

Const REQ_CONTENT_INS As String = "INSERT INTO EML_Content (EMC_Code, EML_Code,EML_Content,EML_HTMLContent) VALUES ($EMC_Code$,$EML_Code$, $EML_Content$, $EML_HTMLContent$)"

On Error GoTo ErrHandler

Dim ls_EAT_Code             As String
Dim ls_EML_Code             As String
Dim ls_EAI_StoredName       As String
Dim la_AttachmentInfo()     As AttachmentInfo
Dim ll_Idx2                 As Long
Dim ls_req                  As String
Dim lb_AttachmentsCopied    As Boolean
Dim lb_inTransaction        As Boolean
Dim ll_EMC_Code             As Long

    SendEmail = 0
    
    If mb_Initialized = False Then Call Err.Raise(ArmErr.CPTNotInitialized)
    
    If mo_MailBoxInfo.Initialized = False Then
        Call Err.Raise(ArmErr.InvalidValue, "SendEmail", "MailBox is not initialized!")
    End If

    If CheckMailIndex(al_MailDataIdx) = False Then
        Err.Raise ArmErr.InvalidValue, "SendEmail", "Used Mail index is incorrect. (Out of range) MailIndex = " & al_MailDataIdx
    End If
    
    If ma_MailData(al_MailDataIdx).MailBoxType = EML_MAILBOX_INBOX Then
        Err.Raise ArmErr.InvalidValue, "SendEmail", "This email cannot be sent because it has been read from MSSQL. You can only send Emails created directly in MailClient module"
    End If
        
    ls_EML_Code = mo_Db.SQLNextID("EML_Mail")
    ll_EMC_Code = mo_Db.SQLNextID("EML_Content")

    ' Insert into EML_Attachment
    If mo_MailBoxInfo.StorageOutbox <> EML_ATTSTORAGE_IGNORE And UBound(ma_MailData(al_MailDataIdx).Attachments) >= 0 Then
        ll_Idx2 = 0
        ReDim la_AttachmentInfo(UBound(ma_MailData(al_MailDataIdx).Attachments))

        For ll_Idx2 = 0 To UBound(ma_MailData(al_MailDataIdx).Attachments)
            If mo_MailBoxInfo.StorageOutbox = EML_ATTSTORAGE_SQLDATABASE Then
                    
                    ls_EAT_Code = mo_Db.SQLNextID("EML_Attachment")
                     
                    ls_req = Replace(REQ_ATT_DATA_INS, "$EAT_Code$", ls_EAT_Code, , , vbTextCompare)
        
                    If Not mo_Db.FileToBlobSQL(ls_req, ma_MailData(al_MailDataIdx).Attachments(ll_Idx2).Path & "\" & ma_MailData(al_MailDataIdx).Attachments(ll_Idx2).Name, 9) Then
                        Err.Raise ArmErr.SQLFailure, "FileToBlobSQL", "Error writing blob: " & ls_req & " File: " & ma_MailData(al_MailDataIdx).Attachments(ll_Idx2).Path & "\" & ma_MailData(al_MailDataIdx).Attachments(ll_Idx2).Name
                    End If
                    
                    la_AttachmentInfo(ll_Idx2).EAT_Code = ls_EAT_Code
                  
            ElseIf mo_MailBoxInfo.StorageOutbox = EML_ATTSTORAGE_DIRECTORY Then
                Call mo_FSO.CopyFile(ma_MailData(al_MailDataIdx).Attachments(ll_Idx2).Path & "\" & ma_MailData(al_MailDataIdx).Attachments(ll_Idx2).Name, mo_MailBoxInfo.DirectoryOutbox & "\C" & ls_EML_Code & "-" & ll_Idx2)
                la_AttachmentInfo(ll_Idx2).FileName = mo_MailBoxInfo.DirectoryOutbox & "\C" & ls_EML_Code & "-" & ll_Idx2
                la_AttachmentInfo(ll_Idx2).StoredName = "C" & ls_EML_Code & "-" & ll_Idx2
                
            End If
            
            la_AttachmentInfo(ll_Idx2).EAI_Code = mo_Db.SQLNextID("EML_AttachmentInfo")

        Next ll_Idx2
        
        ' in case that there are any attachments and Storage=EML_ATTSTORAGE_DIRECTORY at this point they
        ' are copied already into final folder, this is made in advance because
        ' the rest of mail processing is in transaction and copying files could
        ' be a long lasting operation
        lb_AttachmentsCopied = True
    End If
    
    'begin transaction...
    BeginTran ("EML_MailClient")
    lb_inTransaction = True
    
    ' Insert into EML_Mail
    
    ls_req = Replace(REQ_MAIL_INS, "$EML_Code$", ls_EML_Code, , , vbTextCompare)
    ls_req = Replace(ls_req, "$EAC_Code$", mo_MailBoxInfo.EAC_Code, , , vbTextCompare)
    ls_req = Replace(ls_req, "$EML_Mailbox$", EML_MAILBOX_OUTBOX, , , vbTextCompare)
    ls_req = Replace(ls_req, "$EML_MailStatus$", EML_MAILSTATUS_NEW, , , vbTextCompare)
    ls_req = Replace(ls_req, "$EML_MailType$", EML_MAILTYPE_DEFAULT, , , vbTextCompare)
    ls_req = Replace(ls_req, "$EML_MailLink$", "Null", , , vbTextCompare)
    ls_req = Replace(ls_req, "$EML_Subject$", SQLStr(ma_MailData(al_MailDataIdx).Subject), , , vbTextCompare)
    ls_req = Replace(ls_req, "$EML_Charset$", SQLStr(ma_MailData(al_MailDataIdx).HTMLCharset), , , vbTextCompare)
    ls_req = Replace(ls_req, "$EML_AppStatus$", SQLStr(ma_MailData(al_MailDataIdx).AppStatus), , , vbTextCompare)
    ls_req = Replace(ls_req, "$EML_DateReceived$", SqlDate(Now), , , vbTextCompare)
    ls_req = Replace(ls_req, "$EML_DateToSend$", SqlDate(ma_MailData(al_MailDataIdx).DateToSend), , , vbTextCompare)
    ls_req = Replace(ls_req, "$EML_DateSent$", "Null", , , vbTextCompare)
    ls_req = Replace(ls_req, "$Z_Creator$", ml_U_code, , , vbTextCompare)
    
    Call ExecuteSQLSafe(mo_Db, ls_req)
    
    
    ' Insert into EML_AttachmentInfo
    If mo_MailBoxInfo.StorageOutbox <> EML_ATTSTORAGE_IGNORE And UBound(ma_MailData(al_MailDataIdx).Attachments) >= 0 Then
        ll_Idx2 = 0
        For ll_Idx2 = 0 To UBound(ma_MailData(al_MailDataIdx).Attachments)
                                              
            If mo_MailBoxInfo.StorageOutbox = EML_ATTSTORAGE_DIRECTORY Then
                ' store into directory
                ls_EAT_Code = "Null"
                ls_EAI_StoredName = "C" & ls_EML_Code & "-" & ll_Idx2
            ElseIf mo_MailBoxInfo.StorageOutbox = EML_ATTSTORAGE_SQLDATABASE Then
                ls_EAT_Code = la_AttachmentInfo(ll_Idx2).EAT_Code
                ls_EAI_StoredName = ""
            End If
                
            ls_req = Replace(REQ_ATT_INFO_INS, "$EAI_Code$", la_AttachmentInfo(ll_Idx2).EAI_Code, , , vbTextCompare)
            ls_req = Replace(ls_req, "$EAT_Code$", ls_EAT_Code, , , vbTextCompare)
            ls_req = Replace(ls_req, "$EML_Code$", ls_EML_Code, , , vbTextCompare)
            ls_req = Replace(ls_req, "$EAI_Storage$", mo_MailBoxInfo.StorageOutbox, , , vbTextCompare)
            ls_req = Replace(ls_req, "$EAI_Directory$", mo_MailBoxInfo.DirectoryOutbox, , , vbTextCompare)
            ls_req = Replace(ls_req, "$EAI_Name$", ma_MailData(al_MailDataIdx).Attachments(ll_Idx2).Name, , , vbTextCompare)
            ls_req = Replace(ls_req, "$EAI_StoredName$", ls_EAI_StoredName, , , vbTextCompare)
            ls_req = Replace(ls_req, "$Z_Creator$", ml_U_code, , , vbTextCompare)
                                        
            Call ExecuteSQLSafe(mo_Db, ls_req)
          
        Next ll_Idx2
    End If
                
    ' Insert into EML_Address
    Call InsertEmailAddress(ls_EML_Code, ma_MailData(al_MailDataIdx).Addresses, emlEmailType.etEmailTo)
    Call InsertEmailAddress(ls_EML_Code, ma_MailData(al_MailDataIdx).Addresses, emlEmailType.etEmailCopyTo)
    Call InsertEmailAddress(ls_EML_Code, ma_MailData(al_MailDataIdx).Addresses, emlEmailType.etEmailBlindCopyTo)
    Call InsertEmailAddress(ls_EML_Code, ma_MailData(al_MailDataIdx).Addresses, emlEmailType.etEmailFrom)
      
    ' Insert into EML_Content
    If ma_MailData(al_MailDataIdx).Message <> "" Or ma_MailData(al_MailDataIdx).HTMLMessage <> "" Then
    
        ls_req = Replace(REQ_CONTENT_INS, "$EMC_Code$", SqlDbl(ll_EMC_Code), , , vbTextCompare)
        ls_req = Replace(ls_req, "$EML_Code$", ls_EML_Code, , , vbTextCompare)
        ls_req = Replace(ls_req, "$EML_Content$", "N" & SQLStr(ma_MailData(al_MailDataIdx).Message), , , vbTextCompare)
        
        If ma_MailData(al_MailDataIdx).IsHtml = True Then
            ls_req = Replace(ls_req, "$EML_HTMLContent$", "N" & SQLStr(ma_MailData(al_MailDataIdx).HTMLMessage), , , vbTextCompare)
        Else
            ls_req = Replace(ls_req, "$EML_HTMLContent$", "Null", , , vbTextCompare)
        End If
        Call ExecuteSQLSafe(mo_Db, ls_req)
    End If
                            
    CommitTran ("EML_MailClient")
    lb_inTransaction = False
    lb_AttachmentsCopied = False
    
    SendEmail = Val(ls_EML_Code)
    
    Exit Function

ErrHandler:

    Call UpdateError(True)

    If lb_inTransaction = True Then
        Call RollbackTran("EML_MailClient")
        lb_inTransaction = False
    End If
        
    ' delete attachments
    If lb_AttachmentsCopied = True Then
        If mo_MailBoxInfo.StorageOutbox = EML_ATTSTORAGE_DIRECTORY Then
            For ll_Idx2 = 0 To UBound(la_AttachmentInfo)
                If la_AttachmentInfo(ll_Idx2).FileName <> "" Then
                    Call mo_FSO.DeleteFile(la_AttachmentInfo(ll_Idx2).FileName, True)
                End If
            Next
        ElseIf mo_MailBoxInfo.StorageOutbox = EML_ATTSTORAGE_SQLDATABASE Then
            ls_req = "DELETE FROM EML_Attachment WHERE EAT_Code IN ("
            For ll_Idx2 = 0 To UBound(la_AttachmentInfo)
                If la_AttachmentInfo(ll_Idx2).EAT_Code <> "" Then
                    ls_req = ls_req & la_AttachmentInfo(ll_Idx2).EAT_Code
                End If
                If ll_Idx2 < UBound(la_AttachmentInfo) Then
                    ls_req = ls_req & ","
                End If
            Next
            ls_req = ls_req & ")"
            Call ExecuteSQLSafe(mo_Db, ls_req)
        End If
        
    End If
    
    Call UpdateError(False)

    Call ErrorHandler("SendEmail")
End Function
' end of public interface

' cleare main mail data structure, all indexes will be invalid
Public Sub ClearData()
On Error GoTo ErrHandler

    If mb_Initialized = False Then Call Err.Raise(ArmErr.CPTNotInitialized)
    
    ReDim ma_MailData(-1 To -1)
    Exit Sub

ErrHandler:
    Call ErrorHandler("ClearData")
End Sub

' Class Module Private procedures and Functions
Private Function ReadEmail(ByVal al_cursorEmail As Long, ByVal al_MailIndex As Long) As Boolean
On Error GoTo ErrHandler

Dim ll_cursorAtt            As Long
Dim ls_Addresses            As String
Dim ls_Storage              As String
Dim ls_Directory            As String
Dim ls_Name                 As String
Dim ls_StoredName           As String
Dim ls_EAT_Code             As String
Dim ll_Idx                  As Long
            
    ma_MailData(al_MailIndex).EML_Code = mo_Db.GetFields(al_cursorEmail, "EML_Code")
    ma_MailData(al_MailIndex).Subject = mo_Db.GetFields(al_cursorEmail, "EML_Subject")
    ma_MailData(al_MailIndex).Message = mo_Db.GetFields(al_cursorEmail, "EML_Content")
    ma_MailData(al_MailIndex).HTMLMessage = mo_Db.GetFields(al_cursorEmail, "EML_HTMLContent")
    ma_MailData(al_MailIndex).AppStatus = mo_Db.GetFields(al_cursorEmail, "EML_AppStatus")
    ma_MailData(al_MailIndex).MailBoxType = EML_MAILBOX_INBOX
    
    If mo_Db.GetFields(al_cursorEmail, "IsHTML") = "NoHTML" Then
        ma_MailData(al_MailIndex).IsHtml = False
    Else
        ma_MailData(al_MailIndex).IsHtml = True
    End If
            
    Call ReadEmailAddress(al_MailIndex, ma_MailData(al_MailIndex).EML_Code, emlEmailType.etEmailTo)
    Call ReadEmailAddress(al_MailIndex, ma_MailData(al_MailIndex).EML_Code, emlEmailType.etEmailCopyTo)
    Call ReadEmailAddress(al_MailIndex, ma_MailData(al_MailIndex).EML_Code, emlEmailType.etEmailBlindCopyTo)
    Call ReadEmailAddress(al_MailIndex, ma_MailData(al_MailIndex).EML_Code, emlEmailType.etEmailFrom)
                    
    ll_cursorAtt = OpenSQLSafe(mo_Db, "EXEC EML_AttachmentInfo_lst " & ma_MailData(al_MailIndex).EML_Code)
    
    If mo_Db.RowCount(ll_cursorAtt) > 0 Then
    
        ReDim ma_MailData(al_MailIndex).Attachments(mo_Db.RowCount(ll_cursorAtt) - 1)
        
        ll_Idx = 0
        
         ' Extract attachments
        While Not mo_Db.EOF(ll_cursorAtt)
        
            ma_MailData(al_MailIndex).Attachments(ll_Idx).Storage = mo_Db.GetFields(ll_cursorAtt, "EAI_Storage")
            ma_MailData(al_MailIndex).Attachments(ll_Idx).Path = mo_Db.GetFields(ll_cursorAtt, "EAI_Directory")
            ma_MailData(al_MailIndex).Attachments(ll_Idx).Name = mo_Db.GetFields(ll_cursorAtt, "EAI_Name")
            ma_MailData(al_MailIndex).Attachments(ll_Idx).StoredName = mo_Db.GetFields(ll_cursorAtt, "EAI_StoredName")
            ma_MailData(al_MailIndex).Attachments(ll_Idx).EAT_Code = mo_Db.GetFields(ll_cursorAtt, "EAT_Code")
                
            ll_Idx = ll_Idx + 1
            mo_Db.Next (ll_cursorAtt)
        Wend
    
    End If
    
    mo_Db.Close (ll_cursorAtt)

    ReadEmail = True
    Exit Function
    
ErrHandler:
    ReadEmail = False
        
    Call ErrorHandler("ReadEmail")
End Function

' Read email addresses for specific email message
Private Sub ReadEmailAddress(ByVal al_MailIdx As Long, ByVal as_Code As String, ByVal ae_Type As emlEmailType)
Const LST_REQ As String = "exec EML_EmailAddress_lst $CODE$,'$TYPE$'"
Dim ls_req As String
Dim li_Idx As Long
Dim ll_cursor As Long
Dim ll_CurrentNrOfEmails As Long
Dim ls_EmailType As String

On Error GoTo ErrHandler
    
    Select Case ae_Type
    Case emlEmailType.etEmailTo
        ls_EmailType = "T"
    Case emlEmailType.etEmailCopyTo
        ls_EmailType = "C"
    Case emlEmailType.etEmailBlindCopyTo
        ls_EmailType = "B"
    Case emlEmailType.etEmailFrom
        ls_EmailType = "F"
    End Select
    
    ls_req = Replace(LST_REQ, "$CODE$", as_Code, , , vbTextCompare)
    ls_req = Replace(ls_req, "$TYPE$", ls_EmailType, , , vbTextCompare)
        
    ll_cursor = OpenSQLSafe(mo_Db, ls_req)
    ll_CurrentNrOfEmails = UBound(ma_MailData(al_MailIdx).Addresses)
    
    If mo_Db.RowCount(ll_cursor) > 0 Then
    
        If ll_CurrentNrOfEmails = -1 Then
            ReDim ma_MailData(al_MailIdx).Addresses(mo_Db.RowCount(ll_cursor) - 1)
        Else
            ReDim Preserve ma_MailData(al_MailIdx).Addresses(ll_CurrentNrOfEmails + mo_Db.RowCount(ll_cursor))
        End If
        
        li_Idx = ll_CurrentNrOfEmails + 1
        While Not mo_Db.EOF(ll_cursor)
            ma_MailData(al_MailIdx).Addresses(li_Idx).EMail = mo_Db.GetFields(ll_cursor, "EAD_Name")
            ma_MailData(al_MailIdx).Addresses(li_Idx).Type = ae_Type
            li_Idx = li_Idx + 1
            mo_Db.Next (ll_cursor)
        Wend
    End If
    
    Call mo_Db.Close(ll_cursor)
    ll_cursor = 0
   
    Exit Sub
ErrHandler:
    If ll_cursor > 0 Then
        Call mo_Db.Close(ll_cursor)
        ll_cursor = 0
    End If
    
    Call ErrorHandler("ReadEmailAddress")
End Sub

' insert email address into database
Private Sub InsertEmailAddress(ByVal as_Code As String, ByRef as_EmailAddresses() As tMAIL_ADDRESS, ByVal ae_Type As emlEmailType)

Const INS_REQ As String = "exec EML_Address_ins $CODE$,'$TYPE$',$ORDER$,'$ADDRESS$',$UCODE$,$CREATOR$"

Dim li_UCode As Long
Dim ls_UCode As String
Dim lv_addressArray As Variant
Dim ls_Address As Variant
Dim ls_req As String
Dim li_Idx As Long
Dim ls_EmailType As String

On Error GoTo ErrHandler
           
    li_Idx = 1
    
    For li_Idx = 0 To UBound(as_EmailAddresses)
    
        If as_EmailAddresses(li_Idx).Type = ae_Type Then
            li_UCode = GetUCodeForAddress(as_EmailAddresses(li_Idx).EMail)
            If li_UCode > 0 Then
                ls_UCode = li_UCode
            Else
                ls_UCode = "Null"
            End If
            
            Select Case ae_Type
            Case emlEmailType.etEmailTo
                ls_EmailType = "T"
            Case emlEmailType.etEmailCopyTo
                ls_EmailType = "C"
            Case emlEmailType.etEmailBlindCopyTo
                ls_EmailType = "B"
            Case emlEmailType.etEmailFrom
                ls_EmailType = "F"
            End Select

            ls_req = Replace(INS_REQ, "$CODE$", as_Code, , , vbTextCompare)
            ls_req = Replace(ls_req, "$TYPE$", ls_EmailType, , , vbTextCompare)
            ls_req = Replace(ls_req, "$ORDER$", li_Idx + 1, , , vbTextCompare)
            ls_req = Replace(ls_req, "$ADDRESS$", as_EmailAddresses(li_Idx).EMail, , , vbTextCompare)
            ls_req = Replace(ls_req, "$UCODE$", ls_UCode, , , vbTextCompare)
            ls_req = Replace(ls_req, "$CREATOR$", ml_U_code, , , vbTextCompare)
            
            Call ExecuteSQLSafe(mo_Db, ls_req, 1)
        End If
    Next
   
    Exit Sub
ErrHandler:
    Call ErrorHandler("InsertEmailAddress")
End Sub

' Try to find U_Code for an email address
Public Function GetUCodeForAddress(ByVal as_Address As String) As Long
Const GET_UCODE_REQ As String = "SELECT TOP 1 SU.U_Code FROM GEN_Systems_Users SU" _
          & " WHERE SU.U_Email_Armstrong=$EMAIL$ OR SU.U_email_others = $EMAIL$"
          
Dim ll_cursor As Long
Dim ls_req As String
    
On Error GoTo ErrHandler
    GetUCodeForAddress = 0
    
    ls_req = Replace(GET_UCODE_REQ, "$EMAIL$", SQLStr(as_Address), , , vbTextCompare)

    ll_cursor = OpenSQLSafe(mo_Db, ls_req)
    If Not mo_Db.EOF(ll_cursor) Then
        GetUCodeForAddress = Val(mo_Db.GetFields(ll_cursor, "U_Code"))
    End If
    Call mo_Db.Close(ll_cursor)
    ll_cursor = 0
    Exit Function
    
ErrHandler:
    If ll_cursor > 0 Then
        Call mo_Db.Close(ll_cursor)
        ll_cursor = 0
    End If
        
    Call ErrorHandler("GetUCodeForAddress")
End Function

' Try to find U_Code for an email address
Public Function GetAddressForUCode(ByVal ai_UCode As Long) As String
Const GET_UCODE_REQ As String = "SELECT TOP 1 SU.U_Email_Armstrong,SU.U_email_others FROM GEN_Systems_Users SU" _
          & " WHERE SU.U_Code=$UCODE$"
          
Dim ll_cursor As Long
Dim ls_req As String
Dim ls_ArmEmail As String
Dim ls_OtherEmail As String
    
On Error GoTo ErrHandler

    GetAddressForUCode = ""

    ls_ArmEmail = ""
    ls_OtherEmail = ""
    
    ls_req = Replace(GET_UCODE_REQ, "$UCODE$", ai_UCode, , , vbTextCompare)

    ll_cursor = OpenSQLSafe(mo_Db, ls_req)
    If Not mo_Db.EOF(ll_cursor) Then
        ls_ArmEmail = mo_Db.GetFields(ll_cursor, "U_Email_Armstrong")
        ls_OtherEmail = mo_Db.GetFields(ll_cursor, "U_email_others")
    End If
    Call mo_Db.Close(ll_cursor)
    ll_cursor = 0
    
    If ls_ArmEmail <> "" Then
        GetAddressForUCode = ls_ArmEmail
    ElseIf ls_OtherEmail <> "" Then
        GetAddressForUCode = ls_OtherEmail
    Else
        GetAddressForUCode = ""
    End If
    
    Exit Function
    
ErrHandler:

    GetAddressForUCode = ""

    If ll_cursor > 0 Then
        Call mo_Db.Close(ll_cursor)
        ll_cursor = 0
    End If
        
    Call ErrorHandler("GetUCodeForAddress")
End Function

Public Function IsEmailValid(ByVal as_EmailText As String) As Boolean
On Error GoTo ErrHandler

Dim ls_Email
Dim las_Email() As String
Dim ll_Index As Long

IsEmailValid = True

  If Trim(as_EmailText) <> "" Then
    las_Email = Split(Replace(Trim(as_EmailText), ";", ","), ",")
    For ll_Index = 0 To UBound(las_Email)
      ls_Email = Trim(las_Email(ll_Index))
      If InStr(1, ls_Email, "/") Then
        If CheckLotusEmailFormat(ls_Email) = False Then
            IsEmailValid = False
            Exit Function
        End If
      Else
        If CheckNormalEmailFormat(ls_Email) = False Then
            IsEmailValid = False
            Exit Function
        End If
      End If
    Next
  End If
  Exit Function

ErrHandler:
    Call ErrorHandler("IsEmailValid")
End Function

Private Function CheckLotusEmailFormat(ByVal as_EmailCheck As String) As Boolean
On Error GoTo ErrHandler

Dim lb_CK As Boolean
Dim ll_Index As Long
Dim ll_Index2 As Long
Dim las_EmailParts() As String
Dim ls_EmailPart As String
Const sInvalidChars As String = "@"

    lb_CK = True
    
    las_EmailParts = Split(Trim(as_EmailCheck), "/")
    
    If UBound(las_EmailParts) < 2 Then
        lb_CK = False
        GoTo ExitFunction
    End If
    
    For ll_Index = 0 To UBound(las_EmailParts)
        ls_EmailPart = Trim(las_EmailParts(ll_Index))
        If Trim(ls_EmailPart) = "" Then
            lb_CK = False
            GoTo ExitFunction
        End If
        
        ' Check for invalid characters.
        If Len(as_EmailCheck) > Len(sInvalidChars) Then
            For ll_Index2 = 1 To Len(sInvalidChars)
                If InStr(as_EmailCheck, Mid(sInvalidChars, ll_Index2, 1)) > 0 Then
                    lb_CK = False
                    GoTo ExitFunction
                End If
            Next
        Else
            For ll_Index2 = 1 To Len(as_EmailCheck)
                If InStr(sInvalidChars, Mid(as_EmailCheck, ll_Index2, 1)) > 0 Then
                    lb_CK = False
                    GoTo ExitFunction
                End If
            Next
        End If
    
    Next
    
ExitFunction:
    CheckLotusEmailFormat = lb_CK
    Exit Function

ErrHandler:
    CheckLotusEmailFormat = False
    Call ErrorHandler("CheckLotusEmailFormat")

End Function

Private Function CheckNormalEmailFormat(ByVal as_EmailCheck As String) As Boolean
On Error GoTo ErrHandler

Dim lb_CK As Boolean
Dim ls_DomainType As String
Const sInvalidChars As String = "!#$%^&*()=+{}[]|\;:'/?>,< "
Dim ll_Index As Long

    lb_CK = Not InStr(1, as_EmailCheck, Chr(34)) > 0 'Check to see if there is a double quote
    If Not lb_CK Then GoTo ExitFunction
    
    lb_CK = Not InStr(1, as_EmailCheck, "..") > 0 'Check to see if there are consecutive dots
    If Not lb_CK Then GoTo ExitFunction
    
    ' Check for invalid characters.
    If Len(as_EmailCheck) > Len(sInvalidChars) Then
        For ll_Index = 1 To Len(sInvalidChars)
            If InStr(as_EmailCheck, Mid(sInvalidChars, ll_Index, 1)) > 0 Then
                lb_CK = False
                GoTo ExitFunction
            End If
        Next
    Else
        For ll_Index = 1 To Len(as_EmailCheck)
            If InStr(sInvalidChars, Mid(as_EmailCheck, ll_Index, 1)) > 0 Then
                lb_CK = False
                GoTo ExitFunction
            End If
        Next
    End If
    
    If InStr(1, as_EmailCheck, "@") > 1 Then 'Check for an @ symbol
        lb_CK = Len(Left(as_EmailCheck, InStr(1, as_EmailCheck, "@") - 1)) > 0
    Else
        lb_CK = False
    End If
    If Not lb_CK Then GoTo ExitFunction
    
    as_EmailCheck = right(as_EmailCheck, Len(as_EmailCheck) - InStr(1, as_EmailCheck, "@"))
    lb_CK = Not InStr(1, as_EmailCheck, "@") > 0 'Check to see if there are too many @'s
    If Not lb_CK Then GoTo ExitFunction
    
    If InStr(1, as_EmailCheck, ".") = 0 Then
        lb_CK = False
        GoTo ExitFunction
    End If
    
    ls_DomainType = right(as_EmailCheck, Len(as_EmailCheck) - InStr(1, as_EmailCheck, "."))
    lb_CK = Len(ls_DomainType) > 0 And InStr(1, as_EmailCheck, ".") < Len(as_EmailCheck)
    If Not lb_CK Then GoTo ExitFunction
    
    as_EmailCheck = Left(as_EmailCheck, Len(as_EmailCheck) - Len(ls_DomainType) - 1)
    Do Until InStr(1, as_EmailCheck, ".") <= 1
        If Len(as_EmailCheck) >= InStr(1, as_EmailCheck, ".") Then
            as_EmailCheck = Left(as_EmailCheck, Len(as_EmailCheck) - (InStr(1, as_EmailCheck, ".") - 1))
        Else
            lb_CK = False
            GoTo ExitFunction
        End If
    Loop
    If as_EmailCheck = "." Or Len(as_EmailCheck) = 0 Then lb_CK = False
    
ExitFunction:
    CheckNormalEmailFormat = lb_CK
    Exit Function
    
ErrHandler:
    CheckNormalEmailFormat = False
    Call ErrorHandler("CheckNormalEmailFormat")
End Function

' *******************************************************************************
' ************************ DISK IO FUNCTIONS ************************************
' *******************************************************************************
' create directory if not exist
Private Function CreateDirStruct(ByVal strPath As String, ByVal ao_FSO As Object) As Boolean

On Error GoTo Create_Dir_Struct_Errors
    Dim intIndex    As Integer
    Dim strTmpPath  As String
    
    If Len(Trim$(strPath)) = 0 Then
        ' if we specify wrong path it is error
        CreateDirStruct = False
        Exit Function
    End If
    
    If right$(strPath, 1) <> "\" Then strPath = strPath & "\"
    intIndex = 0
    
    Do
        ' get the next path chunk
        intIndex = InStr(intIndex + 1, strPath, "\")
        
        If intIndex > 0 Then
            strTmpPath = Left$(strPath, intIndex - 1)
        Else
            Exit Do
        End If

        ' see if this folder exists
        If Not ao_FSO.FolderExists(strTmpPath) Then
            ' Create this folder.
            ' If there is an error, it will be trapped bellow
            ao_FSO.CreateFolder strTmpPath
            intIndex = 1
        End If
    Loop
    CreateDirStruct = True
    Exit Function

Create_Dir_Struct_Errors:
    Call ErrorHandler(C_MODULE_NAME & ".CreateDirStruct()")
End Function

' ************************************************************************************
' **************************** DB-ACCESS FUNCTIONS ***********************************
' ************************************************************************************

' Return the result of a SQL request
' Convert SQL runtime errors and process errors to VB Error
' Return the result of a SQL request
' Convert SQL runtime errors and process errors to VB Error
#If LIVE = 1 Then
Private Function OpenSQLSafe(ByVal ao_DB As Object, ByVal as_Request As String, Optional ByVal al_RowExpectedCount = -1) As Long
#Else
Private Function OpenSQLSafe(ByVal ao_DB As ARMSYSCOMLib.ArmDb, ByVal as_Request As String, Optional ByVal al_RowExpectedCount = -1) As Long
#End If

On Error GoTo ErrHandler

    Dim lc_Data As Long
    lc_Data = ao_DB.OpenSQL(as_Request)
    
    If lc_Data = 0 Then
        Err.Raise ArmErr.SQLFailure, "SQL : " & as_Request, Join(ao_DB.SQLErrorCodes, SEP2) & SEP1 & Join(ao_DB.SQLErrorMessages, SEP2)
    End If
    
    If al_RowExpectedCount <> -1 Then
        ' Then check the rowcount
        If ao_DB.RowCount(lc_Data) <> al_RowExpectedCount Then
            Err.Raise ArmErr.SQLBadRowExpectedCount, "SQL : " & as_Request, al_RowExpectedCount & "<>" & ao_DB.RowCount(lc_Data)
        End If
    End If

    OpenSQLSafe = lc_Data

    Exit Function

ErrHandler:

    Call ErrorHandler("OpenSQLSafe")

End Function


' Execute a SQL request returning no data
' Convert SQL runtime errors and process errors to VB Error
' Params:
' ao_Db (Object)
' as_Request (String)
' al_RowAffectedCount (String)
#If LIVE = 1 Then
Private Sub ExecuteSQLSafe(ByVal ao_DB As Object, ByVal as_Request As String, Optional ByVal al_RowAffectedCount = -1, Optional ab_DuplicityCheck As Boolean = False)
#Else
Private Sub ExecuteSQLSafe(ByVal ao_DB As ARMSYSCOMLib.ArmDb, ByVal as_Request As String, Optional ByVal al_RowAffectedCount = -1, Optional ab_DuplicityCheck As Boolean = False)
#End If
On Error GoTo ErrHandler

    ' First execute the request
    If Not ao_DB.ExecuteSQL(as_Request) Then
        Err.Raise ArmErr.SQLFailure, "SQL : " & as_Request, Join(ao_DB.SQLErrorCodes, SEP2) & SEP1 & Join(ao_DB.SQLErrorMessages, SEP2)
    End If

    If al_RowAffectedCount <> -1 Then
        ' Then check the rowcount
        If ao_DB.SQLRowsAffected <> al_RowAffectedCount Then
            
            If ab_DuplicityCheck Then
                Err.Raise ArmCusErr.DuplicityDetected, "SQL : " & as_Request, al_RowAffectedCount & "<>" & ao_DB.SQLRowsAffected
            Else
                Err.Raise ArmErr.SQLBadRowAffectedCount, "SQL : " & as_Request, al_RowAffectedCount & "<>" & ao_DB.SQLRowsAffected
            End If
        End If
    End If

    Exit Sub

ErrHandler:
    Call ErrorHandler("ExecuteSQLSafe")
End Sub

Private Function BeginTran(as_Tran As String) As Boolean

On Error GoTo ErrHandler
    BeginTran = False
    ExecuteSQLSafe mo_Db, "BEGIN TRANSACTION " & as_Tran

    BeginTran = True
    Exit Function
    
ErrHandler:
    mo_Db.Disconnect
    Set mo_Db = Nothing
    Call LogMessage("A Fatal error occured in " & SCREEN_NAME & ".BeginTran, your application will be close. Please contact your IT support")
    End
End Function

Private Function CommitTran(as_Tran As String) As Boolean

On Error GoTo ErrHandler
    CommitTran = False
    ExecuteSQLSafe mo_Db, "COMMIT TRANSACTION " & as_Tran

    CommitTran = True
    Exit Function
    
ErrHandler:
    mo_Db.Disconnect
    Set mo_Db = Nothing
    Call LogMessage("A Fatal error occured in " & SCREEN_NAME & ".CommitTran, your application will be close. Please contact your IT support")
    End

End Function

Private Function RollbackTran(as_Tran As String) As Boolean
    
    Dim ll_errNumber As Long, ls_ErrSrc As String, ls_errDesc As String
    ll_errNumber = Err.Number
    ls_ErrSrc = Err.Source
    ls_errDesc = Err.Description

On Error GoTo ErrHandler
    RollbackTran = False
    
    ExecuteSQLSafe mo_Db, "ROLLBACK TRANSACTION " & as_Tran


    Err.Number = ll_errNumber
    Err.Source = ls_ErrSrc
    Err.Description = ls_errDesc

    RollbackTran = True
    Exit Function
    
ErrHandler:
    If mo_Db.LastErrorCode <> 3903 Then
        mo_Db.Disconnect
        Set mo_Db = Nothing
        Call LogMessage("A Fatal error occured in " & SCREEN_NAME & ".RollbackTran, your application will be close. Please contact your IT support")
        End
    Else
        Err.Number = ll_errNumber
        Err.Source = ls_ErrSrc
        Err.Description = ls_errDesc
    
        RollbackTran = True
    
    End If
End Function

Private Function GetDbError(ByVal lo_Db As ARMSYSCOMLib.ArmDb) As String
On Error GoTo ErrHandler
    
    If IsArray(lo_Db.SQLErrorMessages) Then
        Debug.Assert (IsArray(mo_Db.SQLErrorCodes))
        ' Display errors msgBox
        GetDbError = Join(lo_Db.SQLErrorCodes, ",") & vbCrLf & Join(lo_Db.SQLErrorMessages, vbCrLf)
    Else
        ' ExecuteSQL failed but no error message?
        GetDbError = "Unknown error"
    End If
    Exit Function
ErrHandler:
    Call ErrorHandler("GetDbError()")
End Function

Public Function SQLStr(ByVal as_str As String, Optional ByVal al_MaxLen As Long = 0, Optional ByVal ab_LogError As Boolean = True) As String
On Error GoTo ErrHandler
    
    If as_str = "NULL" Then
        SQLStr = "NULL"
    Else
        If al_MaxLen > 0 Then
            as_str = Trim(as_str)
            If Len(as_str) > al_MaxLen Then
                If ab_LogError Then
                    Call LogMessage("Value trimmed (" & al_MaxLen & ") '" & as_str & "' to '" & Left(as_str, al_MaxLen) & "'")
                End If
                as_str = Left(as_str, al_MaxLen)
            End If
        End If
        SQLStr = "'" & Replace(as_str, "'", "''") & "'"
    End If
    Exit Function
ErrHandler:
    Call ErrorHandler("SQLStr as_Str=" & as_str)
End Function

Private Function SqlDbl(ByVal av_Data As Variant) As String
On Error GoTo ErrHandler

    SqlDbl = "NULL"
    If IsNull(av_Data) Then av_Data = ""
    If Trim(CStr(av_Data)) <> "" Then
        SqlDbl = Str(av_Data)
    End If
    Exit Function
ErrHandler:
    Call ErrorHandler("SqlDbl")
End Function

Private Function SqlDate(ByVal av_Data As Variant) As String
On Error GoTo ErrHandler

    SqlDate = "NULL"
    If IsNull(av_Data) Then av_Data = ""
    If (Trim(CStr(av_Data)) <> "") And (CStr(av_Data) <> "0") Then
        SqlDate = "'" & Format(av_Data, "yyyy-mm-dd") & "'"
    End If
    Exit Function
ErrHandler:
    Call ErrorHandler("SqlDate")
End Function

' **************************** DB-ACCESS FUNCTIONS ***********************************

' Standard error handler
Private Sub ErrorHandler(ByVal as_Fct As String)
    Err.Raise Err.Number, "MailHelper" & "::" & as_Fct & SEP1 & Err.Source, Err.Description
End Sub

' display standard error message
Private Sub ErrorMessage(ByVal as_Fct As String)
    Dim ls_errSource As String
    Dim ls_ErrDescription As String
    ls_errSource = as_Fct & SEP1 & Err.Source
    ls_ErrDescription = Err.Description
    
    Call LogMessage(SCREEN_NAME & " exception raised. Err.Number:" & Err.Number & ", Err.Source:" & ls_errSource & ", Err.Description " & ls_ErrDescription & ".", "E", False)
    Call MsgBox("Error occured, please contact IT. Application will now shutdown." & vbCrLf & ls_errSource & vbCrLf & "Description: " & ls_ErrDescription, , "Error message: " & as_Fct)
    End
End Sub

' logs message to database
Private Sub LogMessage(ByVal as_logMsg As String, Optional ByVal as_logType As String = "E", Optional ab_ExitOnException As Boolean = False)
    Dim ll_errNumber As Long
    Dim ls_ErrDescription As String, ls_errSource As String
    
    ll_errNumber = Err.Number
    ls_ErrDescription = Err.Description
    ls_errSource = Err.Source

On Error GoTo ErrHandler

Const LOG_REQUEST As String = "EXEC A_log_ins $UCODE$,$LOGTYPE$,$MSG$,$APP$"
    Dim ls_req As String
    Dim ll_cursor As Long
    Dim ls_Source As String, ls_Msg As String
    
    ls_Source = SCREEN_NAME & " " & App.Title & " " & App.Major & "." & App.Minor & "." & App.Revision
    ls_Msg = as_logMsg & SEP1 & ll_errNumber & " : " & ls_ErrDescription & " - " & ls_errSource
    
    ls_req = Replace(LOG_REQUEST, "$UCODE$", CStr(ml_U_code), , , vbTextCompare)
    ls_req = Replace(ls_req, "$LOGTYPE$", SQLStr(as_logType), , , vbTextCompare)
    ls_req = Replace(ls_req, "$MSG$", SQLStr(Left(Trim(ls_Msg), 4000)), , , vbTextCompare)
    ls_req = Replace(ls_req, "$APP$", SQLStr(Left(Trim(ls_Source), 50)), , , vbTextCompare)
    
    Call ExecuteSQLSafe(mo_Db, ls_req)
    
    Err.Number = ll_errNumber
    Err.Description = ls_ErrDescription
    Err.Source = ls_errSource
    Exit Sub
    
ErrHandler:
    If ab_ExitOnException Then
        Call MsgBox("A fatal error occured. Unable to log error into database, the application will be close. Please report the following message to your IT support: " & vbCrLf & _
            "Number:" & Err.Number & vbCrLf & "Description:" & Err.Description)
        End
    End If
    Err.Number = ll_errNumber
    Err.Description = ls_ErrDescription
    Err.Source = ls_errSource
End Sub

' procedure save/restore err object
Private Sub UpdateError(Optional ab_saveError As Boolean = False)
Static ls_errDesc As String
Static ls_errSource As String
Static ll_errnum As Long
    
    If ab_saveError Then
        ls_errDesc = Err.Description
        ls_errSource = Err.Source
        ll_errnum = Err.Number
    Else
        Err.Description = ls_errDesc
        Err.Source = ls_errSource
        Err.Number = ll_errnum
    End If
End Sub

