VERSION 5.00
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.1#0"; "mscomctl.ocx"
Begin VB.Form frm_TechinfoFile 
   BorderStyle     =   1  'Fixed Single
   Caption         =   "File attachment"
   ClientHeight    =   4980
   ClientLeft      =   2070
   ClientTop       =   360
   ClientWidth     =   9990
   ClipControls    =   0   'False
   ControlBox      =   0   'False
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   PaletteMode     =   1  'UseZOrder
   ScaleHeight     =   4980
   ScaleWidth      =   9990
   ShowInTaskbar   =   0   'False
   Begin VB.Frame frm_File 
      BorderStyle     =   0  'None
      Height          =   4950
      Left            =   0
      TabIndex        =   1
      Top             =   0
      Width           =   5610
      Begin VB.CommandButton cmd_Quit 
         Height          =   615
         Left            =   4800
         Style           =   1  'Graphical
         TabIndex        =   11
         Top             =   4260
         Width           =   675
      End
      Begin VB.CommandButton cmd_Save 
         Height          =   615
         Left            =   4050
         Style           =   1  'Graphical
         TabIndex        =   10
         Top             =   4260
         Width           =   675
      End
      Begin VB.PictureBox pic_Thumb 
         Height          =   600
         Left            =   4500
         ScaleHeight     =   540
         ScaleWidth      =   540
         TabIndex        =   9
         Top             =   570
         Visible         =   0   'False
         Width           =   600
      End
      Begin VB.PictureBox pic_Preview 
         Height          =   1455
         Left            =   3960
         ScaleHeight     =   1395
         ScaleWidth      =   1455
         TabIndex        =   8
         Top             =   90
         Visible         =   0   'False
         Width           =   1515
      End
      Begin VB.FileListBox fil_File 
         Height          =   1845
         Index           =   1
         Left            =   120
         TabIndex        =   6
         Top             =   1700
         Width           =   5355
      End
      Begin VB.DirListBox dir_Dir 
         Height          =   990
         Index           =   1
         Left            =   120
         TabIndex        =   5
         Top             =   500
         Width           =   3690
      End
      Begin VB.DriveListBox drv_Drive 
         Height          =   315
         Index           =   1
         Left            =   120
         TabIndex        =   4
         Top             =   120
         Width           =   3690
      End
      Begin VB.TextBox txt_File 
         Height          =   312
         Index           =   1
         Left            =   120
         Locked          =   -1  'True
         TabIndex        =   3
         Top             =   3900
         Width           =   5385
      End
      Begin MSComctlLib.TabStrip tbs_MediaType 
         Height          =   630
         Left            =   120
         TabIndex        =   2
         Top             =   4260
         Width           =   3870
         _ExtentX        =   6826
         _ExtentY        =   1111
         TabWidthStyle   =   2
         TabFixedWidth   =   1499
         Placement       =   1
         _Version        =   393216
         BeginProperty Tabs {1EFB6598-857C-11D1-B16A-00C0F0283628} 
            NumTabs         =   4
            BeginProperty Tab1 {1EFB659A-857C-11D1-B16A-00C0F0283628} 
               Caption         =   "Thumbnail"
               Key             =   "T"
               ImageVarType    =   2
            EndProperty
            BeginProperty Tab2 {1EFB659A-857C-11D1-B16A-00C0F0283628} 
               Caption         =   "Preview"
               Key             =   "P"
               ImageVarType    =   2
            EndProperty
            BeginProperty Tab3 {1EFB659A-857C-11D1-B16A-00C0F0283628} 
               Caption         =   "Full"
               Key             =   "F"
               ImageVarType    =   2
            EndProperty
            BeginProperty Tab4 {1EFB659A-857C-11D1-B16A-00C0F0283628} 
               Caption         =   "Hires"
               Key             =   "H"
               ImageVarType    =   2
            EndProperty
         EndProperty
      End
      Begin VB.Label lbl_Current 
         Caption         =   "Current attachment: "
         Height          =   195
         Left            =   120
         TabIndex        =   7
         Top             =   3600
         Width           =   1455
      End
   End
   Begin VB.PictureBox pic_Full 
      Height          =   4830
      Left            =   5655
      ScaleHeight     =   4770
      ScaleWidth      =   4215
      TabIndex        =   0
      Top             =   60
      Width           =   4275
   End
End
Attribute VB_Name = "frm_TechinfoFile"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
'   gut_Param.Str13 : Temporary Name of the new directory of the media files (not I/O but Str 18)
'                     Returned by the screen used to choose the directory !!
'   gut_Param.Str14 : Id of the table media_path (not I/Not O)
'                      Returned by the screen used to choose the directory !!
'   gut_Param.Str15 : Contains a boolean OK if we success to change or enter media files (O)
'   gut_Param.Str16 : temporary var : 3 chars of the extension of the new file (O)
'   gut_Param.Str17 : code of the type of media file extension (I)
'   gut_Param.Str18 : Name of the old directory of the media files (I) Name of the new directory of the new media files (O)
'   gut_Param.Str19 : 3 Chars of the extension of the old file (I/O)
'   gut_Param.Str20 : iconcurency of the data (I/O)
'   gut_Param.Str21 : Name of the new preview file (O)
'   gut_Param.Str22 : Name of the new full file (O)
'   gs_MediaCode : Id of the Media (I)


Private Declare Function LockWindowUpdate Lib "user32" (ByVal hwnd As Long) As Long

Dim mb_MediaFilesChange As Boolean  ' for gut_Param.Str15
Dim mi_MediaIconcurency As Integer ' for gut_Param.Str20
Dim ms_MediaCode As String
Dim ms_MediaPathCode As String
Dim ms_FileExtCode As String

Public b_Display As Boolean
Public mExtension As String

Dim ms_ScreenConstantsEntity As String

Dim mi_Tab As Integer
Dim ms_FileName As String
Dim mZipCode As Integer
Dim mPrevZipCode As Integer

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


Private Const SCREEN_NAME As String = "TechInfoFole"
Private ms_Language_Code                As String       'current user interface language
Private ml_U_Code                       As Long         'U_Code (GEN_Systems_Users) of logged user
Private mb_Initialized                  As Boolean      'framework is doing some own control manipulation, all events should handle
Dim mo_WshNetwork As Object                         ' JN task810
Dim C_MAPPED_DRIVE As String                        ' JN task810
Dim ms_DocumentServerDir As String                  ' JN task810
Dim ms_remotePath  As String                        ' JN task810
Dim ms_remoteUser  As String                        ' JN task810
Dim ms_remotePass  As String                        ' JN task810
Dim mb_drivemappedByApp As Boolean                  ' JN task810
Const C_ERROR_FILES As String = "Bad_Files\"        ' JN task810-B

Dim ms_MsgInfo As Variant

Private Const SEP = "®©"                            'standard armstrong separator
Private Const SEP1 As String = "®"
Private Const SEP2 As String = "©"

Private ms_Server As String
'name of database to connect
Private ms_Db As String
'user name when opening connection to sql server
Private ms_User As String
'user passwrod
Private ms_Pwd As String
'application name displayed in connection row in sql server manager
Private ms_App As String

Dim mBlob() As MediaBlob
Private Type MediaBlob
    NewZip As Long
    OldZip As Long
    MD_Type As String
'    MD_File As String
    FileName As String
    SourceFile As String
    MD_size As String
    BlobDelete As Boolean
End Type
Dim ml_MaxSize As Long

'Error handling
Private mNumber As Long
Private mSource As String

' task 409 - to remember old path
Private ms_oldPath As String

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

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

Property Let Language_Code(AString As String)
ms_Language_Code = AString
End Property

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

Public Function Load_A_COM() As Boolean
On Error GoTo errhandler
Dim lo_Control As Object
    
    Load_A_COM = False
    
    If mb_Initialized Then
        Call Err.Raise(ArmErr.CPTAlreadyInitialized)
    End If
    
    For Each lo_Control In Me.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
            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
        End Select
    Next
    
    If gl_CodePage <> 1252 And gl_CodePage <> 0 Then ChangeCharset Me
    
    ' read config
    mb_drivemappedByApp = False
    
    Dim ls_cfgPath As String
    Dim lsa_path() As String
    
    ls_cfgPath = GetAConfigData(mo_Db, "MMG_DocumentServerDir", prg.LoginName)
    If ls_cfgPath = "" Then
        ' remove tab for uploading hires files
        Call tbs_MediaType.Tabs.Remove(4)
    Else
        Set mo_WshNetwork = CreateObject("WScript.Network")
        Set mo_FSO = CreateObject("Scripting.FileSystemObject")
        
        lsa_path = Split(ls_cfgPath, SEP)
        
        If UBound(lsa_path) < 3 Then
            Call SendMessage(779, "Bag A_Config entry.", ms_Language_Code)
            Exit Function
        End If
        
        C_MAPPED_DRIVE = lsa_path(3)
        ms_DocumentServerDir = C_MAPPED_DRIVE & "\"
        If (ms_DocumentServerDir <> "") And right(ms_DocumentServerDir, 1) <> "\" Then ms_DocumentServerDir = ms_DocumentServerDir & "\"
        ms_remotePath = lsa_path(0)
        ms_remoteUser = lsa_path(1)
        ms_remotePass = lsa_path(2)
    
    End If

#If ENV = LIVE Then
    Set mo_ZIP = CreateObject("ArmSYSCOM.ArmZip")
#Else
    Set mo_ZIP = New ARMSYSCOMLib.ArmZip
#End If


    ReDim mBlob(4)
    Dim i As Long
    
    For i = 2 To 4
        Load drv_Drive(i)
        Load dir_Dir(i)
        Load fil_File(i)
        Load txt_File(i)
        
        drv_Drive(i).Top = drv_Drive(1).Top
        drv_Drive(i).Left = drv_Drive(1).Left
        drv_Drive(i).Visible = True
        
        dir_Dir(i).Top = dir_Dir(1).Top
        dir_Dir(i).Left = dir_Dir(1).Left
        dir_Dir(i).Visible = True
        
        fil_File(i).Top = fil_File(1).Top
        fil_File(i).Left = fil_File(1).Left
        fil_File(i).Visible = True
        
        txt_File(i).Text = ""
        txt_File(i).Top = txt_File(1).Top
        txt_File(i).Left = txt_File(1).Left
        txt_File(i).Visible = True
    Next i
    
    ' task 409 - remember last path. begin ...
    Dim lo_Registry As New Registry
    lo_Registry.RootKey = HKEY_CURRENT_USER
    If lo_Registry.OpenSubKey(REG_APP_NAME & REG_APP_DIALOG & Me.Name & "\", OK) Then
        Call lo_Registry.GetValue("ms_oldPath", ms_oldPath)
        For i = 1 To 4
            dir_Dir(i).Path = ms_oldPath
        Next i
    End If
    
    'Task 312 update August 2006
    If LCase(gs_Action) = "upd" Then GetSourceFile
    
    If mExtension <> "" Then
        fil_File(1).Pattern = ";*." & mExtension
        fil_File(2).Pattern = ";*." & mExtension
        fil_File(3).Pattern = ";*." & mExtension
        fil_File(4).Pattern = ";*." & mExtension
    Else
        fil_File(1).Pattern = "*." & mExtension
        fil_File(2).Pattern = "*." & mExtension
        fil_File(3).Pattern = "*." & mExtension
        fil_File(4).Pattern = "*." & mExtension
    End If
    
    If LCase(gs_Action) = "del" Or LCase(gs_Action) = "moreinfo" Then
        For i = 1 To 4
            txt_File(i).Enabled = False
            drv_Drive(i).Enabled = False
            dir_Dir(i).Enabled = False
            fil_File(i).Enabled = False
            tbs_MediaType.Enabled = False
        Next i
    End If
    
    Init_Var
    
    cmd_Save.Picture = LoadResPicture(RES_OK, 1)
    cmd_Quit.Picture = LoadResPicture(RES_QUIT, 1)
    
    GetScCsts
    GetInfoMedia
    
    If Not GetBlobLink Then Exit Function
    
    mBlob(1).MD_Type = "V"          ' thumbnail
    mBlob(2).MD_Type = "P"          ' preview
    mBlob(3).MD_Type = "F"          ' full
    If ms_DocumentServerDir <> "" Then
        mBlob(4).MD_Type = "H"      ' hires
    Else
        ' suppres hires files
        mBlob(4).MD_Type = ""       ' no hires
    End If
    
    If Not b_Display Then
        Me.Width = 5000
        tbs_MediaType.Visible = False
        tbs_MediaType.Tabs.Item(1).Selected = True
        mi_Tab = 1
    End If
    
    If Not MaxZipSize Then
        Call Err.Raise(C_ERRORRAISE + 155, "MaxZipSize", "Impossible to get max size")
    End If
    If ml_MaxSize = 0 Then
        Call Err.Raise(C_ERRORRAISE + 155, "ml_maxSize", "Impossible to get max size")
    End If

    MouseOn
    mb_Initialized = True
    Load_A_COM = True
    Exit Function
errhandler:
    ' task 580 begin
    If Err.Number = 76 Then
        ms_oldPath = "C:\"
        dir_Dir(i).Path = ms_oldPath
        Resume
    Else
        ' task 580 end
        Load_A_COM = False
        Call ErrorMessage("Load_A_COM")
    End If
End Function
Public Function Unload_A_COM() As Boolean
On Error GoTo errhandler
    
    Dim lo_Control As Object
    
    For Each lo_Control In Me.Controls
        Select Case UCase(TypeName(lo_Control))
        Case "ARMCOMBOBOX", "TOOLBARCONTROL", "ARMGRID", "ARMTREEVIEW", "ARMCHECKVIEW", "ARMPICKER"
            Call lo_Control.Unload_A_COM
        End Select
    Next
    
    ' Unmap drive
    If Not mo_WshNetwork Is Nothing And mb_drivemappedByApp Then
        Call mo_WshNetwork.RemoveNetworkDrive(C_MAPPED_DRIVE)
        Set mo_WshNetwork = Nothing
    End If
    
    Set mo_Db = Nothing
    Set mo_FSO = Nothing
    Set mo_ZIP = Nothing

    mb_Initialized = False
    Unload_A_COM = True
    Exit Function
errhandler:
    Unload_A_COM = False
    Call ErrorMessage("Unload_A_Com")
End Function

Private Function Control() As Boolean
Dim i As Integer

Control = KO

If txt_File(1).Text = "" And txt_File(2).Text = "" And txt_File(3).Text = "" And txt_File(4).Text = "" Then
    tbs_MediaType.Tabs.Item(1).Selected = True
    txt_File(1).SetFocus
    SendMessage 8, "Value must be filled in", gut_LangLogin.Code
    Exit Function
End If
    
Control = OK

End Function

Private Sub dir_Dir_Change(ai As Integer)

MouseOff
    ms_oldPath = dir_Dir(ai).Path
fil_File(ai).Path = dir_Dir(ai).Path
txt_File(ai).Text = ""
MouseOn

End Sub

Private Sub drv_Drive_Change(ai As Integer)

On Error GoTo Err_MediaDrive

MouseOff

txt_File(ai).Text = ""
dir_Dir(ai).Path = drv_Drive(ai).Drive
dir_Dir(ai).Enabled = OK
fil_File(ai).Enabled = OK

MouseOn
Exit Sub

Err_MediaDrive:
    Select Case Err
    Case "68"
        SendMessage 92, "Can't access to this drive, please select another one", gut_LangLogin.Code
        dir_Dir(ai).Enabled = KO
        fil_File(ai).Enabled = KO
    End Select
    MouseOn

End Sub

Private Sub fil_File_Click(ai As Integer)
Dim ls_File As String

On Error GoTo Err_File_Click
MouseOff

ls_File = dir_Dir(ai).Path
If Len(dir_Dir(ai).Path) > 3 Then
    ls_File = ls_File & "\"
End If
ls_File = ls_File & fil_File(ai)
txt_File(ai).Text = ls_File
If b_Display Then
    If (UCase(right(ls_File, 3)) = "JPG") Or (UCase(right(ls_File, 3)) = "GIF") Or (UCase(right(ls_File, 3)) = "BMP") Then
        If ai = 3 Or ai = 4 Then pic_Full.Picture = LoadPicture(ls_File)
        If ai = 2 Then pic_Preview.Picture = LoadPicture(ls_File)
        If ai = 1 Then pic_Thumb.Picture = LoadPicture(ls_File)
    End If
End If

MouseOn
Exit Sub

Err_File_Click:
If b_Display Then
    SendMessage 132, "Invalid Picture.", gut_LangLogin.Code, OK
    pic_Full.Picture = Nothing
End If
MouseOn

End Sub

Private Sub GetScCsts()
Dim ls_Field As String
Dim ls_Text As String
Dim ll_Statement As Long
Dim li_Status As Integer
Dim ls_req As String

On Error GoTo suite

ls_req = "EXEC Screen_Csts '" & ms_ScreenConstantsEntity & "','" & gut_LangLogin.Code & "'"
If SQLSubmit(gl_Environment, gl_Database, ll_Statement, ls_req) Then
    li_Status = SQL_SUCCESS
Else
    li_Status = SQL_ERROR
End If
Do While li_Status = SQL_SUCCESS Or li_Status = SQL_SUCCESS_WITH_INFO
    li_Status = SQLFetch(ll_Statement)
    If li_Status = SQL_SUCCESS Or li_Status = SQL_SUCCESS_WITH_INFO Then
        ls_Field = ODBCData(ll_Statement, 1)
        ls_Text = Left(ODBCData(ll_Statement, 2), 30)
        Select Case ls_Field
            Case "title": Caption = ls_Text
            Case "lbl_current": lbl_Current.Caption = ls_Text
        End Select
    End If
Loop
li_Status = SQLFreeStatement(ll_Statement, SQL_DROP)
Exit Sub

suite:
li_Status = SQLFreeStatement(ll_Statement, SQL_DROP)
StdError
End Sub

Private Sub Init_Var()
    mb_MediaFilesChange = KO
    ms_MediaCode = gs_MediaCode
    ms_FileExtCode = gut_Param.Str17
    mi_MediaIconcurency = CInt(gut_Param.Str20)
    ms_ScreenConstantsEntity = "TechinfoFile"
End Sub

Private Sub return_Var()
    gut_Param.Str15 = mb_MediaFilesChange
    If mb_MediaFilesChange = OK Then
        gut_Param.Str21 = txt_File(3).Text
        gut_Param.Str22 = txt_File(2).Text
    End If
    gut_Param.Str20 = CStr(mi_MediaIconcurency)
End Sub

Private Sub cmd_save_Click()
Dim lIdx As Long
Dim lb_BlobCreated As Boolean, lb_MediaToDelete As Boolean
Dim lb_TranOpened As Boolean, lTransName As String
Dim lo_Registry As New Registry

On Error GoTo Err_SaveMedia

MouseOff
'Read maxsize from Cap_DefaultValue table

mNumber = C_ERRORRAISE + 159
mSource = "/cmd_save_Click"

If Not Control Then
    MouseOn
    Exit Sub
Else
    If LCase(gs_Action) <> "del" Then
        gb_Return = False
        DirectorySel.show 1
        If gb_Return Then
            ms_MediaPathCode = gut_Param.Str14
        Else
            Exit Sub
        End If
    End If
End If

Select Case LCase(gs_Action)
Case "add"
    'Task 312 update August 2006
    For lIdx = 1 To UBound(mBlob)
        If txt_File(lIdx).Text <> "" Then
            mBlob(lIdx).FileName = txt_File(lIdx).Text
            
            'Create new blobs
            lb_BlobCreated = SendToBlob(mBlob(lIdx)) Or lb_BlobCreated
        End If
    Next

    lTransName = "AddMedia2"
    Call BeginTran(lTransName)
    lb_TranOpened = True
    
    Call Update_media
    
    Call Insert_Link
    
    Call CommitTran(lTransName)
    lb_TranOpened = False

Case "upd"
    'Task 312 update August 2006
    lb_MediaToDelete = False
    For lIdx = 1 To UBound(mBlob)
        If txt_File(lIdx).Text <> mBlob(lIdx).SourceFile And txt_File(lIdx).Text <> "" Then
            mBlob(lIdx).FileName = txt_File(lIdx).Text
            
            'Create new blobs when needed
            If mBlob(lIdx).FileName <> "" Then
                lb_BlobCreated = SendToBlob(mBlob(lIdx)) Or lb_BlobCreated
            End If
        End If
        
        'Media deleted
        If (mBlob(lIdx).OldZip <> 0) And (txt_File(lIdx).Text = "" Or mBlob(lIdx).NewZip <> 0) Then
            lb_MediaToDelete = True
            mBlob(lIdx).BlobDelete = True
        End If
    Next
        
    'Task 312 update August 2006: if update, delete first and then create
    If lb_BlobCreated Or lb_MediaToDelete Then
        lTransName = "MediaUpd"
        
        Call BeginTran(lTransName)
        lb_TranOpened = True
        
        Call Update_media
            
        'Only when  needed
        Call Delete_Link
        Call Insert_Link
        
        Call CommitTran(lTransName)
        lb_TranOpened = False
        
        ' delete old blobs after ACID transaction
        'Task 312 update August 2006: Delete existing blob when needed
        For lIdx = 1 To UBound(mBlob)
            If mBlob(lIdx).BlobDelete Then
                Debug.Assert (mBlob(lIdx).OldZip <> 0)
                Call DeleteBlob(mBlob(lIdx).OldZip)
           End If
        Next
    End If
End Select

mb_MediaFilesChange = OK
mi_MediaIconcurency = mi_MediaIconcurency + 1
return_Var

' task 409 - remember browse path. begin ...
lo_Registry.RootKey = HKEY_CURRENT_USER
If lo_Registry.CreateSubKey(REG_APP_NAME & REG_APP_DIALOG & Me.Name & "\", OK) Then
    Call lo_Registry.CreateValue("ms_oldPath", ms_oldPath, REG_SZ)
End If
' ... end


MouseOn
Call Me.Hide
Exit Sub

Err_SaveMedia:
    MouseOn
    
    ' penser aux orphelins créés dans la feuille précédente, et aux liens créés ici
    If LCase(gs_Action) = "add" Then
        gb_Return = False
    End If
    
    If lb_TranOpened Then
        If Not (RollbackTran(lTransName)) Then
            End
        End If
    End If
    
    If lb_BlobCreated Then
        For lIdx = 1 To UBound(mBlob)
            If mBlob(lIdx).NewZip > 0 Then Call DeleteBlob(mBlob(lIdx).NewZip)
        Next
    End If
    
    Select Case Err.Number - C_ERRORRAISE
    Case 155
        MsgBox "This file is bigger than :" & ml_MaxSize / 1000 & " Ko and will overload the network. Please select a lower one."
    Case 160
        SendMessage 160, "Failed to compress. Please contact your IT support.", gut_LangLogin.Code
    Case Else
        SendMessage 159, "Server may be too busy. Please try again before contacting your IT support.", gut_LangLogin.Code
    End Select
    
End Sub

Private Sub cmd_Quit_Click()

On Error GoTo Err_TechInfoQuit

MouseOff

Select Case gs_Action
Case "add"
    If SendMessage(90, "The data you just entered will be canceled, Continue ?", gut_LangLogin.Code, vbQuestion + vbYesNo, "Delete ") = vbYes Then
        return_Var
        gb_Return = False
    Else
        MouseOn
        Exit Sub
    End If
End Select

MouseOn
Call Me.Hide
Exit Sub

Err_TechInfoQuit:
    MouseOn
End Sub

Private Sub tbs_MediaType_Click()

Select Case UCase(tbs_MediaType.SelectedItem.Key)
Case "T"
    TabBehavior 1, True
    TabBehavior 2, False
    TabBehavior 3, False
    TabBehavior 4, False
    Me.Width = frm_File.Width
    pic_Thumb.Visible = True
    pic_Preview.Visible = False
    pic_Full.Visible = False
    If txt_File(1).Text = "" Then
        dir_Dir(1).Path = ms_oldPath
    End If
Case "P"
    TabBehavior 2, True
    TabBehavior 1, False
    TabBehavior 3, False
    TabBehavior 4, False
    Me.Width = frm_File.Width
    pic_Thumb.Visible = False
    pic_Preview.Visible = True
    pic_Full.Visible = False
    If txt_File(2).Text = "" Then
        dir_Dir(2).Path = ms_oldPath
    End If
Case "F"
    TabBehavior 3, True
    TabBehavior 1, False
    TabBehavior 2, False
    TabBehavior 4, False
    Me.Width = 10080
    pic_Thumb.Visible = False
    pic_Preview.Visible = False
    pic_Full.Visible = True
    If txt_File(3).Text = "" Then
        dir_Dir(3).Path = ms_oldPath
    End If
Case "H"
    TabBehavior 4, True
    TabBehavior 1, False
    TabBehavior 2, False
    TabBehavior 3, False
    Me.Width = 10080
    pic_Thumb.Visible = False
    pic_Preview.Visible = False
    pic_Full.Visible = True
    If txt_File(4).Text = "" Then
        dir_Dir(4).Path = ms_oldPath
    End If
End Select

If Not b_Display Then pic_Thumb.Visible = False

End Sub

Private Sub TabBehavior(ai_Tab As Integer, ab_Visible As Boolean)
    drv_Drive(ai_Tab).Visible = ab_Visible
    dir_Dir(ai_Tab).Visible = ab_Visible
    fil_File(ai_Tab).Visible = ab_Visible
    txt_File(ai_Tab).Visible = ab_Visible
End Sub

Private Function Send_File(ByVal aZipCode As Long, ByVal aFile As String) As Boolean
Dim ll_try     As Byte

On Error GoTo Err_SendFile
Send_File = False
  
'compression factor
Dim lCompression As Long

If UCase(mExtension) = "JPG" Or UCase(mExtension) = "GIF" Or UCase(mExtension) = "PDF" Then
    lCompression = 1
Else
    lCompression = 9
End If


'ALLOWS SOME RETRY IN CASE THERE IS COMS ISSUES TAHT AN BE RECOVERED BY A RETRY
For ll_try = 1 To 3
    If mo_Db.FileToBlobSQL("exec Media_Zip_ins " & aZipCode & ",?", aFile, lCompression) Then
        Send_File = True
        Exit For
    End If
Next

Exit Function
    
Err_SendFile:
    Call ErrorHandler("Send_File")
End Function

Private Function SendToBlob(ByRef aBlob As MediaBlob) As Boolean
Dim lKey As Long

On Error GoTo Err_SendToBlob

    SendToBlob = False
    
    If Not GetNextKey("Media_Zip", lKey) Then
        Call Err.Raise(C_ERRORRAISE + 158, "GetNextKey", "GetNextKey returned false!!")
    Else
        mZipCode = lKey
    End If
        
    If aBlob.MD_Type = "H" Then
        Debug.Assert (Not mo_WshNetwork Is Nothing)
        Debug.Assert (Not mo_FSO Is Nothing)
        ' hires files are transferred by filesystem
        
        Call InitMMGSharedDir
        
        If Not CheckBlobChanges(aBlob) Then
            Call MsgBox(MsgTextB(779, ms_Language_Code, "Cannot continue to update changes as previouse change is not written yet."))
            Exit Function
        End If
        
        Dim ls_Filename As String
        ls_Filename = ms_MediaCode & "_" & mZipCode & "_" & aBlob.MD_Type
        
        If Not mo_ZIP.CompressFile(aBlob.FileName, ms_DocumentServerDir & ls_Filename, 9, False) Then
            Call Err.Raise(C_ERRORRAISE + 149, "CompressFile", "File not sent")
        End If
        
    Else
        If Not Send_File(mZipCode, aBlob.FileName) Then
            Call Err.Raise(C_ERRORRAISE + 149, "Send_File", "File not sent")
        End If
    End If
    
    aBlob.NewZip = mZipCode
    SendToBlob = True
Exit Function

Err_SendToBlob:
    Call ErrorHandler("SendToBlob")
End Function

Private Function InitMMGSharedDir() As Boolean
On Error GoTo ErrorHandler
        
    If C_MAPPED_DRIVE <> "" Then
        ' check if C_MAPPED_DRIVE is mapped
        If Not NetworkDriveExists(mo_WshNetwork, C_MAPPED_DRIVE) Then
            
            Call MapNetworkDrive(mo_WshNetwork, C_MAPPED_DRIVE, ms_remotePath, ms_remoteUser, ms_remotePass)
        
            If Not mo_FSO.FolderExists(ms_DocumentServerDir) Then
                ReDim ms_MsgInfo(0, 1)
                ms_MsgInfo(0, 0) = "$PATH$"
                ms_MsgInfo(0, 1) = ms_DocumentServerDir
                Call MsgBox(MsgTextB(777, ms_Language_Code, "Server directory does not exists: $PATH$", ms_MsgInfo))
                Exit Function
            End If
        Else
            ' test if curently mapped drive points to service dir on the other side
            If Not mo_FSO.FolderExists(ms_DocumentServerDir & C_ERROR_FILES) Then
                ' drive is not propably pointing ok
                Call MsgBox(MsgTextB(778, ms_Language_Code, "Existing mapped drive is propably not configured correctly!. Upload for Hires pictures may not work."))
            End If
        End If
    Else
        ' in this case we upload using direct network path
        ms_DocumentServerDir = ms_remotePath
        If (ms_DocumentServerDir <> "") And right(ms_DocumentServerDir, 1) <> "\" Then ms_DocumentServerDir = ms_DocumentServerDir & "\"
    End If

    Exit Function
ErrorHandler:
    Call ErrorHandler("InitMMGSharedDir")
End Function

Private Function CheckBlobChanges(ByRef aBlob As MediaBlob) As Boolean
On Error GoTo ErrorHandler

    CheckBlobChanges = False

    ' check if there is some file in folder for the same ms_MediaCode
    Dim lo_File As Object
    For Each lo_File In mo_FSO.GetFolder(ms_DocumentServerDir).Files
        If lo_File.Name Like ms_MediaCode & "_*_" & aBlob.MD_Type Then
            ' the file from previuose update still wait for MMG service to process!
            Exit Function
       End If
    Next lo_File
    
    Dim ll_oldZip As Long
    Dim ll_Cursor As Long
    
    ll_oldZip = 0
    ' check if oldZip is equal to zip linked in database
    
    ll_Cursor = OpenSQLSafe(mo_Db, "SELECT Zip_code FROM Media_BlobLink WHERE MD_code ='" & ms_MediaCode & "' AND MediaType='" & aBlob.MD_Type & "'")
    
    If Not mo_Db.EOF(ll_Cursor) Then
        ll_oldZip = mo_Db.GetFields(ll_Cursor, "Zip_code")
    End If
    
    Call mo_Db.Close(ll_Cursor)
    ll_Cursor = 0
    
    If ll_oldZip <> aBlob.OldZip Then
        ' there is a change since loading the detail ( probalby MMG service uploaded new zip )
        If aBlob.OldZip <> 0 Then
            ' this state normally should not appear!
            ' we cannot continue as it will create duplicity!
            Exit Function
        End If
        
        aBlob.OldZip = ll_oldZip            ' update the structure and the process afre SentToBlob will delete old zip
    End If
    
    CheckBlobChanges = True
    Exit Function
ErrorHandler:
    Call ErrorHandler("CheckBlobChanges")
End Function

Private Sub MapNetworkDrive(ByRef ao_WshNetwork As Object, ByVal as_drive As String, ByVal as_remotePath As String, ByVal as_User As String, ByVal as_pass As String)
On Error GoTo ErrorHandler
    If as_User <> "" Then
        Call mo_WshNetwork.MapNetworkDrive(as_drive, as_remotePath, False, as_User, as_pass)
    Else
        Call mo_WshNetwork.MapNetworkDrive(as_drive, as_remotePath, False)
    End If
    mb_drivemappedByApp = True
    Exit Sub
ErrorHandler:
    Call MsgBox(Err.Description & "num = " & Err.Number)
    ' mapping failed
    ReDim ms_MsgInfo(1, 1)
    ms_MsgInfo(0, 0) = "$DRIVE$"
    ms_MsgInfo(0, 1) = as_drive
    ms_MsgInfo(1, 0) = "$PATH$"
    ms_MsgInfo(1, 1) = as_remotePath
    Call MsgBox(MsgTextB(666, ms_Language_Code, "Application cannot map drive $DRIVE$ to $PATH$. Try it manually or call application support please.", ms_MsgInfo))
End Sub

Private Function NetworkDriveExists(ByRef ao_WshNetwork As Object, ByVal as_drive As String) As Boolean
On Error GoTo ErrorHandler

    Dim lo_Drives As Object
    Dim ll_Index As Long
    NetworkDriveExists = False
    
    Set lo_Drives = ao_WshNetwork.EnumNetworkDrives
    For ll_Index = 0 To lo_Drives.Count - 1 Step 2
        If lo_Drives.Item(ll_Index) = as_drive Then
            ' drive exists
            NetworkDriveExists = True
            Exit Function
        End If
    Next

    Exit Function
ErrorHandler:
    Call ErrorHandler("NetworkDriveExists")
End Function

Private Function DeleteBlob(aZipCode As Long) As Boolean
Dim ls_req As String

On Error GoTo Err_DeleteBlob

    DeleteBlob = KO

    mNumber = C_ERRORRAISE + 156
    mSource = "DeleteBlob"

    ls_req = "EXEC Media_Zip_del '" & aZipCode & "'"

    Call ExecuteSQLSafe(mo_Db, ls_req, 1)

    DeleteBlob = True
Exit Function

Err_DeleteBlob:
    Call ErrorHandler("DeleteBlob")
End Function



' Give the nextkey of an DB table
' NOTICE : MUSTN'T BE CALLED INTO A ACID TRANSACTION BECAUSE DISPLAY ERROR MESSAGE !
Private Function GetNextKey(ByVal as_tableName, ByRef al_Key As Long, Optional ByVal al_TryCount As Integer = 5) As Boolean

On Error GoTo onError
    
Dim ls_Request As String

mNumber = C_ERRORRAISE + 158
mSource = "GetNextKey"

ls_Request = "SELECT Table_Key FROM SYS_TablesKeys WHERE Table_Name = '" & as_tableName & "'"

' STEP 1 - Read the current key
Dim lc_Cursor As Long, ll_CurrentKey As Long, ll_NewKey As Long
lc_Cursor = OpenSQLSafe(mo_Db, ls_Request)

' STEP 2 - Calculate the new
ll_CurrentKey = mo_Db.GetFields(lc_Cursor, 0)
Call mo_Db.Close(lc_Cursor)
ll_NewKey = ll_CurrentKey + 1
    
    
' STEP 3 - Try to register the new key
ls_Request = "UPDATE SYS_TablesKeys SET Table_Key = " & ll_NewKey & vbCrLf & _
            "WHERE Table_Name = '" & as_tableName & "' AND Table_Key = " & ll_CurrentKey

Call ExecuteSQLSafe(mo_Db, ls_Request)

If mo_Db.SQLRowsAffected = 1 Then
    ' That's all folks !
    al_Key = ll_NewKey
    GetNextKey = True
Else
    ' No luck, try again !
    If al_TryCount = 0 Then ' Too much tries, server should busy...
        GetNextKey = False
    Else
        GetNextKey = GetNextKey(as_tableName, al_Key, al_TryCount - 1)
    End If
End If

Exit Function

onError:
    mo_Db.Close (lc_Cursor)
    Call ErrorHandler("GetNextKey")
End Function

Private Sub Insert_Link()
Dim lReq As String, lIdx As Long
Const C_REQ = "EXEC Media_BlobLink_ins '$MD_Code$', $ZipCode$, '$Type$', 0, 0"

On Error GoTo Err_Insert_Link

    For lIdx = 1 To UBound(mBlob)
        
        If mBlob(lIdx).NewZip > 0 And mBlob(lIdx).MD_Type <> "H" Then
            lReq = Replace(C_REQ, "$MD_code$", QuoteParam(ms_MediaCode), , , vbTextCompare)
            lReq = Replace(lReq, "$ZipCode$", mBlob(lIdx).NewZip, , , vbTextCompare)
            lReq = Replace(lReq, "$Type$", mBlob(lIdx).MD_Type, , , vbTextCompare)
            
            Call ExecuteSQLSafe(mo_Db, lReq, 1)
        End If
    Next
    
Exit Sub

Err_Insert_Link:
    Call ErrorHandler("Insert_Link")
End Sub

Private Function GetBlobLink() As Boolean
Dim ls_req As String
Dim ll_Cursor As Long

On Error GoTo Err_GetBlobLink
  
    GetBlobLink = False
      
    ls_req = "SELECT Zip_code,MediaType FROM Media_BlobLink WHERE MD_code ='" & ms_MediaCode & "'"
    
    ll_Cursor = OpenSQLSafe(mo_Db, ls_req)
    
    mBlob(1).OldZip = 0
    mBlob(2).OldZip = 0
    mBlob(3).OldZip = 0
    mBlob(4).OldZip = 0
    
    mBlob(1).NewZip = 0
    mBlob(2).NewZip = 0
    mBlob(3).NewZip = 0
    mBlob(4).NewZip = 0
    
    Call mo_Db.First(ll_Cursor)
    While Not mo_Db.EOF(ll_Cursor)
        Select Case UCase(mo_Db.GetFields(ll_Cursor, "MediaType"))
        Case "V": mBlob(1).OldZip = mo_Db.GetFields(ll_Cursor, "Zip_code")
        Case "P": mBlob(2).OldZip = mo_Db.GetFields(ll_Cursor, "Zip_code")
        Case "F": mBlob(3).OldZip = mo_Db.GetFields(ll_Cursor, "Zip_code")
        Case "H": mBlob(4).OldZip = mo_Db.GetFields(ll_Cursor, "Zip_code")
        End Select
        
        Call mo_Db.Next(ll_Cursor)
    Wend
    
    Call mo_Db.Close(ll_Cursor)
    
    GetBlobLink = True
Exit Function

Err_GetBlobLink:
    Call mo_Db.Close(ll_Cursor)
    
    Call ErrorHandler("GetBlobLink")
End Function

'Private Function Update_Link(aBlob() As MediaBlob) As Boolean
'Dim lReq As String, lCursor As Long
'Dim i As Integer

'On Error GoTo Err_Update_Link

'Update_Link = False

'For i = 1 To 4
'    lReq = "UPDATE Media_BlobLink " _
'        & "SET Zip_code = " & aBlob(i).NewZip & ", Z_last_upd = getdate(), Z_last_upd_user = SUSER_SNAME()," _
'        & " WHERE MD_code = '" & ms_MediaCode & "' AND Zip_code =" & aBlob(i).OldZip
    
'    Call ExecuteSQLSafe(mo_DB, lReq, 1)

'Next i

'Update_Link = True
'Exit Function

'Err_Update_Link:
'    Call ErrorHandler("update_Link")
'End Function


Private Function MaxZipSize() As Boolean
Dim ls_req As String
Dim ll_Cursor As Long

On Error GoTo Err_MaxZipSize

MaxZipSize = False
ml_MaxSize = 0

ls_req = "SELECT DFT_Code FROM Cap_DefaultValue WHERE DFT_ScreenName ='frm_techinfofile' " _
    & " AND DFT_FieldName ='MaxZipSize' AND Language_code ='E' AND CT_code='GB'"

ll_Cursor = OpenSQLSafe(mo_Db, ls_req)

ml_MaxSize = CLng(mo_Db.GetFields(ll_Cursor, 0))
mo_Db.Close ll_Cursor

MaxZipSize = True
Exit Function

Err_MaxZipSize:
    mo_Db.Close ll_Cursor
    Call ErrorHandler("MaxZipSize")
End Function

Private Sub txt_File_KeyDown(Index As Integer, KeyCode As Integer, Shift As Integer)

If KeyCode = 46 Then txt_File(Index).Text = ""

End Sub

Private Sub Update_media()
Dim lReq As String, lIdx As Long
Dim lStatement As Long, lStatus As Integer, lLngRows As Long
Dim ls_Size As String
Const C_REQ = "EXEC media_upd2 '$MD_code$','$Ext$','$Size$','$Source1$','$Source2$','$Source3$','$Source4$',$MD_Path$,$Conc$"

On Error GoTo Err_UpdMedia

mNumber = C_ERRORRAISE + 150
mSource = "Update_Media"

lReq = C_REQ
lReq = Replace(lReq, "$MD_code$", QuoteParam(ms_MediaCode), , , vbTextCompare)
lReq = Replace(lReq, "$Ext$", mExtension, , , vbTextCompare)

If LCase(gs_Action) = "upd" Then
    ls_Size = mBlob(1).MD_size
Else
For lIdx = 4 To 1 Step -1
    If txt_File(lIdx).Text <> "" Then
        ls_Size = right(Str(FileLen(txt_File(lIdx).Text)), Len(Str(FileLen(txt_File(lIdx).Text))) - 1)
        Exit For
    End If
Next
End If
lReq = Replace(lReq, "$Size$", ls_Size, , , vbTextCompare)

lReq = Replace(lReq, "$Source1$", QuoteParam(txt_File(3).Text), , , vbTextCompare)
lReq = Replace(lReq, "$Source2$", QuoteParam(txt_File(2).Text), , , vbTextCompare)
lReq = Replace(lReq, "$Source3$", QuoteParam(txt_File(1).Text), , , vbTextCompare)
lReq = Replace(lReq, "$Source4$", QuoteParam(txt_File(4).Text), , , vbTextCompare)      ' JN task810

lReq = Replace(lReq, "$MD_Path$", ms_MediaPathCode, , , vbTextCompare)
lReq = Replace(lReq, "$Conc$", mi_MediaIconcurency, , , vbTextCompare)

Call ExecuteSQLSafe(mo_Db, lReq)

Exit Sub

Err_UpdMedia:
    Call ErrorHandler("Update_media")
End Sub

Private Sub GetInfoMedia()
Dim lReq As String, lCursor As Long

On Error GoTo Err_InfoMedia

lReq = "EXEC Media_sel '" & ms_MediaCode & "'"          ' JN bugfix

lCursor = OpenSQLSafe(mo_Db, lReq)

Select Case mo_Db.GetFields(lCursor, 0)
Case "T"
    tbs_MediaType.Tabs.Item(1).Selected = True
    mi_Tab = 1
Case "P"
    tbs_MediaType.Tabs.Item(2).Selected = True
    mi_Tab = 2
Case "F"
    tbs_MediaType.Tabs.Item(4).Selected = True
    mi_Tab = 4
Case Else
    tbs_MediaType.Tabs.Item(3).Selected = True
    mi_Tab = 3
End Select

mo_Db.Close lCursor
Exit Sub

Err_InfoMedia:
    Call ErrorHandler("GetInfoMedia")
End Sub

Private Sub Delete_Link()
Dim lIdx As Long
Const C_REQ As String = "Media_BlobLink_del2 '$MD_code$',$Zip$"
Dim lReq As String

On Error GoTo Err_Del_Link

    For lIdx = 1 To UBound(mBlob)
        If mBlob(lIdx).OldZip <> 0 And mBlob(lIdx).BlobDelete Then
        
            lReq = Replace(C_REQ, "$MD_code$", QuoteParam(ms_MediaCode), , , vbTextCompare)
            lReq = Replace(lReq, "$Zip$", mBlob(lIdx).OldZip)
            
            Call ExecuteSQLSafe(mo_Db, lReq, 1)
        End If
    Next

Exit Sub

Err_Del_Link:
    Call ErrorHandler("Delete_OneLink")
End Sub

Private Sub GetSourceFile()
Dim lReq As String
Dim lCursor As Long, ll_Nb As Long, ll_Idx As Long

On Error GoTo Err_InfoMedia

lReq = "EXEC media_dtl '$MD_code$'"
lReq = Replace(lReq, "$MD_code$", QuoteParam(gs_MediaCode), , , vbTextCompare)

lCursor = OpenSQLSafe(mo_Db, lReq, 1)

'JN task810
mBlob(4).SourceFile = mo_Db.GetFields(lCursor, "MD_SourceFile4")        ' hires
mBlob(3).SourceFile = mo_Db.GetFields(lCursor, "MD_SourceFile")        ' full
mBlob(2).SourceFile = mo_Db.GetFields(lCursor, "MD_SourceFile2")        ' preview
mBlob(1).SourceFile = mo_Db.GetFields(lCursor, "MD_SourceFile3")        ' thumbnail

For ll_Idx = 1 To UBound(mBlob)
    mBlob(ll_Idx).MD_size = mo_Db.GetFields(lCursor, "MD_size")
    txt_File(ll_Idx).Text = mBlob(ll_Idx).SourceFile
    mBlob(ll_Idx).BlobDelete = False
Next

mo_Db.Close lCursor
Exit Sub

Err_InfoMedia:
    Call mo_Db.Close(lCursor)
    Call ErrorHandler("GerSourceFile")
End Sub

' Return the result of a SQL request
' Convert SQL runtime errors and process errors to VB Error
#If ENV = LIVE 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 ENV = LIVE 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 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
' Standard error handler
Private Sub ErrorHandler(ByVal as_Fct As String)
  
    Call Err.Raise(Err.Number, 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, vbCritical, App.Title & " " & App.Major & "." & App.Minor & "." & App.Revision)
    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 = ReplacePlaceHolder(LOG_REQUEST, "$UCODE$", CStr(ml_U_Code))
    ls_req = ReplacePlaceHolder(ls_req, "$LOGTYPE$", SqlStr(as_LogType))
    ls_req = ReplacePlaceHolder(ls_req, "$MSG$", Left(Trim(SqlStr(ls_Msg)), 4000))
    ls_req = ReplacePlaceHolder(ls_req, "$APP$", Left(Trim(SqlStr(ls_Source)), 50))
    
    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, vbCritical, App.Title & " " & App.Major & "." & App.Minor & "." & App.Revision)
        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

Private Sub LockScreen(ByVal ab_lock 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
    Static ll_Count As Long
    Static ll_Mousepointer As Long
    Static lb_Locked As Boolean
      
      
    ll_Count = ll_Count + IIf(ab_lock, 1, -1)
    Debug.Assert (ll_Count >= 0)
    
    ' First lock
    If Not lb_Locked And ab_lock Then
        ll_Mousepointer = Screen.MousePointer
        Screen.MousePointer = vbHourglass
        Me.Enabled = False
        LockWindowUpdate Me.hwnd
        lb_Locked = True
    End If
    
    ' Unlock
    If ll_Count = 0 Then
        DoEvents ' Flush events
        LockWindowUpdate 0
        Me.Enabled = True
        Me.Refresh ' Repaint immediately
        Screen.MousePointer = ll_Mousepointer
        lb_Locked = False
    End If
    
    Err.Number = ll_errNumber
    Err.Source = ls_ErrSrc
    Err.Description = ls_ErrDesc
    Exit Sub
errhandler:
    Call ErrorHandler("LockScreen")
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:
    'try to log error
    Call LogMessage("BeginTran: " & as_Tran)
    Call mo_Db.Disconnect
    Set mo_Db = Nothing
    MsgBox "A Fatal error occured in " & SCREEN_NAME & ".BeginTran, your application will be close. Please contact your IT support", vbCritical, App.Title & " " & App.Major & "." & App.Minor & "." & App.Revision
    End
End Function

Private Function CommitTran(as_Tran As String) As Boolean

On Error GoTo errhandler
    CommitTran = False
    Call ExecuteSQLSafe(mo_Db, "COMMIT TRANSACTION " & as_Tran)

    CommitTran = True
    Exit Function
    
errhandler:
    'try to log error
    Call LogMessage("CommitTran: " & as_Tran)
    Call mo_Db.Disconnect
    Set mo_Db = Nothing
    MsgBox "A Fatal error occured in " & SCREEN_NAME & ".CommitTran, your application will be close. Please contact your IT support", vbCritical, App.Title & " " & App.Major & "." & App.Minor & "." & App.Revision
    End

End Function

Private Function RollbackTran(as_Tran As String) As Boolean
    
    Dim ll_errNumber As Long, ls_ErrSource As String, ls_ErrDesc As String
    ll_errNumber = Err.Number
    ls_ErrSource = 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_ErrSource
    Err.Description = ls_ErrDesc

    RollbackTran = True
    Exit Function
    
errhandler:
    'try to log error
    Call LogMessage("RollbackTran: " & as_Tran)
    Call mo_Db.Disconnect
    Set mo_Db = Nothing
    MsgBox "A Fatal error occured in " & SCREEN_NAME & ".RollbackTran, your application will be close. Please contact your IT support", vbCritical, App.Title & " " & App.Major & "." & App.Minor & "." & App.Revision
    End
End Function

Private Function SqlInt(ByVal av_Data As Variant) As String
On Error GoTo errhandler

    SqlInt = "NULL"
    If IsNull(av_Data) Then av_Data = ""
    If Trim(CStr(av_Data)) <> "" Then
        SqlInt = CStr(av_Data)
    End If
    Exit Function
errhandler:
    Call ErrorHandler("SqlInt")
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

Private Function SQLDateTime(ByVal av_Data As Variant) As String
On Error GoTo errhandler

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

Private Function SqlStr(ByVal as_Data As String) As String
On Error GoTo errhandler

    SqlStr = "'" & Replace(as_Data, "'", "''") & "'"
    Exit Function
errhandler:
    Call ErrorHandler("SqlStr")
End Function

Private Function GetComboKey(ByVal ao_Combo As ArmCombobox) As String
On Error GoTo errhandler

    GetComboKey = ""
    If Not (ao_Combo.SelectedItem Is Nothing) Then
        GetComboKey = Trim(CStr(ao_Combo.SelectedItem.Key))
    End If
    Exit Function
errhandler:
    Call ErrorHandler("GetComboKey")
End Function

Private Function ReplacePlaceHolder(ByVal as_Request As String, ByVal as_PlaceHolder As String, ByVal as_DefaultValue As String) As String
On Error GoTo errhandler
    
    ReplacePlaceHolder = Replace(as_Request, as_PlaceHolder, as_DefaultValue, , , vbTextCompare)
    Exit Function
errhandler:
    Call ErrorHandler("ReplacePlaceholder")
End Function


Private Function GetAConfigData(ByRef ao_Db As ArmDb, ByVal as_Key As String, ByVal as_loginName As String) As String
On Error GoTo errhandler

    GetAConfigData = ""
    
    Const C_REQ As String = "SELECT A.CFG_Value" & vbCrLf & _
                            "FROM security_identity SI" & vbCrLf & _
                            "    INNER JOIN A_Config A ON CFG_Key='$KEY$'+'_' + SI.CT_code" & vbCrLf & _
                            "WHERE SI.login_Name = '$LOGIN$'"
    Dim ll_Cursor As Long
    Dim ls_req As String
    
    ls_req = Replace(C_REQ, "$KEY$", as_Key, , , vbTextCompare)
    ls_req = Replace(ls_req, "$LOGIN$", as_loginName, , , vbTextCompare)
    
    ll_Cursor = OpenSQLSafe(ao_Db, ls_req)
    
    If ao_Db.RowCount(ll_Cursor) = 1 Then
        GetAConfigData = ao_Db.GetFields(ll_Cursor, "CFG_Value")
    End If
    Call ao_Db.Close(ll_Cursor)
    
    Exit Function
errhandler:
    Call ao_Db.Close(ll_Cursor)
    Call ErrorHandler("GetAConfigData")
End Function

Function MsgTextB(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$'"

    MsgTextB = ""
    
    Dim lRequest As String
    lRequest = ReplacePlaceHolder(DB_REQ, "$id$", aID)
    lRequest = ReplacePlaceHolder(lRequest, "$lang$", aLang)
    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
    
    
    MsgTextB = lBuffer
    Exit Function
errhandler:
    mo_Db.Close (lData)
    Call MsgBox("Connection failure accessing message information.", vbCritical, App.Title & " " & App.Major & "." & App.Minor & "." & App.Revision)
    MsgTextB = aDefault
End Function

