VERSION 5.00
Begin VB.UserControl FocusProducts 
   ClientHeight    =   8340
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   12240
   ScaleHeight     =   8340
   ScaleWidth      =   12240
   Begin VB.Frame fra_container 
      Height          =   8175
      Left            =   120
      TabIndex        =   0
      Top             =   0
      Width           =   12015
      Begin VB.CommandButton btn_Exit 
         Caption         =   "#EXIT"
         Height          =   732
         Left            =   10800
         Style           =   1  'Graphical
         TabIndex        =   2
         Top             =   240
         Visible         =   0   'False
         Width           =   852
      End
      Begin Project1.ArmGrid grd_FocusProduct 
         Height          =   3375
         Left            =   3120
         TabIndex        =   1
         Tag             =   "grd_FocusProduct"
         Top             =   1080
         Visible         =   0   'False
         Width           =   8535
         _ExtentX        =   15055
         _ExtentY        =   5953
      End
      Begin Project1.ArmTreeView tvw_Main 
         Height          =   7815
         Left            =   120
         TabIndex        =   3
         Top             =   240
         Visible         =   0   'False
         Width           =   2895
         _ExtentX        =   5106
         _ExtentY        =   13785
      End
      Begin Project1.ArmGrid grd_Items 
         Height          =   3375
         Left            =   3120
         TabIndex        =   4
         Tag             =   "grd_Items"
         Top             =   4440
         Visible         =   0   'False
         Width           =   8535
         _ExtentX        =   15055
         _ExtentY        =   5953
      End
   End
End
Attribute VB_Name = "FocusProducts"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Private Declare Function LoadBitmap Lib "user32" Alias "LoadBitmapA" (ByVal hInstance As Long, ByVal lpBitmapName As String) As Long
Private Declare Function LoadIcon Lib "user32" Alias "LoadIconA" (ByVal hInstance As Long, ByVal lpIconName As String) As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (lpPictDesc As PictDesc, riid As Guid, ByVal fPictureOwnsHandle As Long, ipic As IPicture) As Long

Private Declare Function LoadLibrary Lib "Kernel32" Alias "LoadLibraryA" _
   (ByVal lpLibFileName As String) As Long
Private Declare Function FreeLibrary Lib "Kernel32" (ByVal hLibModule As Long) As Long
Private Declare Function LoadStringFromDLL Lib "user32" Alias "LoadStringA" _
   (ByVal hInstance As Long, ByVal wID As Long, ByVal lpBuffer As String, _
    ByVal nBufferMax As Long) As Long

Private Type PictDesc
    cbSizeofStruct As Long
    picType As Long
    hImage As Long
    xExt As Long
    yExt As Long
End Type

Private Type Guid
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type

Private Const ICON_DLL = "c:\arm_apps\dll\A_icons.dll"
Private Const TREEVIEW_INDEX = 1001

Private Const SEP As String = "®©"
Private Const SCREEN_NAME As String = "FOCUS_PROD"

Const CL_COLOR_ENABLED As Long = &H80000005
Const CL_COLOR_DISABLED As Long = &H8000000F
Const C_ERRORRAISE As Long = 50000
    
Private Const TB_ITEM_VIEW As Long = 0
Private Const TB_ITEM_ADD As Long = 1
Private Const TB_ITEM_UPDATE As Long = 2
Private Const TB_ITEM_DELETE As Long = 3

Public Event quit()

#If LIVE Then
Private mo_Db As Object
Private mo_DbErr As Object
#Else
Private mo_Db As ArmDb
Private mo_DbErr As ArmDb
#End If

Private mb_Initialized As Boolean
Private ms_LoginName As String
Private ms_Language_Code As String
Private ml_U_Code As Long

Private Enum eMode
    emList = 0
    emView = 1
    emAdd = 2
    emUpdate = 3
    emDelete = 4
End Enum

Private mOldMode As eMode
Private mMode As eMode

Public Property Let Visible(ByVal aVisible As Boolean)
    UserControl.Extender.Visible = aVisible
End Property
Public Property Get Visible() As Boolean
    Visible = UserControl.Extender.Visible
End Property

Public Property Let Top(ByVal aTop As Single)
    UserControl.Extender.Top = aTop
End Property
Public Property Get Top() As Single
    Top = UserControl.Extender.Top
End Property

Public Property Let Height(ByVal aHeight As Single)
    UserControl.Extender.Height = aHeight
End Property
Public Property Get Height() As Single
    Height = UserControl.Extender.Height
End Property

Public Property Let Left(ByVal aLeft As Single)
    UserControl.Extender.Left = aLeft
End Property
Public Property Get Left() As Single
    Left = UserControl.Extender.Left
End Property

Public Property Let Width(ByVal aWidth As Single)
    UserControl.Extender.Width = aWidth
End Property

Public Property Get Width() As Single
    Width = UserControl.Extender.Width
End Property

Public Sub Move(ByVal aLeft As Single, ByVal aTop As Single, ByVal aWidth As Single, ByVal aHeight As Single)
    Call UserControl.Extender.Move(aLeft, aTop, aWidth, aHeight)
End Sub

Public Sub ZOrder()
  Call UserControl.Extender.ZOrder
End Sub

Public Function Load_A_Com() As Boolean
Dim ll_hInst As Long
Dim lv_Columns As Variant
Dim lv_Request As Variant
On Error GoTo ErrHandler
    mMode = emList
    Set tvw_Main.ArmDb = mo_Db
    tvw_Main.Language = ms_Language_Code
    Call tvw_Main.Load_A_Com
    tvw_Main.Levels = 3
    tvw_Main.UseImages = True
    tvw_Main.Images = Array(1, 1, 1)
    tvw_Main.SelectedImages = Array(2, 2, 2)
    ReDim lv_Request(2)
    lv_Request(0) = ReplaceHolders("exec Cap_Rpt_FocusProduct_Year_tv $LoginName$")
    lv_Request(1) = ReplaceHolders("exec Cap_Rpt_FocusProduct_BMK_tv $0$,$Language_Code$,$LoginName$")
    lv_Request(2) = ReplaceHolders("exec Cap_Rpt_FocusProduct_FP_tv $0@0$,$0$")
    tvw_Main.NodeRequests = lv_Request
    lv_Request(0) = ReplaceHolders("")
    lv_Request(1) = ReplaceHolders("exec Cap_Rpt_FocusProduct_grd $0@0$,$Language_Code$,$LoginName$,$0$,NULL")
    lv_Request(2) = ReplaceHolders("exec Cap_Rpt_FocusProduct_grd $0@0$,$Language_Code$,$LoginName$,$1@0$,$0$")
    tvw_Main.GridRequests = lv_Request
    If Not tvw_Main.LoadTree(LoadTypeChildsDemand) Then
      'debug.print "tvw_Main.LoadTree error"
      Call Unload_A_Com
      End
    End If
    tvw_Main.Visible = True
    btn_exit.Visible = True
    grd_FocusProduct.Visible = False
    Set grd_FocusProduct.ArmDb = mo_Db
    grd_FocusProduct.Load_A_Com
    grd_FocusProduct.AllowExcelExport = True
    grd_FocusProduct.ExportTitles = True
    grd_FocusProduct.MultiSelect = False
    ReDim lColumns(10)
    lColumns(0) = Join(Array("FPYear", 700, 0, "FPYear", "#Year"), SEP)
    lColumns(1) = Join(Array("BMK_Desc", 1000, 0, "BMK_Desc", "#Business market"), SEP)
    lColumns(2) = Join(Array("FP_ID", 0, 0, "FP_ID", "#FP_ID"), SEP)
    lColumns(3) = Join(Array("FPD_ID", 0, 0, "FPD_ID", "#FPD_ID"), SEP)
    lColumns(4) = Join(Array("FP_Name", 1200, 0, "FP_Name", "#Focus product"), SEP)
    lColumns(5) = Join(Array("S_Code", 1200, 0, "S_Code", "#Product Code"), SEP)
    lColumns(6) = Join(Array("PS_Desc", 1200, 0, "PS_Desc", "#Product segmentation"), SEP)
    lColumns(7) = Join(Array("PF_Desc", 1200, 0, "PF_Desc", "#Product families"), SEP)
    lColumns(8) = Join(Array("PE_Desc", 1200, 0, "PE_Desc", "#Product edge"), SEP)
    lColumns(9) = Join(Array("BM_Desc", 1200, 0, "BM_Desc", "#Base material"), SEP)
    lColumns(10) = Join(Array("SBM_Desc", 1200, 0, "SBM_Desc", "#Super base material"), SEP)
    If Not grd_FocusProduct.SetColumns(lColumns) Then
      'debug.print "grd_FocusProduct.SetColumns error"
      Call Unload_A_Com
      End
    End If
    
    grd_Items.Visible = False
    Set grd_Items.ArmDb = mo_Db
    grd_Items.Load_A_Com
    grd_Items.AllowExcelExport = True
    grd_Items.ExportTitles = True
    grd_Items.MultiSelect = False
    ReDim lColumns(1)
    lColumns(0) = Join(Array("S_Code", 2000, 1, "S_Code", "#S_Code"), SEP)
    lColumns(1) = Join(Array("S_Desc", 4000, 1, "S_Desc", "#S_Desc"), SEP)
    If Not grd_Items.SetColumns(lColumns) Then
      Call Unload_A_Com
      End
    End If
    Call LoadLabels(UserControl.Controls, SCREEN_NAME, ms_Language_Code)
    ll_hInst = LoadLibrary(ICON_DLL)
    If ll_hInst <> 0 Then
      btn_exit.Picture = LoadImageFromFile(ll_hInst, 123, vbPicTypeIcon)
      Call FreeLibrary(ll_hInst)
    End If
    btn_exit.Picture = LoadResPicture(RES_QUIT, 1)
    If btn_exit.Picture <> 0 Then btn_exit.Caption = ""
    Call InitCtrlSize
    mb_Initialized = True
    Load_A_Com = True
    Exit Function
ErrHandler:
    Load_A_Com = False
    'debug.print Err.Number & " : " & Err.Description
End Function

Public Function Unload_A_Com() As Boolean
    
On Error GoTo ErrHandler

    Call tvw_Main.Unload_A_Com
    Call grd_FocusProduct.Unload_A_Com
    Call grd_Items.Unload_A_Com
    
    If mo_Db.CursorCount <> 0 Then
        ''debug.print "cursors : " & mo_Db.CursorCount
    End If
    
    Set mo_Db = Nothing
    Set mo_DbErr = Nothing
    
    Unload_A_Com = True
    Exit Function
ErrHandler:
    Unload_A_Com = False
    ''debug.print Err.Number & " : " & Err.Description
End Function


#If LIVE Then
Public Property Set Db(ByRef ao_Db As Object)
#Else
Public Property Set Db(ByRef ao_Db As ArmDb)
#End If
    Set mo_Db = ao_Db
End Property

Public Property Get Initialized() As Boolean
    Initialized = mb_Initialized
End Property

Public Property Let LoginName(ByVal as_loginName As String)
    ms_LoginName = as_loginName
End Property

Public Property Let U_Code(ByVal al_U_Code As Long)
    ml_U_Code = al_U_Code
End Property

Public Property Let Language_Code(ByVal as_Language_Code As String)
    ms_Language_Code = as_Language_Code
End Property

Private Sub InitCtrlSize()

  Const HSPACE As Long = 120
  Const VSPACE As Long = 120
  
On Error GoTo ErrHandler
  fra_container.Height = UserControl.Height
  fra_container.Width = UserControl.Width - HSPACE
  tvw_Main.Height = UserControl.Height - tvw_Main.Top - VSPACE
  
  grd_FocusProduct.Width = UserControl.Width - grd_FocusProduct.Left - (HSPACE * 2)
  grd_Items.Width = grd_FocusProduct.Width
  
  grd_Items.Height = UserControl.Height - grd_Items.Top - VSPACE
  btn_exit.Left = UserControl.Width - btn_exit.Width - (HSPACE * 2)
  Exit Sub
ErrHandler:
End Sub

Private Sub btn_exit_Click()
  RaiseEvent quit
End Sub

Private Function ReplaceHolders(ByVal aRequest As String) As String
    
    Dim lBuffer As String
    lBuffer = Replace(aRequest, "$language_code$", SQLStr(ms_Language_Code), , , vbTextCompare)
    lBuffer = Replace(lBuffer, "$loginname$", SQLStr(ms_LoginName), , , vbTextCompare)
    lBuffer = Replace(lBuffer, "$u_code$", ml_U_Code, , , vbTextCompare)
    lBuffer = Replace(lBuffer, "$now$", SQLDateTime(Now), , , vbTextCompare)
    ReplaceHolders = lBuffer
End Function

Private Function ConvertDateToSQL(ByVal aDate As Date) As String
    Dim lStr As String
    lStr = Year(aDate) & "-" & Month(aDate) & "-" & Day(aDate)
    ConvertDateToSQL = lStr
End Function

Private Sub SetMode(ByVal aMode As eMode)
    mOldMode = mMode
    mMode = aMode
End Sub

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

    Dim lIdx As Long, lCount As Long, lLabels As Long
    Dim lControl As Control
    
    lLabels = mo_Db.OpenSQL("exec Screen_Csts '" & as_ScreenName & "','" & as_Language & "'")
    lCount = aControls.Count - 1
    
    If lLabels <> 0 Then
      For lIdx = 0 To lCount
          Set lControl = aControls.Item(lIdx)
              Select Case UCase(TypeName(lControl))
                  Case "LABEL", "FRAME", "COMMANDBUTTON", "OPTIONBUTTON"
                      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
                      End If
                  Case "ARMGRID"
                      If lControl.Tag <> "" Then
                          If mo_Db.Find(lLabels, "FIELD_NAME", lControl.Tag, , 1) >= 0 Then
                              Call lControl.LoadConstants(ParamType.ptStatic, mo_Db.GetFields(lLabels, "LOCAL_TEXT"), ConstType.ctColumns)
                          End If
                      End If
                  Case "FRAME", "MSFLEXGRID", "TOOLBARCONTROL", "TEXTBOX", "COMMANDBUTTON", "ARMCHECKVIEW", "ARMCOMBOBOX", "A_CALOCX", "OPTIONBUTTON", "ARMTREEVIEW", "LISTBOX", "PICTUREBOX"
                      ' Do nothing !
                  Case Else
                      ''debug.print "LoadLabels " & UCase(TypeName(lControl))
              End Select
          Set lControl = Nothing
      Next
      
      mo_Db.Close (lLabels)
    End If
End Sub

Sub SendMessage(aID As Long, aDefault As String, aLang As String)
Dim lMessage As String

lMessage = MsgText(aID, aLang, aDefault)
    
MsgBox lMessage

End Sub

Function MsgText(aID As Long, aLang As String, ByVal aDefault As String) As String

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)
    lRequest = Replace(lRequest, "$lang$", aLang)
    
    Dim lData As Long
    lData = mo_Db.OpenSQL(lRequest)
    
    Dim lBuffer As String
    lBuffer = mo_Db.GetFields(lData, "message_text")
    mo_Db.Close (lData)
    If lBuffer = "" Then lBuffer = aDefault
    
    MsgText = lBuffer
End Function

Public Sub UploadSQLError(ByRef ao_Armdb As Object, ByRef ao_ArmdbErr As Object, ByVal as_Procedure As String)
Dim ls_req As String, lStr As String, lNumber As Long, lDesc As String

Const C_ERR_FATAL_MSG As String = "A fatal error occured, the application will be terminated. Please report error to IT support team" & vbCrLf & "Error : "
Const C_ERR_REPORT As String = "Please, report this to IT application support"

lNumber = Err.Number
lDesc = Err.Description

On Error GoTo onError

If ao_Armdb.LastErrorCode = 0 Then
    If lNumber <> 0 Then
        'error runtime
        as_Procedure = "VB runtime : " & as_Procedure
        ls_req = "EXEC Error_Log_Insert '" & App.EXEName & "', '" & App.Major & "." & App.Minor & "." & App.Revision & "', '" _
            & Replace(as_Procedure, "'", "''", , , vbTextCompare) & "', '" & lNumber & "','" & lDesc & "'"
        If Not ao_ArmdbErr.ExecuteSQL(ls_req) Then
            ''debug.print "Impossible to insert in Error log  "
        End If
    Else
        'debug.print "Call to UploadSQLError not relevant : " & as_Procedure
        Exit Sub
    End If
Else
    'In case of armsyscom failure
    If IsEmpty(ao_Armdb.SQLErrorCodes) Then Err.Raise C_ERRORRAISE, "UploadSQLError", "Fatal error in armsyscom : SQlErrorCodes is empty although LastErrorCode = " & ao_Armdb.LastErrorCode
    If IsEmpty(ao_Armdb.SQLErrorMessages) Then Err.Raise C_ERRORRAISE, "UploadSQLError", "Fatal error in armsyscom : SQLErrorMessages is empty although LastErrorCode = " & ao_Armdb.LastErrorCode
    
    
    Dim lErrMsg As Variant, lErrCode As Variant
    Dim lIdx As Long, lCount As Long, lCount2 As Long
        
    lStr = "An error occured : " & as_Procedure & vbCrLf
        
    '  On contourne le bug à l'aide de variables locales, le bug empêche d'accéder au élément du variant mais pas au variant lui même
    lErrCode = ao_Armdb.SQLErrorCodes
    lErrMsg = ao_Armdb.SQLErrorMessages
        
    lCount = UBound(lErrCode)
    lCount2 = UBound(lErrMsg)
         
    'If not it may cause a runtime error (index out of bound)
    If lCount = lCount2 Then
        For lIdx = 0 To lCount
            lStr = lStr & "Err : " & lErrCode(lIdx) & ", " & lErrMsg(lIdx)
        Next
    Else
            lStr = lStr & "Errs : " & Join(lErrCode, ", ") & vbCrLf & "Msg : " & Join(lErrMsg, vbCrLf) & vbCrLf & C_ERR_REPORT
    End If
        
    ls_req = "EXEC Error_Log_Insert '" & App.EXEName & "', '" & App.Major & "." & App.Minor & "." & App.Revision & "', '" _
        & Replace(as_Procedure, "'", "''", , , vbTextCompare) & "', 'UploadSQLError','" & Replace(lStr, "'", "''", , , vbTextCompare) & "'"
    If Not ao_ArmdbErr.ExecuteSQL(ls_req) Then
        'debug.print "Impossible to insert in Error log  "
    End If
End If
    
Exit Sub

onError:
    ao_Armdb.Disconnect
    MsgBox C_ERR_FATAL_MSG & lNumber & ", " & lDesc, vbCritical
        
    End
End Sub

Private Sub SendFieldErrMsg(ByVal aMsgID As Long, ByVal aCaption As String, ByRef AField As Object)

    Dim lBuffer As String
    Dim lMsgID As Long
    lMsgID = aMsgID ' @!#'@@ of byref argument !
    lBuffer = MsgText(lMsgID, ms_Language_Code, "This data is not entered correctly")
    lBuffer = Replace(lBuffer, "$field$", aCaption)
    
    AField.SetFocus
    Call MsgBox(lBuffer, vbOKOnly + vbCritical)

End Sub

Private Function SQLDbl(ByVal ad_Value As Double) As String
  SQLDbl = Str(ad_Value)
End Function

Private Function SQLDateTime(ByVal ad_Date As Date) As String
  If ad_Date = 0 Then
    SQLDateTime = "Null"
  Else
    SQLDateTime = "{ ts '" & Format(ad_Date, "yyyy-mm-dd hh:mm:ss") & "'}"
  End If
End Function

Private Function SQLStr(ByVal as_Value As String) As String

  SQLStr = "'" & Replace(as_Value, "'", "''") & "'"
End Function

' Name :        function LoadImageFromFile
' Parameters:   hIns - handle to dll library
'               li_IconIndex - index of icon
' Description:  Load picture from external file
' Return value: Picture

Private Function LoadImageFromFile(ByRef al_hInst As Long, ai_IconIndex As Integer, al_PicType As Long) As Picture
Dim ll_hImage As Long
Dim lo_Pic As StdPicture, lu_PicConv As PictDesc, lo_IGuid As Guid

On Error GoTo ErrHandler
    Set LoadImageFromFile = Nothing  ' not good
    
    If al_hInst = 0 Then Exit Function        ' stop
    
    ll_hImage = 0
    ' ok seems fine
    If al_PicType = vbPicTypeBitmap Then
      ll_hImage = LoadBitmap(al_hInst, "#" & ai_IconIndex) ' get the handle of the bitmap
    ElseIf al_PicType = vbPicTypeIcon Then
      ll_hImage = LoadIcon(al_hInst, "#" & ai_IconIndex) ' get the handle of the icon
    End If
    
    If ll_hImage = 0 Then Exit Function ' O dear error
    
    ' Fill PictDesc structure with necessary parts:
    With lu_PicConv
        .cbSizeofStruct = Len(lu_PicConv)
        .picType = al_PicType
        .hImage = ll_hImage
    End With
    
    ' Magic GUID for picture
    With lo_IGuid
    .Data1 = &H20400
    .Data4(0) = &HC0
    .Data4(7) = &H46
    End With
    
    ' Create a picture object:
    If OleCreatePictureIndirect(lu_PicConv, lo_IGuid, True, lo_Pic) <> 0 Then Exit Function
    
    ' return the picture
    Set LoadImageFromFile = lo_Pic
    Set lo_Pic = Nothing
    Exit Function
ErrHandler:
    Set LoadImageFromFile = Nothing
    Set lo_Pic = Nothing
    Exit Function
End Function

Private Sub grd_FocusProduct_ItemSelected()
Const C_ITEMREQUEST = "exec Cap_Rpt_FocusProduct_Items_grd $FPD_ID$,$Language_Code$"
Dim ls_Request As String

On Error GoTo ErrHandler

  ls_Request = ReplaceHolders(C_ITEMREQUEST)
  If grd_FocusProduct.SelectedCount = 1 Then
    ls_Request = Replace(ls_Request, "$FPD_ID$", grd_FocusProduct.SelectedLine(0, "FPD_ID"), , , vbTextCompare)
    Call grd_Items.Load(ls_Request, False)
  Else
    Call grd_Items.ClearGrid
  End If
  grd_Items.Visible = True
  Exit Sub
ErrHandler:

End Sub

Private Sub tvw_Main_Click()
Dim ls_Request As String

On Error GoTo ErrHandler

  If Not (tvw_Main.SelectedItem Is Nothing) Then
    grd_FocusProduct.Visible = tvw_Main.SelectedItem.Tag.ml_Level > 0
    grd_Items.Visible = False
    
    ls_Request = tvw_Main.SelectedNodeRequest
    Call grd_FocusProduct.Load(ls_Request, False, , , tvw_Main.SelectedItem.Tag.ml_Level < tvw_Main.Levels - 1)
    
  End If
  Exit Sub
ErrHandler:

End Sub

Private Sub UserControl_Resize()
On Error GoTo ErrHandler

  Call InitCtrlSize
  Exit Sub
ErrHandler:
End Sub
