VERSION 5.00
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.1#0"; "mscomctl.ocx"
Begin VB.UserControl DCCost 
   AutoRedraw      =   -1  'True
   BackColor       =   &H8000000A&
   ClientHeight    =   9300
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   15360
   ScaleHeight     =   9300
   ScaleWidth      =   15360
   Begin MSComctlLib.ImageList il_imgList 
      Left            =   5010
      Top             =   4245
      _ExtentX        =   1005
      _ExtentY        =   1005
      BackColor       =   -2147483643
      MaskColor       =   12632256
      _Version        =   393216
   End
   Begin VB.Frame frame 
      BorderStyle     =   0  'None
      Height          =   2460
      Left            =   -15
      TabIndex        =   4
      Top             =   2460
      Visible         =   0   'False
      Width           =   4755
      Begin VB.PictureBox pic_bin 
         Appearance      =   0  'Flat
         BackColor       =   &H80000005&
         ForeColor       =   &H80000008&
         Height          =   300
         Left            =   105
         MousePointer    =   2  'Cross
         OLEDropMode     =   1  'Manual
         Picture         =   "DCCost.ctx":0000
         ScaleHeight     =   270
         ScaleWidth      =   510
         TabIndex        =   17
         Top             =   2115
         Width           =   540
      End
      Begin MSComctlLib.ListView lv_emails 
         Height          =   660
         Left            =   840
         TabIndex        =   15
         Top             =   1755
         Width           =   2610
         _ExtentX        =   4604
         _ExtentY        =   1164
         Arrange         =   2
         LabelEdit       =   1
         LabelWrap       =   0   'False
         HideSelection   =   -1  'True
         HideColumnHeaders=   -1  'True
         OLEDragMode     =   1
         OLEDropMode     =   1
         FlatScrollBar   =   -1  'True
         _Version        =   393217
         ForeColor       =   -2147483640
         BackColor       =   -2147483643
         BorderStyle     =   1
         Appearance      =   0
         MousePointer    =   1
         OLEDragMode     =   1
         OLEDropMode     =   1
         NumItems        =   0
      End
      Begin VB.TextBox txt_comment 
         Height          =   288
         Left            =   1785
         MaxLength       =   80
         TabIndex        =   14
         Top             =   1410
         Width           =   2805
      End
      Begin VB.PictureBox pic_Quit 
         AutoSize        =   -1  'True
         BackColor       =   &H80000009&
         Height          =   540
         Left            =   4080
         Picture         =   "DCCost.ctx":030A
         ScaleHeight     =   480
         ScaleWidth      =   480
         TabIndex        =   9
         Top             =   1860
         Width           =   540
      End
      Begin VB.PictureBox pic_Valid 
         AutoSize        =   -1  'True
         BackColor       =   &H80000009&
         Height          =   540
         Left            =   3525
         Picture         =   "DCCost.ctx":0614
         ScaleHeight     =   480
         ScaleWidth      =   480
         TabIndex        =   8
         Top             =   1860
         Width           =   540
      End
      Begin VB.TextBox txt_Amount 
         Height          =   288
         Left            =   1800
         MaxLength       =   80
         TabIndex        =   0
         Top             =   600
         Width           =   1635
      End
      Begin Project1.ArmCombobox cbo_currency 
         Height          =   345
         Left            =   1800
         TabIndex        =   10
         Tag             =   "CURR_Code"
         Top             =   1005
         Width           =   2805
         _ExtentX        =   4948
         _ExtentY        =   609
      End
      Begin Project1.ArmCombobox cbo_costType 
         Height          =   345
         Left            =   1800
         TabIndex        =   12
         Tag             =   "DCC_Type"
         Top             =   150
         Width           =   2805
         _ExtentX        =   4948
         _ExtentY        =   609
      End
      Begin VB.Label lbl_emails 
         Caption         =   "#Links"
         Height          =   225
         Left            =   120
         TabIndex        =   16
         Top             =   1845
         Width           =   720
      End
      Begin VB.Label lbl_comment 
         Caption         =   "#Comment"
         Height          =   255
         Left            =   120
         TabIndex        =   13
         Tag             =   "lbl_comment"
         Top             =   1500
         Width           =   1575
      End
      Begin VB.Label lbl_Currency 
         Caption         =   "Currency"
         Height          =   255
         Left            =   120
         TabIndex        =   7
         Tag             =   "lbl_Currency"
         Top             =   1080
         Width           =   1575
      End
      Begin VB.Label lbl_Amount 
         Caption         =   "Amount"
         Height          =   255
         Left            =   120
         TabIndex        =   6
         Tag             =   "lbl_Amount"
         Top             =   600
         Width           =   1575
      End
      Begin VB.Label lbl_CostType 
         Caption         =   "Cost type"
         Height          =   255
         Left            =   120
         TabIndex        =   5
         Tag             =   "lbl_CostType"
         Top             =   120
         Width           =   1575
      End
   End
   Begin VB.PictureBox pic_Del 
      AutoSize        =   -1  'True
      BackColor       =   &H80000009&
      Height          =   540
      Left            =   1020
      Picture         =   "DCCost.ctx":091E
      ScaleHeight     =   480
      ScaleWidth      =   480
      TabIndex        =   3
      Top             =   0
      Width           =   540
   End
   Begin VB.PictureBox pic_Upd 
      AutoSize        =   -1  'True
      BackColor       =   &H80000009&
      Height          =   540
      Left            =   555
      Picture         =   "DCCost.ctx":0C28
      ScaleHeight     =   480
      ScaleWidth      =   480
      TabIndex        =   2
      Top             =   0
      Width           =   540
   End
   Begin VB.PictureBox pic_Add 
      AutoSize        =   -1  'True
      BackColor       =   &H80000009&
      Height          =   540
      Left            =   0
      Picture         =   "DCCost.ctx":0F32
      ScaleHeight     =   480
      ScaleWidth      =   480
      TabIndex        =   1
      Top             =   0
      Width           =   540
   End
   Begin Project1.ArmGrid grd_link 
      Height          =   1875
      Left            =   0
      TabIndex        =   11
      Tag             =   "grd_link"
      Top             =   555
      Width           =   4755
      _ExtentX        =   8387
      _ExtentY        =   3307
   End
End
Attribute VB_Name = "DCCost"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Private Const C_SCREENNAME As String = "DC_Cost"
Private Const SEP = "®©"
Private Const SEP1 As String = "®"
Private Const SEP2 As String = "©"
Const L_NotNTFS = "Sorry, the current volume is not NTFS."

Public Enum LocaleIDs
    en_US = &H409       ' English (United States)
'    fl_FI = &H40B       ' Finnish
    ' [[ Add other Locale ID's here as needed ]] '
End Enum

Private Declare Function GetTempPath Lib "Kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Private Declare Function VarDateFromStr Lib "oleaut32.dll" ( _
    ByVal psDateIn As Long, _
    ByVal LCID As Long, _
    ByVal uwFlags As Long, _
    ByRef dtOut As Date) As Long

Private Const S_OK = 0
Private Const DISP_E_BADVARTYPE = &H80020008
Private Const DISP_E_OVERFLOW = &H8002000A
Private Const DISP_E_TYPEMISMATCH = &H80020005
Private Const E_INVALIDARG = &H80070057
Private Const E_OUTOFMEMORY = &H8007000E

Private ml_U_Code As Long
Private ml_Transcode As Long
Dim dc_userName As String

Dim mi_Conc As Integer

Private ms_Title As String                  ' title of user control - can be assigned as Caption to the parent form or title for printing

#If LIVE = 1 Then
    Private mo_Db As Object
    Private mo_FSO As Object
#Else
    Private mo_Db As ARMSYSCOMLib.ArmDb
    Private mo_FSO As Scripting.FileSystemObject
#End If


Private mb_Initialized As Boolean
Private ms_reconnectServer As String
Private ms_reconnectDB As String
Private ms_reconnectUser As String
Private ms_reconnectPassword As String
Private ms_reconnectApp As String
Private ms_Language_Code As String
Private mb_eventRunning As Boolean
Private ms_Action As String
Private ml_DCPLLI_Code As Long

Private md_TheoreticalCost As Double

Public Event ConnectFailed()
Public Event RowUpdated(ByVal as_action As String, ByVal as_CostType As String, ByVal ad_Value As Double)

Public Sub SetReconnectParams(ByVal as_Server As String, ByVal as_Db As String, ByVal as_User As String, ByVal as_Password As String, ByVal as_App As String)
On Error GoTo errhandler
    ms_reconnectServer = as_Server
    ms_reconnectDB = as_Db
    ms_reconnectUser = as_User
    ms_reconnectPassword = as_Password
    ms_reconnectApp = as_App
    Exit Sub
errhandler:
    Call ErrorMessage("SetReconnectParams")
End Sub

Public Property Set ArmDb(ByRef lo_Db As Object)
On Error GoTo errhandler
  
  Set mo_Db = lo_Db
  Exit Property
errhandler:
  Call ErrorHandler("ArmDb.Set")
End Property

Public Property Let dc_user(ByVal as_dc_user As String)
    dc_userName = as_dc_user
End Property

Public Property Get Lang() As String
    Lang = ms_Language_Code
End Property

Public Property Let Lang(as_Lang As String)
    ms_Language_Code = as_Lang
End Property

Property Let U_Code(ByVal al_U_Code As Long)
On Error GoTo errhandler

  ml_U_Code = al_U_Code
  Exit Property
errhandler:
  Call ErrorMessage("U_Code.Let")
End Property

Public Property Get TransCode() As Long
    TransCode = ml_Transcode
End Property

Public Property Let TransCode(al_TransCode As Long)
    ml_Transcode = al_TransCode
End Property

Public Property Let PartialCost(ByVal ad_partialCost As Double)
    md_TheoreticalCost = ad_partialCost
    Call RecalcPartialCost
End Property

Public Property Get PartialCost() As Double
    PartialCost = md_TheoreticalCost
End Property

Public Property Get ManualCost() As Double
On Error GoTo errhandler
    
    ManualCost = 0
    
    Dim ll_i As Long
    For ll_i = 0 To grd_link.Rows - 1
        If grd_link.Data(ll_i, "DCC_type") = "M" Then
            ManualCost = grd_link.Data(ll_i, "DC_Cost")
            Exit For
        End If
    Next
    
    Exit Function
errhandler:
    Call ErrorHandler("ManualCost")
End Function

Public Property Get SurchargeCost() As Double
On Error GoTo errhandler
    
    SurchargeCost = 0
    
    Dim ll_i As Long
    For ll_i = 0 To grd_link.Rows - 1
        If grd_link.Data(ll_i, "DCC_type") = "S" And grd_link.Data(ll_i, "Action") <> "D" Then
            SurchargeCost = grd_link.Data(ll_i, "DC_Cost")
            Exit For
        End If
    Next
    
    Exit Property
errhandler:
    Call ErrorHandler("SurchargeCost")
End Property

Public Property Get TransportCost() As Double
On Error GoTo errhandler
    
    TransportCost = 0
    
    Dim ld_Cost As Double
    ld_Cost = 0
    
    Dim ll_i As Long
    For ll_i = 0 To grd_link.Rows - 1
        If grd_link.Data(ll_i, "DCC_type") = "T" Or grd_link.Data(ll_i, "DCC_type") = "D" Then
            ld_Cost = ld_Cost + grd_link.Data(ll_i, "DC_Cost")
        End If
    Next
    
    TransportCost = ld_Cost
    
    Exit Property
errhandler:
    Call ErrorHandler("TransportCost")
End Property


Public Property Get Cost_Comment() As String
On Error GoTo errhandler
    
    Cost_Comment = ""
    
    Dim ll_i As Long
    For ll_i = 0 To grd_link.Rows - 1
        If grd_link.Data(ll_i, "Cost_Comment") <> "" Then
            Cost_Comment = grd_link.Data(ll_i, "Cost_Comment")
            Exit For
        End If
    Next
    
    Exit Property
errhandler:
    Call ErrorHandler("Cost_Comment")
End Property

Public Property Let Enabled(ByVal ab_Enabled As Boolean)
    pic_add.Enabled = ab_Enabled
    pic_upd.Enabled = ab_Enabled
    pic_Del.Enabled = ab_Enabled
End Property

Private Sub MouseOn()
'------------------------------------------------------------------
' Name : MouseOn
'
' Purpose : Turn the mouse pointer to arrow
'
' Parameters : Nothing
'
' Return : Nothing
'
' review : Jan/06/2000 by AD
'------------------------------------------------------------------
    DoEvents
    Screen.MousePointer = 0
    DoEvents
End Sub

Private Sub MouseOff()
'------------------------------------------------------------------
' Name : MouseOff
'
' Purpose : Turn the mouse pointer to busy
'
' Parameters : Nothing
'
' Return : Nothing
'
' review : Jan/06/2000 by AD
'------------------------------------------------------------------
    DoEvents
    Screen.MousePointer = 11
    DoEvents
End Sub


' Load the labels of a containers
Private Sub LoadLabels(ByRef aControls As Variant, ByVal as_ScreenName As String, ByVal as_Language As String)

On Error GoTo errhandler

    Dim lIdx As Long, lCount As Long, lLabels As Long
    Dim lControl As Control

    lLabels = OpenSQLSafe(mo_Db, "exec Screen_Csts '" & as_ScreenName & "','" & as_Language & "'")
    Debug.Assert (lLabels <> 0)
    
    lCount = aControls.Count - 1
    
    For lIdx = 0 To lCount
        Set lControl = aControls.Item(lIdx)
            Select Case UCase(TypeName(lControl))
                Case "LABEL", "FRAME", "COMMANDBUTTON", "OPTIONBUTTON", "MENU", "CHECKBOX"
                    If lControl.Tag <> "" Then
                        If mo_Db.Find(lLabels, "FIELD_NAME", lControl.Tag, , 1) >= 0 Then
                            lControl.Caption = mo_Db.GetFields(lLabels, "LOCAL_TEXT")
                        End If
                        ' once translation is done and control is not in array CLEAR tag
                        If Not TypeOf lControl Is Frame And Not TypeOf lControl Is Label Then
                            lControl.Tag = ""
                        End If
                    End If
                Case "ARMGRID"
                    If mo_Db.Find(lLabels, "FIELD_NAME", lControl.Tag, , 1) >= 0 Then
                      Call lControl.LoadConstants(ptStatic, mo_Db.GetFields(lLabels, "LOCAL_TEXT"), ctColumns)
                        End If
                    If mo_Db.Find(lLabels, "FIELD_NAME", lControl.Tag & "_Title", , 1) >= 0 Then
                      lControl.Title = mo_Db.GetFields(lLabels, "LOCAL_TEXT")
                    End If
                Case "TABSTRIP"
                    If mo_Db.Find(lLabels, "FIELD_NAME", lControl.Tag, , 1) >= 0 Then
                        Dim lsa_TextArr() As String
                        Dim ll_Index As Long
                        
                        lsa_TextArr = Split(mo_Db.GetFields(lLabels, "LOCAL_TEXT"), SEP)
                        
                        For ll_Index = LBound(lsa_TextArr, 1) To UBound(lsa_TextArr, 1)
                            lControl.Tabs(ll_Index + 1).Caption = lsa_TextArr(ll_Index)
                        Next
                    End If
                    ' once translation is done and control is not in array CLEAR tag
                    lControl.Tag = ""
                Case "MSFLEXGRID", "TOOLBARCONTROL", "TEXTBOX", "ARMCHECKVIEW", "ARMCOMBOBOX", "A_CALOCX", "OPTIONBUTTON", "ARMTREEVIEW", "LISTBOX", "PICTUREBOX", "TOOLBR", "SPINBUTTON"
                    ' Do nothing !
                Case Else
                    'debug.print "LoadLabels " & UCase(TypeName(lControl))
            End Select
        Set lControl = Nothing
    Next
    
    ' SPECIAL INITIALIZATION
    ' Title
    If mo_Db.Find(lLabels, "FIELD_NAME", "title", , 1) >= 0 Then
        ms_Title = mo_Db.GetFields(lLabels, "LOCAL_TEXT")
    End If

    Call mo_Db.Close(lLabels)
    lLabels = 0

    Exit Sub

errhandler:
    If lLabels > 0 Then
        Call mo_Db.Close(lLabels)
    End If
    Call ErrorHandler(Extender.Name & ".LoadLabels")
End Sub



Public Function GridSave() As Byte
On Error GoTo err_GridSave
    
    GridSave = 1
    Dim ll_i As Long
    
    ' first delete
    For ll_i = 0 To grd_link.Rows - 1
        Call Item_UpdateValueDB(ll_i, "D")
    Next
    
    ' then add/udate
    For ll_i = 0 To grd_link.Rows - 1
        Call Item_UpdateValueDB(ll_i, "AU")
    Next

Exit Function
err_GridSave:
    Call ErrorMessage("GridSave")
End Function

Public Function GridDelete()

    Dim ll_i As Long
    For ll_i = 0 To grd_link.Rows - 1
        grd_link.Data(ll_i, "Action") = "D"
    Next
    Call GridSave
    
End Function

Private Sub Maintenance_Init(ByVal as_ActionType As String)
Dim ll_Cursor  As Long
On Error GoTo errhandler

    ms_Action = as_ActionType
    cbo_costType.Enabled = False
    
    If as_ActionType = "Update" Or as_ActionType = "Add" Then
        txt_Amount.Enabled = True
        cbo_currency.Enabled = True
    Else
        txt_Amount.Enabled = False
        cbo_currency.Enabled = False
    End If
    
'    lv_emails.Enabled = (as_ActionType = "Update")                      ' linked data available only for Update!!!!
    

    If as_ActionType = "Update" Or as_ActionType = "Delete" Then
        txt_Amount = grd_link.SelectedLine(0, "DC_Cost")
        txt_Comment.Text = grd_link.SelectedLine(0, "Cost_Comment")
        Call SetComboItemValue(cbo_currency, grd_link.SelectedLine(0, "CURR_code"))
        Call SetComboItemValue(cbo_costType, grd_link.SelectedLine(0, "DCC_type"))
        
        If EML_MasterExists Then
            Call RefreshLinkedEmails
        Else
            Call RefreshLinkedEmailsCache
        End If

    ElseIf as_ActionType = "Add" Then
        
        If mo_FSO.FolderExists(prg.AppCache_Dir & "\DCCost\") Then
            Dim lo_File As File
            Dim lo_folder As Folder
            Set lo_folder = mo_FSO.GetFolder(prg.AppCache_Dir & "\DCCost\")
            For Each lo_File In lo_folder.Files
                Call lo_File.Delete(True)
            Next
        End If
        
'        Call EML_CacheFileInfo(prg.AppCache_Dir & "\DCCost\0000000000000040.JPG", "M", 22, "jubject", "julo", "joloss", "Julo", 1, Now())
        
        Call RefreshLinkedEmailsCache
        
        
        txt_Amount.Text = ""
        txt_Comment.Text = ""
        Call SetComboItemValue(cbo_costType, "M")
        
        ' look for user market currency
        ll_Cursor = OpenSQLSafe(mo_Db, "EXEC currencies_sel1 '" & dc_userName & "','" & ms_Language_Code & "'")
            Call SetComboItemValue(cbo_currency, mo_Db.GetFields(ll_Cursor, "curr_code"))
        Call mo_Db.Close(ll_Cursor)
        ll_Cursor = 0
        
        txt_Amount.SetFocus
    End If
    Exit Sub
errhandler:
    Call ErrorHandler("Maintenance_Init")
End Sub

Private Sub RefreshLinkedEmails()
On Error GoTo errhandler
Const C_REQ As String = "DC_Cost_LinkedEmail_lst $TRANS_Code$, $DCC_type$"
    
    Dim ll_Cursor As Long
    Dim ls_req As String
    Dim lo_ListItem As ListItem
    
    ls_req = Replace(C_REQ, "$TRANS_Code$", SQLNum(ml_Transcode), , , vbTextCompare)
    ls_req = Replace(ls_req, "$DCC_type$", SqlStr("M", 1), , , vbTextCompare)
    
    ll_Cursor = OpenSQLSafe(mo_Db, ls_req)
    
    lv_emails.ListItems.Clear
    
    While Not mo_Db.EOF(ll_Cursor)
        
        Set lo_ListItem = lv_emails.ListItems.Add(, "_" & CStr(mo_Db.GetFields(ll_Cursor, "DC_EML_ID")), mo_Db.GetFields(ll_Cursor, "EML_Subject"), 1, 1)
        
        lo_ListItem.ToolTipText = mo_Db.GetFields(ll_Cursor, "EML_SenderName")
        lo_ListItem.Tag = mo_Db.GetFields(ll_Cursor, "iConcurrency")
        
        Call mo_Db.Next(ll_Cursor)
    Wend
    
    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("RefreshLinkedEmails")
End Sub

Private Sub RefreshLinkedEmailsCache()
On Error GoTo errhandler
    
    Dim lo_ListItem As ListItem
    
    Dim lo_folder As Folder
    If mo_FSO.FolderExists(prg.AppCache_Dir & "\DCCost\") Then
        Set lo_folder = mo_FSO.GetFolder(prg.AppCache_Dir & "\DCCost\")
    Else
        Set lo_folder = mo_FSO.CreateFolder(prg.AppCache_Dir & "\DCCost\")
    End If
    
    lv_emails.ListItems.Clear
    
    Dim lo_File As File
    
    Dim ls_DC_EML_ID As String
    Dim ls_EML_Subject As String
    Dim ls_EML_SenderName As String
    
    For Each lo_File In lo_folder.Files
    
        Call ReadFileStream(lo_File.Path, "DC_EML_ID", ls_DC_EML_ID, lo_File.Name)
        Call ReadFileStream(lo_File.Path, "EML_Subject", ls_EML_Subject, lo_File.Name)
        Call ReadFileStream(lo_File.Path, "EML_SenderName", ls_EML_SenderName)
        
        Set lo_ListItem = lv_emails.ListItems.Add(, "_" & ls_DC_EML_ID, ls_EML_Subject, 1, 1)
        
        lo_ListItem.ToolTipText = ls_EML_SenderName
        lo_ListItem.Tag = lo_File.Path
        
    Next
    
    Exit Sub
errhandler:
    Call ErrorHandler("RefreshLinkedEmailsCache")
End Sub

Public Function Grid_Init() As Boolean

    Grid_Init = False

    Frame.Visible = False
    
    GridFill
    
    Grid_Init = True

End Function

Private Sub Permission()
Dim ls_req As String
Dim ll_Cursor As Long

On Error GoTo Err_Permission

    pic_add.Visible = False
    pic_upd.Visible = False
    pic_Del.Visible = False
    
    ls_req = "EXEC Check_Security 'DC_Cost', '" & dc_userName & "'"
    ll_Cursor = OpenSQLSafe(mo_Db, ls_req)
    
    While Not mo_Db.EOF(ll_Cursor)
        Select Case UCase(mo_Db.GetFields(ll_Cursor, "Action"))
            Case "INSERT"
                pic_add.Visible = True
            Case "UPDATE"
                pic_upd.Visible = True
            Case "DELETE"
                pic_Del.Visible = True
        End Select
        Call mo_Db.Next(ll_Cursor)
    Wend
    
    Call mo_Db.Close(ll_Cursor)
    ll_Cursor = 0

Exit Sub

Err_Permission:
    If ll_Cursor > 0 Then
        Call mo_Db.Close(ll_Cursor)
        ll_Cursor = 0
    End If
    
    Call ErrorHandler("Permission")
End Sub

Private Sub GridFill()

On Error GoTo Err_GridFill
    
    Call grd_link.ClearGrid
    Call LoadGrid(grd_link, "EXEC DC_Cost_t_lst " & ml_Transcode & ", '" & ms_Language_Code & "'", "Grid not loaded (DC_Cost_t_lst)!")

Exit Sub

Err_GridFill:
    Call ErrorHandler("GridFill")
End Sub

Private Sub grd_link_RowLoaded(ByVal al_Row As Long)
On Error GoTo errhandler
    
    ' calculate theoretical cost
    
    If grd_link.Data(al_Row, "DCC_Type") <> "M" Then
        grd_link.Data(al_Row, "TheoreticalCost") = md_TheoreticalCost
    Else
        grd_link.Data(al_Row, "TheoreticalCost") = grd_link.Data(al_Row, "DC_Cost")
    End If
    
    Exit Sub
errhandler:
    Call ErrorHandler("grd_link_RowLoaded")
End Sub


Private Sub lv_emails_DblClick()

On Error GoTo errhandler
    If lv_emails.SelectedItem Is Nothing Then Exit Sub
    
    CapMouseOff
    ' Open selected message in outlook application
    
    Call ShowMsg(Val(right(lv_emails.SelectedItem.Key, Len(lv_emails.SelectedItem.Key) - 1)))
    CapMouseOn
    Exit Sub
    
errhandler:
    Call ErrorMessage("grd_linkedEmails_ItemSelected")
    CapMouseOn

End Sub

Private Function EML_MasterExists() As Boolean
On Error GoTo errhandler
    EML_MasterExists = False
    
    If ml_Transcode = 0 Then Exit Function
    
    If ms_Action = "Add" Then Exit Function

    EML_MasterExists = True
    Exit Function
errhandler:
    Call ErrorHandler("EML_MasterExists")
End Function

Private Sub lv_emails_OLEDragDrop(Data As MSComctlLib.DataObject, Effect As Long, Button As Integer, Shift As Integer, x As Single, y As Single)

    If Effect = 3 Then Exit Sub                  ' VbDropEffectCopy and VbDropEffectMove
    
'    If ml_Transcode = 0 Then
'        MsgBox ("Document link is possible only for update!!")
'        Exit Sub
'    End If

    Dim mo_OtlSel As Object
    Dim mo_OtlExp As Object
    Dim mo_OtlApp As Object
    Dim ll_Idx As Long

On Error GoTo errhandler
 
    Dim ll_DC_EML_ID As Long
    Dim ll_DC_EML_ZIP_ID As Long
    Dim ls_req As String
    Dim ls_eml_file As String
    Dim ls_Subject As String
    Dim ls_To As String
    Dim ls_SenderEmail As String
    Dim ls_SenderName As String
    Dim ld_creationTime As Date
    Dim ls_cacheFilePath As String
    
    Dim ll_Attachements As Long
    
    If Data.GetFormat(vbCFFiles) Then
        CapMouseOff
        
        Dim ll_i As Long
        Dim lsa_str() As String
        For ll_i = 1 To Data.Files.Count
            ls_cacheFilePath = ""
            ls_Subject = ""
            ls_SenderName = ""
            ls_SenderEmail = ""
            ls_To = ""
            
            lsa_str = Split(Data.Files.Item(ll_i), ".")
            If Len(lsa_str(UBound(lsa_str))) > 3 Then lsa_str(UBound(lsa_str)) = Left(lsa_str(UBound(lsa_str)), 3)
            
            If EML_MasterExists Then
                ll_DC_EML_ZIP_ID = EML_InsertFile(Data.Files.Item(ll_i), UCase(lsa_str(UBound(lsa_str))))
            Else
                ll_DC_EML_ZIP_ID = EML_CacheFile(Data.Files.Item(ll_i), UCase(lsa_str(UBound(lsa_str))), ls_cacheFilePath)
            End If
            
            Select Case UCase(right(Data.Files.Item(ll_i), 4))
            Case ".EML"
                Call EML_GetInfo(Data.Files.Item(ll_i), ls_Subject, ls_SenderName, ls_SenderEmail, ls_To, ld_creationTime)
            Case Else
                ls_Subject = mo_FSO.GetBaseName(Data.Files.Item(ll_i))
                ls_SenderEmail = ml_U_Code
                ls_SenderName = dc_userName
                ls_To = mo_FSO.GetExtensionName(Data.Files.Item(ll_i))
                
                ld_creationTime = Now
            End Select
            
            If EML_MasterExists Then
                ll_DC_EML_ID = EML_InsertInfo(ml_Transcode, "M", ll_DC_EML_ZIP_ID, ls_Subject, ls_SenderEmail, ls_To, ls_SenderName, 1, ld_creationTime)
            Else
                ll_DC_EML_ID = EML_CacheFileInfo(ls_cacheFilePath, "M", ll_DC_EML_ZIP_ID, ls_Subject, ls_SenderEmail, ls_To, ls_SenderName, 1, ld_creationTime)
            End If
        Next
        
        CapMouseOn
    
    ElseIf Data.GetFormat(vbCFText) Then
    
        ' it is not 100% that we have dropped an outolook message
        Set mo_OtlApp = CreateObject("Outlook.Application")
        If mo_OtlApp Is Nothing Then
            Call MsgBox("Outlook application not found!!", vbCritical)
            Exit Sub
        End If
        
        Set mo_OtlExp = mo_OtlApp.ActiveExplorer
        If mo_OtlExp Is Nothing Then
            Call MsgBox("Outlook ActiveExplorer not found!!", vbCritical)
            Set mo_OtlApp = Nothing
            Exit Sub
        End If
        
        Set mo_OtlSel = mo_OtlExp.selection
        If mo_OtlExp Is Nothing Then
            Call MsgBox("Outlook selection not found!!", vbCritical)
            Set mo_OtlExp = Nothing
            Set mo_OtlApp = Nothing
            Exit Sub
        End If
        
        CapMouseOff
        
        For ll_Idx = 1 To mo_OtlSel.Count
            ls_cacheFilePath = ""
    '        Call MsgBox("Email detected: " & mo_OtlSel.Item(ll_Idx).Subject)
            ' getnext ID for the file
            
            ' get info before save
            ls_Subject = mo_OtlSel.Item(ll_Idx).Subject
            ls_To = mo_OtlSel.Item(ll_Idx).To
            ll_Attachements = mo_OtlSel.Item(ll_Idx).Attachments.Count
            ls_SenderEmail = mo_OtlSel.Item(ll_Idx).SenderEmailAddress
            ls_SenderName = mo_OtlSel.Item(ll_Idx).SenderName
            ld_creationTime = mo_OtlSel.Item(ll_Idx).CreationTime
            
            'Save the file
            ls_eml_file = App.Path & "\download\DC_Email_" & ll_DC_EML_ZIP_ID & ".eml"
            Call mo_OtlSel.Item(ll_Idx).SaveAs(ls_eml_file, 3)      'olMSG
            
            'Insert the file
            If EML_MasterExists Then
                ll_DC_EML_ZIP_ID = EML_InsertFile(ls_eml_file, "MSG")
                ' insert record
                ll_DC_EML_ID = EML_InsertInfo(ml_Transcode, "M", ll_DC_EML_ZIP_ID, ls_Subject, ls_SenderEmail, ls_To, ls_SenderName, ll_Attachements, ld_creationTime)
            Else
                ll_DC_EML_ZIP_ID = EML_CacheFile(ls_eml_file, "MSG", ls_cacheFilePath)
                ' insert record
                ll_DC_EML_ID = EML_CacheFileInfo(ls_cacheFilePath, "M", ll_DC_EML_ZIP_ID, ls_Subject, ls_SenderEmail, ls_To, ls_SenderName, 1, ld_creationTime)
            End If
            
        Next
        
        Set mo_OtlExp = Nothing
        Set mo_OtlApp = Nothing
    
        CapMouseOn
    Else
        MsgBox ("unsupported format")
    End If
    
    If EML_MasterExists Then
        Call RefreshLinkedEmails
    Else
        Call RefreshLinkedEmailsCache
    End If
    
    Exit Sub
    
errhandler:
    If Err.Number = 429 Then
        Resume Next
    End If
    CapMouseOn
    Call ErrorMessage("lv_emails_OLEDragDrop")
End Sub


Private Sub pic_add_Click()
On Error GoTo errhandler
    
    If ManualCostExists Then
        MsgBox "Manual cost already exists. Pleasee update existing line."
        Exit Sub
    End If
    
    Frame.Visible = True
    ml_DCPLLI_Code = 0
    Call Maintenance_Init("Add")
    
    Exit Sub
errhandler:
    Call ErrorMessage("pic_add_Click")
End Sub

Private Sub pic_bin_OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, x As Single, y As Single)
On Error GoTo errhandler
    
Const C_REQ As String = "DC_Cost_LinkedEmail_del $DC_EML_ID$, $Z_Creator$, $iConcurrency$"
    
    If Data.GetFormat(vbCFText) Then
        
        Dim lo_item As ListItem
        Set lo_item = lv_emails.FindItem(Data.GetData(vbCFText))
        
        If Not lo_item Is Nothing Then
            If MsgBox("Do you want to remove the link? (" & lo_item.Text & ")", vbYesNo) = vbYes Then
                ' remove the link
                
                If EML_MasterExists Then
                
                    Dim ls_req As String
                    ls_req = Replace(C_REQ, "$DC_EML_ID$", SQLNum(right(lo_item.Key, Len(lo_item.Key) - 1)), , , vbTextCompare)
                    ls_req = Replace(ls_req, "$iConcurrency$", SQLNum(lo_item.Tag), , , vbTextCompare)
                    ls_req = Replace(ls_req, "$Z_Creator$", SQLNum(ml_U_Code), , , vbTextCompare)
                
                    Call ExecuteSQLSafe(mo_Db, ls_req)
                
                    Call RefreshLinkedEmails
                Else
                    If mo_FSO.FileExists(lo_item.Tag) Then
                        Call MsgBox("Key exists = " & lo_item.Key & ", tag=" & lo_item.Tag)
                        Call mo_FSO.DeleteFile(lo_item.Tag)
                    Else
                        Call MsgBox("Key not exists = " & lo_item.Key & ", tag=" & lo_item.Tag)
                    End If
                    Call RefreshLinkedEmailsCache
                End If
                
            End If
            MsgBox ("Dropped item:" & lo_item.Key)
        End If
        
    End If
    
    Exit Sub
errhandler:
    Call ErrorMessage("pic_bin_OLEDragDrop")
End Sub

Private Sub pic_Del_Click()
On Error GoTo errhandler

    If grd_link.SelectedCount = 0 Then
        MsgBox "Please, first select a record."
        Exit Sub
    Else
        Frame.Visible = True
        Call Maintenance_Init("Delete")
    End If

    Exit Sub
errhandler:
    Call ErrorMessage("pic_Del_Click")
End Sub

Private Sub pic_quit_Click()
On Error GoTo errhandler

    Frame.Visible = False

    Exit Sub
errhandler:
    Call ErrorMessage("pic_quit_Click")
End Sub

Private Sub pic_upd_Click()
On Error GoTo errhandler

    If grd_link.SelectedCount = 0 Then
        MsgBox "Please, first select a record."
        Exit Sub
    ElseIf grd_link.SelectedKey(0)(0) <> "M" Then
        MsgBox "Only Manual cost can be updated," & vbCrLf & " Please, first select a record with manual cost."
        Exit Sub
    Else
        Frame.Visible = True
        Maintenance_Init ("Update")
    End If

    Exit Sub
errhandler:
    Call ErrorMessage("pic_upd_Click")
End Sub

Private Sub pic_Valid_Click()
On Error GoTo errhandler
    MouseOff
    If Control = True Then
        If ms_Action = "Delete" And lv_emails.ListItems.Count > 0 Then
            
            If MsgBox("Are you sure to remove the Cost including the links?", vbYesNo) = vbNo Then
                Exit Sub
            End If
        
        End If
    
        Call UpdateGridAfterAction(grd_link, ms_Action, Array(GetCboKey(cbo_costType)))
    
        RaiseEvent RowUpdated(ms_Action, GetCboKey(cbo_costType), Val(txt_Amount.Text))
    
        Frame.Visible = False
    End If
    MouseOn
    Exit Sub
errhandler:
    MouseOn
    Call ErrorMessage("pic_Valid_Click")
End Sub

Private Function ManualCostExists() As Boolean
On Error GoTo errhandler
    
    ManualCostExists = False
    
    Dim ll_i As Long
    For ll_i = 0 To grd_link.Rows - 1
        If grd_link.Data(ll_i, "DCC_type") = "M" Then
            ManualCostExists = True
            Exit For
        End If
    Next
    
    Exit Function
errhandler:
    Call ErrorHandler("ManualCostExists")
End Function

Private Function Control() As Boolean
On Error GoTo errhandler
    Control = False
    
    If cbo_costType.SelectedItem Is Nothing Then
        MsgBox "No cost type is selected, select one before validation."
        cbo_costType.SetFocus
        Exit Function
    End If

    If cbo_currency.SelectedItem Is Nothing Then
        MsgBox "No currency is selected, select one before validation."
        cbo_currency.SetFocus
        Exit Function
    End If
    
    If txt_Amount.Enabled And txt_Amount.Visible Then
        If Not CheckNumericValue(txt_Amount.Text) Then
            txt_Amount.SetFocus
            MsgBox "Only numeric field is valid "
            Control = KO
            Exit Function
        End If
    End If

    If txt_Amount.Enabled And txt_Amount.Visible Then
        If Val(txt_Amount.Text) > 555555 Then
            txt_Amount.SetFocus
            MsgBox "Amount too big"
            Control = KO
            Exit Function
        End If
    End If
    Control = True
    Exit Function
errhandler:
    Call ErrorHandler("Control")
End Function

Private Function CheckNumericValue(ls_Text As String) As Boolean
On Error GoTo errhandler
Dim i As Integer
Dim ls_char As String
Dim lb_First As Boolean

CheckNumericValue = False
lb_First = False

For i = 1 To Len(ls_Text)
    ls_char = Mid(ls_Text, i, 1)
    If Not isNumeric(ls_char) Then
        If ls_char = "." Then
            If lb_First Then
                Exit Function
            Else
                lb_First = True
            End If
        ElseIf ls_char = "-" Then
            If i > 1 Then
                Exit Function
            End If
        Else
            Exit Function
        End If
    End If
Next i
CheckNumericValue = True

    Exit Function
errhandler:
    Call ErrorHandler("CheckNumericValue")
End Function



' display standard error message
Private Sub ErrorMessage(ByVal as_Fct As String)
    Dim ls_ErrSource As String
    Dim ls_errDescription As String
    Dim ls_Message As String
    
    ls_ErrSource = as_Fct & SEP1 & Err.Source
    ls_errDescription = Err.Description
    ls_Message = C_SCREENNAME & " exception. Nr:" & Err.Number & ",Desc: " & ls_errDescription & ",Src:" & ls_ErrSource & "@"
    Call LogMessage(mo_Db, ml_U_Code, C_SCREENNAME, ls_Message, "E")
    Call MsgBox("Error occured, please contact IT. Application will now shutdown." & vbCrLf & ls_ErrSource & vbCrLf & "Description: " & ls_errDescription, vbCritical, App.Title & " " & App.Major & "." & App.Minor & "." & App.Revision)
'    End
End Sub

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

' logs message to database
#If LIVE = 1 Then
    Public Sub LogMessage(ByVal ao_Db As Object, ByVal al_U_Code As Long, ByVal as_ScreenName As String, ByVal as_LogMsg As String, Optional ByVal as_LogType As String = "E", Optional ByVal ab_ExitOnException As Boolean = True)
#Else
    Public Sub LogMessage(ByVal ao_Db As ARMSYSCOMLib.ArmDb, ByVal al_U_Code As Long, ByVal as_ScreenName As String, ByVal as_LogMsg As String, Optional ByVal as_LogType As String = "E", Optional ByVal ab_ExitOnException As Boolean = True)
#End If
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 = as_ScreenName & " " & App.Title & " " & App.Major & "." & App.Minor & "." & App.Revision
  
  ls_req = Replace(LOG_REQUEST, "$UCODE$", SQLNum(al_U_Code), , , vbTextCompare)
  ls_req = Replace(ls_req, "$LOGTYPE$", SqlStr(as_LogType), , , vbTextCompare)
  ls_req = Replace(ls_req, "$MSG$", SqlStr(Trim(as_LogMsg), 4000), , , vbTextCompare)
  ls_req = Replace(ls_req, "$APP$", SqlStr(Trim(ls_Source), 50), , , vbTextCompare)
  
  Call ExecuteSQLSafe(ao_Db, ls_req)
  Exit Sub
errhandler:
  If ab_ExitOnException Then
    Call MsgBox("A fatal error occured. Unable to log error into database, the application will be closed. Please report the following message to your IT support: " & vbCrLf & _
      as_LogMsg & " - " & ls_Source & "LogMessage exception " & Err.Number & "-" & Err.Description, vbCritical, App.Title & " " & App.Major & "." & App.Minor & "." & App.Revision)
    End
  Else
    Call ao_Db.Disconnect
  End If
End Sub


Private Function GetDbError(ByVal lo_Db As ARMSYSCOMLib.ArmDb) As String
On Error GoTo errhandler
    If IsArray(lo_Db.SQLErrorMessages) Then
        Debug.Assert (IsArray(lo_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(Extender.Name & ".GetDbError()")
End Function

Public Sub Load_A_COM()
    
On Error GoTo errhandler

    If mb_Initialized Then Exit Sub
    
    mb_Initialized = True
    
    mb_eventRunning = True
    
    Dim lo_Control As Object
    
      For Each lo_Control In Controls
        Select Case UCase(TypeName(lo_Control))
        Case "ARMCOMBOBOX"
          Set lo_Control.ArmDb = mo_Db
          Call lo_Control.Load_A_COM
        Case "ARMPICKER"
          Set lo_Control.ArmDb = mo_Db
          Call lo_Control.Load_A_COM
        Case "TOOLBARCONTROL"
          lo_Control.Language = ms_Language_Code
'          Set lo_Control.ArmDb = mo_Db
          Call lo_Control.Load_A_COM
        Case "ARMGRID"
          Set lo_Control.ArmDb = mo_Db
          Call lo_Control.Load_A_COM
        Case "ARMTREEVIEW"
          Set lo_Control.ArmDb = mo_Db
          lo_Control.Language = ms_Language_Code
          Call lo_Control.Load_A_COM
        Case "ARMCHECKVIEW"
          Set lo_Control.ArmDb = mo_Db
          Call lo_Control.Load_A_COM
        Case "A_CALOCX"
          lo_Control.Language = ms_Language_Code
          Call lo_Control.reinit_cal
        Case "TOOLBR"
          Set lo_Control.ArmDb = mo_Db
          Call lo_Control.Load_A_COM
        End Select
    Next
    
    Set mo_FSO = CreateObject("Scripting.FileSystemObject")
    If mo_FSO Is Nothing Then
        MsgBox ("Failedto create Scripting.FileSystemObject")
    End If
    
    Call il_imgList.ListImages.Add(, "file", LoadResPicture(RES_DOCUMENT, 0))
    Set lv_emails.Icons = il_imgList
    Set lv_emails.SmallIcons = il_imgList
    
    md_TheoreticalCost = 0
    
    cbo_currency.FirstBlankItem = False
    cbo_currency.Request = "EXEC DC_currencies_cbo '" & ms_Language_Code & "'"
    
    cbo_costType.FirstBlankItem = False
    cbo_costType.Request = "EXEC DC_CostType_cbo '" & ms_Language_Code & "'"
    
    Call Permission
    
    grd_link.AllowExcelExport = True
    grd_link.Title = "#Transport cost"
    grd_link.MultiSelect = False
    
    'Join(Array("MasterDetail", 250, 0, "MasterDetail", "", "BITMAP"), SEP)
    
    If Not grd_link.SetColumns(Array( _
                Join(Array("DCC_type", 0, 1, "DCC_type", "#Cost type code", "String"), SEP) _
                , Join(Array("DCC_Desc", 1300, 0, "DCC_Desc", "#Cost type", "String"), SEP) _
                , Join(Array("DCPLLI_Code", 0, 0, "DCPLLI_Code", "#Price list line"), SEP) _
                , Join(Array("DC_Cost", 800, 0, "DC_Cost", "#Price", "Float", MONEY_FORMAT_PRECISE, "Left"), SEP) _
                , Join(Array("CURR_code", 0, 0, "CURR_code", "CURR_code", "String"), SEP) _
                , Join(Array("CURR_Desc", 500, 0, "CURR_Desc", "#CURR_Desc", "String"), SEP) _
                , Join(Array("TheoreticalCost", 800, 0, "TheoreticalCost", "#TheoreticalCost", "Float", MONEY_FORMAT_PRECISE, "Left"), SEP) _
                , Join(Array("Cost_Comment", 1500, 0, "Cost_Comment", "Cost_Comment", "String"), SEP) _
                , Join(Array("LinkedEmailIcon", 250, 0, "LinkedEmailIcon", "", "BITMAP"), SEP) _
                , Join(Array("iConcurrency", 0, 0, "iConcurrency", "iConcurrency", "INT"), SEP) _
                , Join(Array("Action", 0, 0, "", "Action", "String"), SEP) _
                )) Then
        MsgBox ("Grid not initialized!")
    End If

    Call LoadLabels(UserControl.Controls, C_SCREENNAME, ms_Language_Code)
    Call ChangeCharset(UserControl.Controls, GetCodePageFromLanguage(mo_Db, ms_Language_Code))
    
    Exit Sub
    
errhandler:
    
    Call ErrorHandler("Load_A_COM")
    
End Sub

Public Sub Unload_A_COM()
    
On Error GoTo errhandler
    mb_Initialized = False
    
    Dim lo_Control As Object

    For Each lo_Control In Controls
      Select Case UCase(TypeName(lo_Control))
      Case "ARMCOMBOBOX"
        Call lo_Control.Unload_A_COM
      Case "ARMPICKER"
        Call lo_Control.Unload_A_COM
      Case "TOOLBARCONTROL"
        Call lo_Control.Unload_A_COM
      Case "ARMGRID"
        Call lo_Control.Unload_A_COM
      Case "ARMTREEVIEW"
        Call lo_Control.Unload_A_COM
      Case "ARMCHECKVIEW"
        Call lo_Control.Unload_A_COM
      Case "TOOLBR"
        Call lo_Control.Unload_A_COM
      End Select
    Next
    
    Set mo_FSO = Nothing
    
    Exit Sub
    
errhandler:
    
    Call ErrorHandler("UnLoad_A_Com")
    
End Sub

Private Sub LoadGrid(ByRef ao_grd As ArmGrid, ByVal as_req As String, ByVal as_Message As String)
On Error GoTo errhandler

TyAgain:
    If Not ao_grd.Load(as_req, True) Then
    
        If ReconnectSafe Then
            GoTo TyAgain
        End If
        
        Call MsgBox(as_Message)
    End If

    Exit Sub
errhandler:
     Call ErrorHandler("LoadGrid()")
End Sub

Private Function ReconnectSafe() As Boolean
On Error GoTo errhandler

    ReconnectSafe = False
    
    Dim ll_Counter As Long
    ll_Counter = 3              ' try 3 times to connect
    
    If IsLostConnection(mo_Db) Then
    
        Call mo_Db.Disconnect
        
        Do While ll_Counter > 0
        
            If mo_Db.Connect(ms_reconnectServer, ms_reconnectDB, ms_reconnectUser, ms_reconnectPassword, ms_reconnectApp) Then
                ReconnectSafe = True
                Exit Do
            End If
            
            ll_Counter = ll_Counter - 1
        Loop
        
        If ll_Counter = 0 And Not mo_Db.IsConnected Then
            RaiseEvent ConnectFailed
        End If
        
    End If
    
    Exit Function
errhandler:
     Call ErrorHandler("ReconnectSafe()")
End Function

Private Function IsLostConnection(ByRef ao_Armdb As ArmDb) As Boolean
On Error GoTo errhandler
    
    IsLostConnection = Not ao_Armdb.IsConnected
    
    If IsArray(ao_Armdb.SQLErrorCodes) Then
        Dim lv_ErrCode As Variant
        Dim ll_Index As Long
        
        lv_ErrCode = ao_Armdb.SQLErrorCodes
        
        For ll_Index = LBound(lv_ErrCode) To UBound(lv_ErrCode)
            If lv_ErrCode(ll_Index) = 11 Then       '[DBNETLIB][ConnectionWrite (send()).]General network error. Check your network documentation.
                IsLostConnection = True
                Exit For
            End If
        Next

    End If
    
    Exit Function
errhandler:
     Call ErrorHandler("IsLostConnection()")
End Function


Private Function OpenSQLSafe(ByVal ao_Db As ARMSYSCOMLib.ArmDb, ByVal as_Request As String, Optional ByVal al_RowExpectedCount = -1) As Long
On Error GoTo errhandler
    Dim lc_Data As Long
tryAgain:
    lc_Data = ao_Db.OpenSQL(as_Request)
    If lc_Data = 0 Then
        
        Dim ls_ErrMsg As String
        ls_ErrMsg = "SQL Error: " & GetDbError(ao_Db)
        
        If ReconnectSafe() Then
            GoTo tryAgain
        End If
        
        Call Err.Raise(1, "ao_Db.OpenSQL - " & "SQL : " & as_Request, ls_ErrMsg)
    End If
    
    If al_RowExpectedCount <> -1 Then
        ' Then check the rowcount
        If ao_Db.RowCount(lc_Data) <> al_RowExpectedCount Then
            Call Err.Raise(2, "SQL : " & as_Request, al_RowExpectedCount & "<>" & ao_Db.RowCount(lc_Data))
        End If
    End If
    OpenSQLSafe = lc_Data
    Exit Function
errhandler:
    Call ErrorHandler(Extender.Name & ".OpenSQLSafe")
End Function

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)
On Error GoTo errhandler

tryAgain:
    ' First execute the request
    If Not ao_Db.ExecuteSQL(as_Request) Then
        If GetArrayValue(ao_Db.SQLErrorCodes, 0) = 547 Then
            Err.Raise 3, "SQL : " & as_Request, Join(ao_Db.SQLErrorCodes, SEP2) & SEP1 & Join(ao_Db.SQLErrorMessages, SEP2)
        End If
        
        Dim ls_ErrMsg As String
        ls_ErrMsg = Join(ao_Db.SQLErrorCodes, SEP2) & SEP1 & Join(ao_Db.SQLErrorMessages, SEP2)
        
        If ReconnectSafe() Then
            GoTo tryAgain
        End If
        
        Err.Raise 1, "SQL : " & as_Request, ls_ErrMsg
    End If

    If al_RowAffectedCount <> -1 Then
        ' Then check the rowcount
        If ao_Db.SQLRowsAffected <> al_RowAffectedCount Then
            
            If ab_DuplicityCheck Then
                Err.Raise 4, "SQL : " & as_Request, al_RowAffectedCount & "<>" & ao_Db.SQLRowsAffected
            Else
                Err.Raise 5, "SQL : " & as_Request, al_RowAffectedCount & "<>" & ao_Db.SQLRowsAffected
            End If
        End If
    End If
    
    Exit Sub

errhandler:
    Call ErrorHandler(Extender.Name & ".ExecuteSQLSafe")
End Sub

Private Function SetComboItemValue(ByRef ao_cbo As ArmCombobox, ByVal as_Key As String) As Boolean
On Error GoTo ErrorHandler
    SetComboItemValue = True
    If Not ao_cbo.SearchItem(as_Key) Then
        Call ao_cbo.Load
        SetComboItemValue = ao_cbo.SearchItem(as_Key)
    End If
    Exit Function
ErrorHandler:
    Call ErrorHandler(Extender.Name & ".SetComboItemValue")
End Function

Private Function UpdateGridAfterAction(ByVal ao_grid As ArmGrid, ByVal as_action As String, ByVal av_Key As Variant) As Boolean
On Error GoTo errhandler
    Dim ll_Index As Long
    Dim lo_Column As ArmColumn
    
    UpdateGridAfterAction = False
    
    Select Case as_action
    Case "Add"
        ' insert row at the end of grid
        Debug.Assert (ao_grid.Cols > 0)
        Dim lsa_newRow() As String
        'MS REDIMM
        Call SafeRedimPreserve(lsa_newRow, ao_grid.Cols - 1)
        Dim ll_KeyIndex As Long
        ll_KeyIndex = 0
        
        For ll_Index = 0 To ao_grid.Cols - 1
            Set lo_Column = ao_grid.Columns(ll_Index)
            If lo_Column.Key Then
                Debug.Assert (UBound(av_Key) >= ll_KeyIndex)
                lsa_newRow(ll_Index) = av_Key(ll_KeyIndex)
                ll_KeyIndex = ll_KeyIndex + 1
            ElseIf lo_Column.Name = "Action" Then
                lsa_newRow(ll_Index) = "A"
            ElseIf lo_Column.Name = "iConcurrency" Then
                lsa_newRow(ll_Index) = 0
            Else
                lsa_newRow(ll_Index) = GetDataSrcForGrid(lo_Column)
            End If
        Next
        Call ao_grid.AddLine(lsa_newRow)
        ao_grid.LineColor(ao_grid.Row) = vbGreen
    Case "Update"
        ' search and update row in the grid
        Debug.Assert (ao_grid.Cols > 0)
        
        If Not ao_grid.SearchKey(True, av_Key) Then
            Exit Function
        End If
        
        For ll_Index = 0 To ao_grid.Cols - 1
            Set lo_Column = ao_grid.Columns(ll_Index)
            If Not lo_Column.Key Then
                If lo_Column.Name = "Action" Then
                    If lo_Column.GetData(ao_grid.Row) = "" Or lo_Column.GetData(ao_grid.Row) = "D" Then
                        Call lo_Column.SetData(ao_grid.Row, "U")
                        ao_grid.LineColor(ao_grid.Row) = vbCyan
                    End If
                ElseIf lo_Column.Name <> "iConcurrency" Then
                    If Not lo_Column.SetData(ao_grid.Row, GetDataSrcForGrid(lo_Column)) Then
                        Call Err.Raise(1, "lo_Column.SetData", "Cannot update grid.")
                    End If
                End If
            End If
        Next

    Case "Delete"
        Debug.Assert (ao_grid.Cols > 0)
        
        If Not ao_grid.SearchKey(True, av_Key) Then
            Exit Function
        End If
        
        If ao_grid.SelectedLine(0, "Action") = "A" Then
            Call ao_grid.DeleteLine(av_Key)
        Else
            ao_grid.Data(ao_grid.Row, "Action") = "D"
            ao_grid.LineColor(ao_grid.Row) = vbRed
        End If
    
    Case Else
        Debug.Assert (False)
    End Select
    UpdateGridAfterAction = True
    Exit Function
errhandler:
     Call ErrorHandler("UpdateGridAfterAction()")
End Function

' when updating main grid from detail
Private Function GetDataSrcForGrid(ByVal ao_Column As ArmColumn) As String
On Error GoTo errhandler
                
    Select Case ao_Column.Name
        Case "DCC_type"       ' it should be a key
            Debug.Assert (False)
        Case "DCC_Desc"
            GetDataSrcForGrid = GetCboValue(cbo_costType, ao_Column.FieldName)
        Case "DCPLLI_Code"
            GetDataSrcForGrid = IIf(ml_DCPLLI_Code = 0, "", ml_DCPLLI_Code)
        Case "DC_Cost"
            GetDataSrcForGrid = txt_Amount.Text
        Case "Cost_Comment"
            GetDataSrcForGrid = txt_Comment.Text
        Case "CURR_code"
            GetDataSrcForGrid = GetCodeFromCombo(cbo_currency)
        Case "CURR_Desc"
            GetDataSrcForGrid = GetCodeFromCombo(cbo_currency)
        Case "TheoreticalCost"
            GetDataSrcForGrid = txt_Amount.Text
        Case "LinkedEmailIcon"
            GetDataSrcForGrid = ""
        Case "Action", "iConcurrency"     ' shoul be managed outside
            Debug.Assert (False)
        Case Else
            Debug.Assert (False)
    End Select
    
    Exit Function
errhandler:
     Call ErrorHandler("GetDataSrcForGrid()")
End Function

Private Sub Item_UpdateValueDB(ByVal al_valueIndex As Long, ByVal as_allowedOperations As String)
On Error GoTo errhandler
    Dim ls_req As String

    If InStr(as_allowedOperations, grd_link.Data(al_valueIndex, "Action")) = 0 Then Exit Sub
    
Const CREQ_AV As String = "EXEC DC_Cost_ins $Trans_code$,$DCC_type$,$DCPLLI_Code$,$CURR_code$,$DC_Cost$,$DC_Comment$,$Z_Creator$"
Const CREQ_UV As String = "EXEC DC_Cost_upd $Trans_code$,$DCC_type$,$DCPLLI_Code$,$CURR_code$,$DC_Cost$,$DC_Comment$,$Z_Creator$,$iConcurrency$"
Const CREQ_DV As String = "EXEC DC_Cost_del $Trans_code$,$DCC_type$,$iConcurrency$"
Const CREQ_DVL As String = "EXEC DC_Cost_LinkedEmailZip_del $Trans_code$, $DCC_type$"
    
    Select Case grd_link.Data(al_valueIndex, "Action")
        Case "A"
            ls_req = Replace(CREQ_AV, "$Trans_code$", SQLNum(ml_Transcode), , , vbTextCompare)
        Case "U"
            ls_req = Replace(CREQ_UV, "$Trans_code$", SQLNum(ml_Transcode), , , vbTextCompare)
        Case "D"
            ls_req = Replace(CREQ_DVL & ";" & vbCrLf & CREQ_DV, "$Trans_code$", SQLNum(ml_Transcode), , , vbTextCompare)
    End Select
    
    If ls_req = "" Then
        Exit Sub
    End If
    
    ls_req = ItemLine_ReplacePlaceholders(ls_req, al_valueIndex)
    
    Call ExecuteSQLSafe(mo_Db, ls_req, -1)
    
    ' insert linked emails if cost to add is manual cost
    If grd_link.Data(al_valueIndex, "Action") = "A" And _
        grd_link.Data(al_valueIndex, "DCC_type") = "M" Then
        
        Dim lo_folder As Folder
        If mo_FSO.FolderExists(prg.AppCache_Dir & "\DCCost\") Then
            Set lo_folder = mo_FSO.GetFolder(prg.AppCache_Dir & "\DCCost\")
        
            Dim lo_File As File
            
            For Each lo_File In lo_folder.Files
                If Not EML_InsertFileFromCache(lo_File.Path, ml_Transcode) Then
                    ReDim ms_MsgInfo(0, 1)
                    ms_MsgInfo(0, 0) = "$FILE$"
                    ms_MsgInfo(0, 1) = lo_File.Name
                    Call MsgBox(MsgText(5160, ms_Language_Code, "#Link was not added!!! ($FILE$)", ms_MsgInfo), vbCritical Or vbOKOnly)
                End If
            Next
            
        End If
    End If
    
    Exit Sub
errhandler:
    Call ErrorHandler(Extender.Name & ".Item_UpdateValueDB")
End Sub

Private Function ItemLine_ReplacePlaceholders(ls_retVal As String, ByVal al_Row As Long) As String
On Error GoTo errhandler
    
    ls_retVal = Replace(ls_retVal, "$DCC_type$", SqlStr(grd_link.Data(al_Row, "DCC_type"), 1), , , vbTextCompare)
    ls_retVal = Replace(ls_retVal, "$DCPLLI_Code$", SQLNum(grd_link.Data(al_Row, "DCPLLI_Code")), , , vbTextCompare)
    ls_retVal = Replace(ls_retVal, "$CURR_code$", SqlStr(grd_link.Data(al_Row, "CURR_code"), 5), , , vbTextCompare)
    ls_retVal = Replace(ls_retVal, "$DC_Cost$", SQLNum(grd_link.Data(al_Row, "DC_Cost")), , , vbTextCompare)
    ls_retVal = Replace(ls_retVal, "$DC_Comment$", SqlStr(grd_link.Data(al_Row, "Cost_Comment"), 255), , , vbTextCompare)
    ls_retVal = Replace(ls_retVal, "$iConcurrency$", SQLNum(grd_link.Data(al_Row, "iConcurrency")), , , vbTextCompare)
    ls_retVal = Replace(ls_retVal, "$Z_Creator$", SqlStr(dc_userName, 15), , , vbTextCompare)

    ItemLine_ReplacePlaceholders = ls_retVal
    Exit Function
errhandler:
    Call ErrorHandler(Extender.Name & ".ItemLine_ReplacePlaceholders")
End Function

Private Sub ChangeCharset(ByRef ao_Container As Object, Optional ByVal aCodePage As Long)
On Error GoTo errhandler
   
    Dim lc_Control As Control
    Dim ll_Charset As Long
    
    On Error Resume Next
    ll_Charset = GetCharSetFromCodePage(aCodePage)
    
    For Each lc_Control In ao_Container
        Select Case UCase(TypeName(lc_Control))
        Case "TABSTRIP", "TEXTBOX", "LABEL", "FRAME", "COMMANDBUTTON", _
              "LISTVIEW", "CHECKBOX", "OPTIONBUTTON", _
              "ARMCHECKVIEW", "ARMTREEVIEW", "ARMGRID", "ARMCOMBOBOX", "ARMCHECKVIEW0"
            lc_Control.Font.Name = "Arial"
            lc_Control.Font.Charset = ll_Charset
        Case "A_SEEK", "A_SRCHTXT"
            lc_Control.Charset = ll_Charset
        End Select
    Next
    
    Exit Sub

errhandler:
    Call ErrorHandler(Extender.Name & ".ChangeCharset")
End Sub


' translate string to sql format
' Params:
' as_Value (String)
' ab_EmptyNULL (Boolean = False)
Private Function SqlStr(ByVal as_Value As String, Optional ByVal al_MaxLen As Long = 8000, Optional ByVal ab_EmptyNULL As Boolean = False) As String
    If as_Value = "" And ab_EmptyNULL Then
        SqlStr = "NULL"
    Else
        SqlStr = "'" & Replace(Left(as_Value, IIf(Len(as_Value) <= al_MaxLen, Len(as_Value), al_MaxLen)), "'", "''") & "'"
    End If
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

Private Function SQLNum(ByVal as_str As String) As String
    If as_str = "" Then
        SQLNum = "NULL"
    Else
        SQLNum = Replace(as_str, ",", ".")
    End If
End Function


Private Function GetArrayValue(ByRef ao_variantArray As Variant, ByVal al_Index As Long) As Variant
    If IsArray(ao_variantArray) Then
        If UBound(ao_variantArray) <= al_Index Then
            GetArrayValue = ao_variantArray(al_Index)
        Else
            GetArrayValue = 0
        End If
    Else
        GetArrayValue = 0
    End If
End Function

Private Function GetCboKey(ByRef ao_cbo As ArmCombobox) As String
On Error GoTo errhandler
    GetCboKey = ""
    If Not ao_cbo.SelectedItem Is Nothing Then
        GetCboKey = ao_cbo.SelectedItem.Key
    End If
    Exit Function
errhandler:
     Call ErrorHandler("GetCboKey()")
End Function

Private Function GetCboValue(ByRef ao_cbo As ArmCombobox, ByVal av_field As Variant) As String
On Error GoTo errhandler
    GetCboValue = ""
    If Not ao_cbo.SelectedItem Is Nothing Then
        GetCboValue = ao_cbo.GetItemData(ao_cbo.SelectedItem.Key, av_field)
    End If
    Exit Function
errhandler:
     Call ErrorHandler("GetCboValue()")
End Function


Public Sub DeleteCostLine(ByVal as_DCC_type As String)
On Error GoTo errhandler
    Call UpdateGridAfterAction(grd_link, "Delete", Array(as_DCC_type))
    grd_link.DeselectRow
    Exit Sub
errhandler:
     Call ErrorHandler("DeleteCostLine()")
End Sub

Public Sub UpdateCostLine(ByVal as_DCC_type As String, ByVal al_DCPLLI_code As Long, ByVal ad_Price As Double, ByVal as_CURR_Code As String)
On Error GoTo errhandler
    ml_DCPLLI_Code = al_DCPLLI_code
    Call SetComboItemValue(cbo_costType, as_DCC_type)
    txt_Amount.Text = ad_Price
    txt_Comment.Text = ""
    Call SetComboItemValue(cbo_currency, as_CURR_Code)
    
    If grd_link.SearchKey(True, as_DCC_type) Then
        ' check if existing line is going to change
        If al_DCPLLI_code <> grd_link.SelectedLine(0, "DCPLLI_Code") Or _
            ad_Price <> grd_link.SelectedLine(0, "DC_Cost") Or _
            as_CURR_Code <> grd_link.SelectedLine(0, "CURR_code") _
        Then
            Call UpdateGridAfterAction(grd_link, "Update", Array(as_DCC_type))
        Else
            If grd_link.Data(grd_link.Row, "Action") = "D" Then
                grd_link.Data(grd_link.Row, "Action") = ""
                grd_link.LineColor(grd_link.Row) = vbWhite
            End If
        End If
    Else
        If ml_DCPLLI_Code <> 0 Or as_DCC_type <> "T" Then
            Call UpdateGridAfterAction(grd_link, "Add", Array(as_DCC_type))
        End If
    End If
    
    grd_link.DeselectRow
        
    Exit Sub
errhandler:
     Call ErrorHandler("UpdateCostLine()")
End Sub

Private Sub RecalcPartialCost()
On Error GoTo errhandler

    Dim ll_i As Long
    
    For ll_i = 0 To grd_link.Rows - 1
        If grd_link.Data(ll_i, "DCC_Type") <> "M" Then
            grd_link.Data(ll_i, "TheoreticalCost") = md_TheoreticalCost
        Else
            grd_link.Data(ll_i, "TheoreticalCost") = grd_link.Data(ll_i, "DC_Cost")
        End If
    Next

    Exit Sub
errhandler:
     Call ErrorHandler("RecalcPartialCost()")
End Sub

Private Sub UserControl_Resize()
Const C_SPACE As Long = 60
    grd_link.Left = UserControl.ScaleLeft
    grd_link.Width = UserControl.ScaleWidth
    Call Frame.Move(UserControl.ScaleLeft, UserControl.ScaleTop, UserControl.ScaleWidth)
    cbo_costType.Width = Frame.Width - cbo_costType.Left
    cbo_currency.Width = Frame.Width - cbo_currency.Left
    txt_Comment.Width = Frame.Width - txt_Comment.Left
    pic_quit.Left = Frame.Width - pic_quit.Width
    pic_Valid.Left = pic_quit.Left - pic_Valid.Width - (C_SPACE / 2)
    lv_emails.Width = pic_Valid.Left - lv_emails.Left - C_SPACE
End Sub


Private Sub EML_GetInfo(ByVal as_Path As String, ByRef as_Subject As String, ByRef as_fromName As String, ByRef as_from As String, ByRef as_to As String, ByRef ad_Date As Date)
On Error GoTo errhandler

    Dim lo_ts As TextStream
    Dim ls_Line As String
    
    Dim lsa_line() As String
    
    Set lo_ts = mo_FSO.OpenTextFile(as_Path)
    
    Dim ls_token As String
    Dim ls_Value As String
    
    While Not lo_ts.AtEndOfStream
        ls_Line = lo_ts.ReadLine
        
        If IsToken(ls_Line) Then
            ' we reach new token -> process old
        
            Select Case ls_token
            Case "Subject"
                as_Subject = ls_Value
            Case "From"
                lsa_line = Split(ls_Value, "<", 2)
                If UBound(lsa_line) = 1 Then
                    as_fromName = Trim(lsa_line(0))
                    as_from = Left(lsa_line(1), Len(lsa_line(1)) - 1)
                Else
                    as_from = lsa_line(0)
                    as_fromName = lsa_line(0)
                End If
            Case "To"
                as_to = ls_Value
            Case "Date"
                ' remove day -> before comma
                lsa_line = Split(ls_Value, ",", 2)
                If UBound(lsa_line) = 1 Then
                    ' remove time after -
                    lsa_line = Split(lsa_line(1), "-", 2)
                Else
                    ' no day?
                    lsa_line = Split(lsa_line(0), "-", 2)
                End If
                ad_Date = DateFromString(lsa_line(0), en_US)
                
            End Select
            
            ' define new token
            lsa_line = Split(ls_Line, ":", 2)
        
            If UBound(lsa_line) = 1 Then
                ls_token = lsa_line(0)
                ls_Value = lsa_line(1)
            Else
                'new part of value
                ls_Value = ls_Value & ls_Line
            End If
        Else
            'new part of value
            ls_Value = ls_Value & ls_Line
        End If
    Wend
    
    lo_ts.Close
    Set lo_ts = Nothing
    
        
    Exit Sub
errhandler:
     Call ErrorHandler("EML_GetInfo()")
End Sub

Private Function IsToken(ByRef as_Line As String) As Boolean
On Error GoTo errhandler
    If as_Line = "" Then
        IsToken = False
        Exit Function
    End If
    Select Case Asc(Left(as_Line, 1))
        Case 32, 9
            IsToken = False
        Case Else
            IsToken = True
    End Select
        
    Exit Function
errhandler:
     Call ErrorHandler("IsToken()")
End Function

Private Function DateFromString(ByVal sDateIn As String, ByVal LCID As LocaleIDs) As Date
On Error GoTo errhandler

    Dim hResult As Long
    Dim dtOut As Date

    ' Do not want user's own settings to override the standard formatting settings
    ' if they are using the same locale that we are converting from.
    '
    Const LOCALE_NOUSEROVERRIDE = &H80000000

    ' Do the conversion
    hResult = VarDateFromStr(StrPtr(sDateIn), LCID, LOCALE_NOUSEROVERRIDE, dtOut)

    ' Check return value to catch any errors.
    '
    ' Can change the code below to return standard VB6 error codes instead
    ' (i.e. DISP_E_TYPEMISMATCH = "Type Mismatch" = error code 13)
    '
    Select Case hResult

        Case S_OK:
            DateFromString = dtOut
        Case DISP_E_BADVARTYPE:
            Err.Raise 5, , "DateFromString: DISP_E_BADVARTYPE"
        Case DISP_E_OVERFLOW:
            Err.Raise 5, , "DateFromString: DISP_E_OVERFLOW"
        Case DISP_E_TYPEMISMATCH:
            Err.Raise 5, , "DateFromString: DISP_E_TYPEMISMATCH"
        Case E_INVALIDARG:
            Err.Raise 5, , "DateFromString: E_INVALIDARG"
        Case E_OUTOFMEMORY:
            Err.Raise 5, , "DateFromString: E_OUTOFMEMORY"
        Case Else
            Err.Raise 5, , "DateFromString: Unknown error code returned from VarDateFromStr (0x" & Hex(hResult) & ")"
    End Select
        
    Exit Function
errhandler:
     Call ErrorHandler("DateFromString()")
End Function

Private Function EML_CacheFile(ByVal as_Path As String, ByVal as_Type As String, ByRef as_filePath As String) As Long
On Error GoTo errhandler
        
    EML_CacheFile = -1
    'Insert the file
    
    Dim ls_DC_EML_ZIP_ID  As String
    ls_DC_EML_ZIP_ID = mo_Db.SQLNextID("DC_EML_ZIP_ID")
    
    If ls_DC_EML_ZIP_ID = "" Then
        Err.Raise 666, "mo_Db.SQLNextID", "SQLNextID failed for: DC_EML_ZIP_ID"
    End If
    
    as_filePath = prg.AppCache_Dir & "\DCCost\" & ls_DC_EML_ZIP_ID & "." & as_Type
    
    Call mo_FSO.CopyFile(as_Path, as_filePath, True)
    
    If Not WriteFileStream(as_filePath, "DC_EML_type", as_Type) Then MsgBox ("#Write DC_EML_type failed. (" & as_filePath & ")")
    
    EML_CacheFile = Val(ls_DC_EML_ZIP_ID)
    Exit Function
errhandler:
     Call ErrorHandler("EML_CacheFile()")
End Function

        
Private Function EML_CacheFileInfo(ByVal as_file As String, ByVal as_DCC_type As String, ByVal al_DC_EML_ZIP_ID As Long, ByVal as_EML_Subject As String, ByVal as_EML_SenderEmailAddress As String, ByVal as_EML_To As String, ByVal as_EML_SenderName As String, ByVal al_EML_Attachements As Long, ByVal ad_EML_CreationTime As Date) As Long
On Error GoTo errhandler
Const C_REQ As String = "DC_Cost_LinkedEmail_ins $DC_EML_ID$, $TRANS_Code$, $DCC_type$, $DC_EML_ZIP_ID$, $EML_Subject$, $EML_SenderEmailAddress$, $EML_To$, $EML_SenderName$, $EML_Attachements$, $EML_CreationTime$, $Z_Creator$"

        EML_CacheFileInfo = 0
    
        Dim ls_DC_EML_ID  As String
        ls_DC_EML_ID = mo_Db.SQLNextID("DC_EML_ID")
        
        If ls_DC_EML_ID = "" Then
            Err.Raise 666, "mo_Db.SQLNextID", "SQLNextID failed for: DC_EML_ID"
        End If
        
        ' insert record
        If Not WriteFileStream(as_file, "DCC_type", as_DCC_type) Then MsgBox ("#Write DCC_type failed. (" & as_file & ")")
        If Not WriteFileStream(as_file, "DC_EML_ID", ls_DC_EML_ID) Then MsgBox ("#Write DC_EML_ID failed. (" & as_file & ")")
        If Not WriteFileStream(as_file, "DC_EML_ZIP_ID", al_DC_EML_ZIP_ID) Then MsgBox ("#Write DC_EML_ZIP_ID failed. (" & as_file & ")")
        If Not WriteFileStream(as_file, "EML_Subject", as_EML_Subject) Then MsgBox ("#Write EML_Subject failed. (" & as_file & ")")
        If Not WriteFileStream(as_file, "EML_SenderEmailAddress", as_EML_SenderEmailAddress) Then MsgBox ("#Write EML_SenderEmailAddress failed. (" & as_file & ")")
        If Not WriteFileStream(as_file, "EML_To", as_EML_To) Then MsgBox ("#Write EML_To failed. (" & as_file & ")")
        If Not WriteFileStream(as_file, "EML_SenderName", as_EML_SenderName) Then MsgBox ("#Write EML_SenderName failed. (" & as_file & ")")
        If Not WriteFileStream(as_file, "EML_Attachements", al_EML_Attachements) Then MsgBox ("#Write EML_Attachements failed. (" & as_file & ")")
        If Not WriteFileStream(as_file, "EML_CreationTime", ad_EML_CreationTime) Then MsgBox ("#Write EML_CreationTime failed. (" & as_file & ")")
        
        EML_CacheFileInfo = Val(ls_DC_EML_ID)

    Exit Function
errhandler:
     Call ErrorHandler("EML_CacheFileInfo()")
End Function

Private Function EML_InsertFileFromCache(ByVal as_Path As String, ByVal al_TRANS_Code As Long) As Boolean
On Error GoTo errhandler

    EML_InsertFileFromCache = False
    
    If Not mo_FSO.FileExists(as_Path) Then Exit Function
    
    Dim ls_req As String
    
    Dim ls_DCC_type As String
    Dim ls_DC_EML_ID As String
    Dim ls_DC_EML_ZIP_ID As String
    Dim ls_EML_Subject As String
    Dim ls_EML_SenderEmailAddress As String
    Dim ls_EML_To As String
    Dim ls_EML_SenderName As String
    Dim ls_EML_Attachements As String
    Dim ls_EML_CreationTime As String
    Dim ls_DC_EML_type As String
    
    If Not ReadFileStream(as_Path, "DC_EML_type", ls_DC_EML_type) Then MsgBox ("#Read DC_EML_type failed.")
    If Not ReadFileStream(as_Path, "DCC_type", ls_DCC_type) Then MsgBox ("#Read DCC_type failed.")
    If Not ReadFileStream(as_Path, "DC_EML_ID", ls_DC_EML_ID) Then MsgBox ("#Read DC_EML_ID failed.")
    If Not ReadFileStream(as_Path, "DC_EML_ZIP_ID", ls_DC_EML_ZIP_ID) Then MsgBox ("#Read DC_EML_ZIP_ID failed.")
    If Not ReadFileStream(as_Path, "EML_Subject", ls_EML_Subject) Then MsgBox ("#Read EML_Subject failed.")
    If Not ReadFileStream(as_Path, "EML_SenderEmailAddress", ls_EML_SenderEmailAddress) Then MsgBox ("#Read EML_SenderEmailAddress failed.")
    If Not ReadFileStream(as_Path, "EML_To", ls_EML_To) Then MsgBox ("#Read EML_To failed.")
    If Not ReadFileStream(as_Path, "EML_SenderName", ls_EML_SenderName) Then MsgBox ("#Read EML_SenderName failed.")
    If Not ReadFileStream(as_Path, "EML_Attachements", ls_EML_Attachements) Then MsgBox ("#Read EML_Attachements failed.")
    If Not ReadFileStream(as_Path, "EML_CreationTime", ls_EML_CreationTime) Then MsgBox ("#Read EML_CreationTime failed.")
    
    If ls_DC_EML_ZIP_ID = "" Then Exit Function
    If ls_DC_EML_ID = "" Then Exit Function
    
    Call EML_InsertFileSQL(as_Path, ls_DC_EML_ZIP_ID, ls_DC_EML_type)
    
    Call EML_InsertInfoSQL(ls_DC_EML_ID, al_TRANS_Code, ls_DCC_type, ls_DC_EML_ZIP_ID, ls_EML_Subject, ls_EML_SenderEmailAddress, ls_EML_To, ls_EML_SenderName, ls_EML_Attachements, ls_EML_CreationTime)
    
    EML_InsertFileFromCache = True
    Exit Function
errhandler:
     Call ErrorHandler("EML_InsertFileFromCache()")
End Function

Private Function WriteFileStream(ByVal as_fileName As String, ByVal as_StreamName As String, ByVal as_StreamText As String) As Boolean
On Error GoTo ErrorHandler

    Dim ts As Object
    Dim ls_FileStreamName As String

    WriteFileStream = False
    
    If as_fileName = "" Then Exit Function
    If as_StreamName = "" Then Exit Function
    
    ' Makes sure the current volume is NTFS
    If Not IsNTFS(as_fileName) Then
       MsgBox L_NotNTFS
       Exit Function
    End If
      
    ' Creates the file if it doesn't exist
    If mo_FSO.FileExists(as_fileName) Then
    
      ls_FileStreamName = as_fileName & ":" & as_StreamName
      ' Try to write to the stream
      Set ts = mo_FSO.CreateTextFile(ls_FileStreamName)
      Call ts.Write(as_StreamText)
      Call ts.Close
      Set ts = Nothing
      WriteFileStream = True
    End If
    
    Exit Function
ErrorHandler:
     Call ErrorHandler("WriteFileStream()")
End Function

Function IsNTFS(as_fileName As String)
   Dim drv As Drive
   
On Error GoTo ErrorHandler
   Set drv = mo_FSO.GetDrive(mo_FSO.GetDriveName(as_fileName))
   IsNTFS = (drv.FileSystem = "NTFS")
   Set drv = Nothing
   Exit Function
ErrorHandler:
     Call ErrorHandler("IsNTFS()")
End Function

Private Function ReadFileStream(ByVal as_fileName As String, ByVal as_StreamName As String, ByRef as_StreamText As String, Optional ByVal as_DefaultValue As String = "") As Boolean
Dim ts As Object
Dim ls_FileStreamName As String

On Error GoTo ErrorHandler
    ReadFileStream = False
    
    If as_fileName = "" Then Exit Function
    If as_StreamName = "" Then Exit Function
    
    ' Makes sure the current volume is NTFS
    If Not IsNTFS(as_fileName) Then
       MsgBox L_NotNTFS
       Exit Function
    End If
    
    ' if it doesn't exist
    If mo_FSO.FileExists(as_fileName) Then
      ls_FileStreamName = as_fileName & ":" & as_StreamName
      If mo_FSO.FileExists(ls_FileStreamName) Then
         Set ts = mo_FSO.OpenTextFile(ls_FileStreamName)
         as_StreamText = ts.ReadAll()
         ts.Close
      Else
         as_StreamText = as_DefaultValue
      End If
      ReadFileStream = True
    End If
    ' Close the app
    Set ts = Nothing
    Exit Function
ErrorHandler:
     Call ErrorHandler("ReadFileStream()")
End Function

Private Function EML_InsertFile(ByVal as_Path As String, ByVal as_Type As String) As Long
On Error GoTo errhandler
        
    EML_InsertFile = -1
    'Insert the file
    
    Dim ls_DC_EML_ZIP_ID  As String
    ls_DC_EML_ZIP_ID = mo_Db.SQLNextID("DC_EML_ZIP_ID")
    
    If ls_DC_EML_ZIP_ID = "" Then
        Err.Raise 666, "mo_Db.SQLNextID", "SQLNextID failed for: DC_EML_ZIP_ID"
    End If
    
    Call EML_InsertFileSQL(as_Path, ls_DC_EML_ZIP_ID, as_Type)
    
    EML_InsertFile = Val(ls_DC_EML_ZIP_ID)
    Exit Function
errhandler:
     Call ErrorHandler("EML_InsertFile()")
End Function

Private Sub EML_InsertFileSQL(ByVal as_Path As String, ByVal as_DC_EML_ZIP_ID As String, ByVal as_Type As String)
On Error GoTo errhandler
Const C_REQ_FILE As String = "INSERT INTO DC_Cost_LinkedEmailZip VALUES($DC_EML_ZIP_ID$, ?, $DC_EML_TYPE$)"
        
    Dim ls_req As String
    
    ls_req = Replace(C_REQ_FILE, "$DC_EML_ZIP_ID$", SQLNum(as_DC_EML_ZIP_ID), , , vbTextCompare)
    ls_req = Replace(ls_req, "$DC_EML_TYPE$", SqlStr(as_Type, 3), , , vbTextCompare)
    
    If Not mo_Db.FileToBlobSQL(ls_req, as_Path, 9) Then
        Err.Raise 666, "FileToBlobSQL", mo_Db.LastErrorMessage & " Error writing blob: " & ls_req & " File: " & as_Path
    End If
    
    Exit Sub
errhandler:
     Call ErrorHandler("EML_InsertFileSQL()")
End Sub

Private Function EML_InsertInfo(ByVal al_TRANS_Code As Long, ByVal as_DCC_type As String, ByVal al_DC_EML_ZIP_ID As Long, ByVal as_EML_Subject As String, ByVal as_EML_SenderEmailAddress As String, ByVal as_EML_To As String, ByVal as_EML_SenderName As String, ByVal al_EML_Attachements As Long, ByVal ad_EML_CreationTime As Date) As Long
On Error GoTo errhandler

    EML_InsertInfo = 0
    
    Dim ls_DC_EML_ID  As String
    ls_DC_EML_ID = mo_Db.SQLNextID("DC_EML_ID")
    
    If ls_DC_EML_ID = "" Then
        Err.Raise 666, "mo_Db.SQLNextID", "SQLNextID failed for: DC_EML_ID"
    End If
    
    Call EML_InsertInfoSQL(ls_DC_EML_ID, al_TRANS_Code, as_DCC_type, al_DC_EML_ZIP_ID, as_EML_Subject, as_EML_SenderEmailAddress, as_EML_To, as_EML_SenderName, al_EML_Attachements, ad_EML_CreationTime)
    
    EML_InsertInfo = Val(ls_DC_EML_ID)
    Exit Function
errhandler:
     Call ErrorHandler("EML_InsertInfo()")
End Function

Private Sub EML_InsertInfoSQL(ByVal as_DC_EML_ID As String, ByVal al_TRANS_Code As Long, ByVal as_DCC_type As String, ByVal al_DC_EML_ZIP_ID As Long, ByVal as_EML_Subject As String, ByVal as_EML_SenderEmailAddress As String, ByVal as_EML_To As String, ByVal as_EML_SenderName As String, ByVal al_EML_Attachements As Long, ByVal ad_EML_CreationTime As Date)
On Error GoTo errhandler
Const C_REQ As String = "DC_Cost_LinkedEmail_ins $DC_EML_ID$, $TRANS_Code$, $DCC_type$, $DC_EML_ZIP_ID$, $EML_Subject$, $EML_SenderEmailAddress$, $EML_To$, $EML_SenderName$, $EML_Attachements$, $EML_CreationTime$, $Z_Creator$"

    Dim ls_req As String
    
    ' insert record
    ls_req = Replace(C_REQ, "$TRANS_Code$", SQLNum(al_TRANS_Code), , , vbTextCompare)
    ls_req = Replace(ls_req, "$DCC_type$", SqlStr(as_DCC_type, 1), , , vbTextCompare)
    ls_req = Replace(ls_req, "$DC_EML_ID$", SQLNum(as_DC_EML_ID), , , vbTextCompare)
    ls_req = Replace(ls_req, "$DC_EML_ZIP_ID$", SQLNum(al_DC_EML_ZIP_ID), , , vbTextCompare)
    ls_req = Replace(ls_req, "$EML_Subject$", SqlStr(as_EML_Subject, 150), , , vbTextCompare)
    ls_req = Replace(ls_req, "$EML_SenderEmailAddress$", SqlStr(as_EML_SenderEmailAddress, 150), , , vbTextCompare)
    ls_req = Replace(ls_req, "$EML_To$", SqlStr(as_EML_To, 150), , , vbTextCompare)
    ls_req = Replace(ls_req, "$EML_SenderName$", SqlStr(as_EML_SenderName, 150), , , vbTextCompare)
    ls_req = Replace(ls_req, "$EML_Attachements$", SQLNum(al_EML_Attachements), , , vbTextCompare)
    ls_req = Replace(ls_req, "$EML_CreationTime$", SqlDate(ad_EML_CreationTime), , , vbTextCompare)
    ls_req = Replace(ls_req, "$Z_Creator$", SQLNum(ml_U_Code), , , vbTextCompare)
    Call ExecuteSQLSafe(mo_Db, ls_req)
    
    Exit Sub
errhandler:
     Call ErrorHandler("EML_InsertInfoSQL()")
End Sub



Private Function ShowMsg(ByVal al_DC_EML_ID As Long) As Boolean
On Error GoTo errhandler
Const C_REQ As String = "EXEC DC_Cost_LinkedEmail_sel $DC_EML_ID$"

Dim ls_TempDir As String
Dim ls_Filename As String
Dim lo_shell As Object
Dim ll_DC_EML_ZIP_ID  As Long

    ShowMsg = False
    If MsgBox(MsgText(5170, ms_Language_Code, "Are you sure to download outlook message file ? Operation can take long time"), vbYesNo) = vbNo Then Exit Function
    
    Dim ll_Cursor As Long
    
    ll_Cursor = OpenSQLSafe(mo_Db, Replace(C_REQ, "$DC_EML_ID$", SQLNum(al_DC_EML_ID), , , vbTextCompare))
    
    If Not mo_Db.EOF(ll_Cursor) Then
        ll_DC_EML_ZIP_ID = mo_Db.GetFields(ll_Cursor, "DC_EML_ZIP_ID")
        
        Select Case UCase(mo_Db.GetFields(ll_Cursor, "DC_EML_Type"))
        Case "MSG", "EML"
            ls_Filename = "File_" & ll_DC_EML_ZIP_ID & "." & LCase(mo_Db.GetFields(ll_Cursor, "DC_EML_Type"))
        Case Else
            ls_Filename = "File_" & ll_DC_EML_ZIP_ID & "." & mo_Db.GetFields(ll_Cursor, "EML_To")
        End Select
    End If
    
    Call mo_Db.Close(ll_Cursor)
    ll_Cursor = 0
    
    ls_TempDir = GetTempDir()
    If Not mo_FSO.FolderExists(ls_TempDir) Then
      Call mo_FSO.CreateFolder(ls_TempDir)
    End If
    
    If DownloadMSGToFile(ll_DC_EML_ZIP_ID, ls_TempDir & "\" & ls_Filename) Then
        Set lo_shell = CreateObject("Shell.Application")
        Call lo_shell.ShellExecute(ls_TempDir & "\" & ls_Filename, "", "", "open", 1)
        Set lo_shell = Nothing
        ShowMsg = True
    End If
    Exit Function
errhandler:
    If ll_Cursor > 0 Then
        Call mo_Db.Close(ll_Cursor)
        ll_Cursor = 0
    End If
    Call ErrorHandler("ShowMSG")
End Function

Private Function DownloadMSGToFile(ByVal al_ZipTableIndex As Long, ByVal as_fileName As String) As Boolean
On Error GoTo errhandler

Dim ll_Index As Long
Dim ls_RequestSel As String
Dim ls_RequestIns As String
Dim ls_Filename As String

    DownloadMSGToFile = False
    If mo_FSO.FileExists(as_fileName) Then
        If Not DeleteFile(as_fileName) Then
            Exit Function
        End If
    End If
    
    ls_RequestSel = "SELECT DC_EML_ZIP FROM DC_Cost_LinkedEmailZip WHERE DC_EML_ZIP_ID=$DC_EML_ZIP_ID$"
    ls_RequestSel = Replace(ls_RequestSel, "$DC_EML_ZIP_ID$", al_ZipTableIndex)
    
    If Not mo_Db.BlobToFileSQL(ls_RequestSel, as_fileName, True, False) Then
        Err.Raise 666, "FileToBlobSQL", mo_Db.LastErrorMessage & " Error writing blob: " & ls_RequestSel & " File: " & ls_Filename
    End If
    DownloadMSGToFile = True
    Exit Function
errhandler:
    Call ErrorHandler("DownloadMSGToFile as_FileName=" & _
                               " DC_EML_ZIP_ID=" & al_ZipTableIndex)
End Function


Private Function GetTempDir() As String
Dim ls_Buff As String, ll_Count As Long

On Error GoTo errhandler
    ls_Buff = SPACE(4096)
    ll_Count = GetTempPath(4096, ls_Buff)
    
    ls_Buff = Left(ls_Buff, ll_Count)
    'this function can return path with trailing "\" character - strip it
    If ll_Count > 0 Then
      If right(ls_Buff, 1) = "\" Then
       ls_Buff = Left(ls_Buff, ll_Count - 1)
      End If
    End If
    GetTempDir = ls_Buff
  Exit Function
errhandler:
  Call ErrorHandler("GetTempDir")
End Function



Private Function MsgText(ByVal aID As Long, ByVal aLang As String, ByVal aDefault As String, Optional ByVal aInfo As Variant) As String
On Error GoTo errhandler

Const DB_REQ As String = "SELECT message_text FROM error_message WHERE msgid = $id$ AND Language_code = '$lang$'"

    MsgText = ""
    
    Dim lRequest As String
    lRequest = Replace(DB_REQ, "$id$", aID, , , vbTextCompare)
    lRequest = Replace(lRequest, "$lang$", aLang, , , vbTextCompare)
    Dim lData As Long
    
    lData = OpenSQLSafe(mo_Db, lRequest)
    
    Dim lBuffer As String
    lBuffer = mo_Db.GetFields(lData, "message_text")
    mo_Db.Close (lData)
    If lBuffer = "" Then lBuffer = aDefault
    
    Dim li_idx As Integer
    If Not IsMissing(aInfo) Then
        For li_idx = 0 To UBound(aInfo)
            lBuffer = Replace(lBuffer, aInfo(li_idx, 0), aInfo(li_idx, 1), , , vbTextCompare)
        Next li_idx
    End If
    
    
    MsgText = lBuffer
    Exit Function
errhandler:
    mo_Db.Close (lData)
    Call MsgBox("Connection failure accessing message information.")
    MsgText = aDefault
End Function

