modsyssetting.bas

销售预测系统

Attribute VB_Name = "modSysSetting"
'Create by Whorter Wang in 2002-2-9
Option Explicit

''''''''''''''''''''''''''''''''''''''''''
Dim m_tagErrInfo As TYPE_ERRORINFO

'操作状态枚举
Enum ENUM_OPTYPE
    OPTYPE_QUERY = 0        '查询状态
    OPTYPE_INSERT = 1       '增加操作
    OPTYPE_MODIFY = 2       '修改操作
    OPTYPE_DELETE = 3       '删除操作
    OPTYPE_AUDIT = 4        '审核操作
    OPTYPE_UNAUDIT = 5      '反审核操作
    OPTYPE_BLANK = 6        '作废操作
    OPTYPE_UNBLANK = 7      '反作废操作
End Enum

'审核、有效性状态
Enum ENUM_DATASTATUS
    STATUS_CONFIRMED = 1        '已审核
    STATUS_UNCONFIRMED = 2      '未审核
    STATUS_ABANDONED = 3        '作废
    STATUS_INUSE = 4            '有效
End Enum

'业务单据状态
Enum ENUM_BUSINESS_STATUS
    STATUS_INITIAL = 1          '初始
    STATUS_PERFORMING = 2       '履行中
    STATUS_STOPED = 3           '异常终止
    STATUS_FINISHED = 4         '完成
    STATUS_PRODUCT_OUT = 5      '货已发完
    STATUS_MONEY_IN = 6         '款已收完
    STATUS_PRODUCT_IN = 7       '货已收完
    STATUS_MONEY_OUT = 8        '款已付完
End Enum

Private Type TYPE_USERDB
    strUserName As String
    strUserPassword As String
    strUserDatabase As String
    strUserDatasource As String
End Type
Public g_MyUserDB As TYPE_USERDB

'***********************************************************************************Added by Whorter Wang
Private Type TPBaseDept
    NameC As String
    DeptID As Integer
End Type
Private Type TPBaseEmp
    NameC As String
    Code1 As String
    DeptID As Integer
    DeptType As Byte
End Type
Private Type TPBaseCust
    Code1 As String
    NameC As String
End Type
Public g_tBUDept() As TPBaseDept
Public g_tBUEmp() As TPBaseEmp
Public g_tBUCust() As TPBaseCust

'**********************************************************************Added by Whorter Wang
'btChoice 用来决定更新那些基础信息，缺省为全部更新
Public Function InitBaseUseInfo(Optional ByVal btChoice As Byte) As Boolean
    On Error GoTo ERROR_EXIT
    
    Dim col2 As New yxerpcom.CDepartmentCol, i As Long
    Dim col3 As New yxerpcom.CEmployeeCol, col4 As New yxerpcom.CBaseOther1Col
    Dim col5 As New yxerpcom.CCustomerCol
    
    If btChoice = 0 Or btChoice = 15 Then
        Set col2.IBaseCollection_ActiveConnection = dbMyDB
        If Not col2.IBaseCollection_Query("SELECT * FROM Department WHERE nouse_yesno=0") Then
            MsgBox "常用部门信息检索错误！", vbOKOnly + vbExclamation, "错误"
            GoTo ERROR_EXIT
        End If
        If col2.Count > 0 Then
            ReDim g_tBUDept(col2.Count - 1)
            For i = 1 To col2.Count
                g_tBUDept(i - 1).DeptID = col2(i).dp_id
                g_tBUDept(i - 1).NameC = col2(i).dp_name
            Next i
        Else
            ReDim g_tBUDept(0)
        End If
    End If
    
    If btChoice = 0 Or btChoice = 20 Then
        Set col3.IBaseCollection_ActiveConnection = dbMyDB
        If Not col3.IBaseCollection_Query("SELECT * FROM Employee WHERE nouse_yesno=0") Then
            MsgBox "在职员工信息检索错误！", vbOKOnly + vbExclamation, "错误"
            GoTo ERROR_EXIT
        End If
        If col3.Count > 0 Then
            ReDim g_tBUEmp(col3.Count - 1)
            For i = 1 To col3.Count
                g_tBUEmp(i - 1).Code1 = col3(i).ep_code
                g_tBUEmp(i - 1).NameC = col3(i).name_c
                g_tBUEmp(i - 1).DeptID = col3(i).Department.dp_id
                g_tBUEmp(i - 1).DeptType = col3(i).Department.dp_type
            Next i
        Else
            ReDim g_tBUEmp(0)
        End If
    End If
    
    If btChoice = 0 Or btChoice = 30 Then
        Set col5.IBaseCollection_ActiveConnection = dbMyDB
        col5.StructType = 1
        If Not col5.IBaseCollection_Query("SELECT * FROM Company WHERE nouse_yesno=0 AND cp_type=1") Then
            MsgBox "有效客户数据检索错误！", vbOKOnly + vbExclamation, "错误"
            GoTo ERROR_EXIT
        End If
        If col5.Count > 0 Then
            ReDim g_tBUCust(col5.Count - 1)
            For i = 1 To col5.Count
                g_tBUCust(i - 1).Code1 = col5(i).cp_code_1
                g_tBUCust(i - 1).NameC = col5(i).name_c
            Next i
        Else
            ReDim g_tBUCust(0)
        End If
    End If
    InitBaseUseInfo = True
ERROR_EXIT:
    Set col2 = Nothing
    Set col3 = Nothing
    Set col4 = Nothing
    Set col5 = Nothing
End Function

Public Function GetDeptID(ByVal strName As String) As Integer
    Dim i As Integer, bTwice As Boolean
ONCE_AGAIN:
    For i = 0 To UBound(g_tBUDept)
        If g_tBUDept(i).NameC = strName Then
            GetDeptID = g_tBUDept(i).DeptID
            Exit Function
        End If
    Next i
    If Not bTwice Then
        InitBaseUseInfo 15
        bTwice = True
        GoTo ONCE_AGAIN
    End If
    GetDeptID = 0
'    MsgBox "所选部门已不存在，请选择其他部门！", vbOKOnly, "消息"
End Function

Public Function GetDeptName(ByVal intID As Integer) As String
    Dim i As Integer, bTwice As Boolean
ONCE_AGAIN:
    For i = 0 To UBound(g_tBUDept)
        If g_tBUDept(i).DeptID = intID Then
            GetDeptName = g_tBUDept(i).NameC
            Exit Function
        End If
    Next i
    If Not bTwice Then
        InitBaseUseInfo 15
        bTwice = True
        GoTo ONCE_AGAIN
    End If
    GetDeptName = ""
'    MsgBox "所选部门已不存在，请选择其他部门！", vbOKOnly, "消息"
End Function

Public Function GetItemNameC(ByVal lMaID As Long) As String
    On Error GoTo ERROR_EXIT
    Dim oItem As New yxerpcom.CyxItem, str1 As String
    
    str1 = "SELECT * FROM Item WHERE pid=" & lMaID
    
    Set oItem.IBaseClass_ActiveConnection = dbMyDB
    If Not oItem.IBaseClass_Query(str1) Then
        MsgBox "物料信息检索错误！", vbOKOnly + vbExclamation, "错误"
        GoTo ERROR_EXIT
    End If
    GetItemNameC = oItem.item_name_c
    Set oItem = Nothing
    Exit Function
ERROR_EXIT:
    Set oItem = Nothing
    m_tagErrInfo.strErrDate = Format(Now, "yyyy-mm-dd hh:mm:ss")
    m_tagErrInfo.strErrFile = "modSysSetting"
    m_tagErrInfo.strErrFunc = "GetItemNameC"
    m_tagErrInfo.nErrNum = Err.Number
    m_tagErrInfo.strErrDesc = Error(Err.Number)
    If Err.Number <> 0 Then Err.Clear
End Function

Public Function GetItemCode(ByVal lngID As Long) As String
    On Error GoTo ERROR_EXIT
    Dim oItem As New yxerpcom.CyxItem, str1 As String
    
    str1 = "SELECT * FROM Item WHERE pid=" & CStr(lngID)
    Set oItem.IBaseClass_ActiveConnection = dbMyDB
    If Not oItem.IBaseClass_Query(str1) Then
        MsgBox "物料信息检索错误！", vbOKOnly + vbExclamation, "错误"
        GoTo ERROR_EXIT
    End If
    GetItemCode = oItem.item_code
    Set oItem = Nothing
    Exit Function
ERROR_EXIT:
    Set oItem = Nothing
    m_tagErrInfo.strErrDate = Format(Now, "yyyy-mm-dd hh:mm:ss")
    m_tagErrInfo.strErrFile = "modSysSetting"
    m_tagErrInfo.strErrFunc = "GetItemCode"
    m_tagErrInfo.nErrNum = Err.Number
    m_tagErrInfo.strErrDesc = Error(Err.Number)
    If Err.Number <> 0 Then Err.Clear
End Function

Public Function GetEmpCode(ByVal strName As String) As String
    Dim i As Long, bTwice As Boolean
ONCE_AGAIN:
    For i = 0 To UBound(g_tBUEmp)
        If g_tBUEmp(i).NameC = strName Then
            GetEmpCode = g_tBUEmp(i).Code1
            Exit Function
        End If
    Next i
    If Not bTwice Then
        InitBaseUseInfo 20
        bTwice = True
        GoTo ONCE_AGAIN
    End If
    GetEmpCode = ""
End Function

Public Function GetEmpName(ByVal strCode As String) As String
    Dim i As Long, bTwice As Boolean
ONCE_AGAIN:
    For i = 0 To UBound(g_tBUEmp)
        If g_tBUEmp(i).Code1 = strCode Then
            GetEmpName = g_tBUEmp(i).NameC
            Exit Function
        End If
    Next i
    If Not bTwice Then
        InitBaseUseInfo 20
        bTwice = True
        GoTo ONCE_AGAIN
    End If
    GetEmpName = ""
End Function

Public Function GetEmpDeptType(ByVal strCode As String) As Byte
    Dim i As Long, bTwice As Boolean
ONCE_AGAIN:
    For i = 0 To UBound(g_tBUEmp)
        If g_tBUEmp(i).Code1 = strCode Then
            GetEmpDeptType = g_tBUEmp(i).DeptType
            Exit Function
        End If
    Next i
    If Not bTwice Then
        InitBaseUseInfo 20
        bTwice = True
        GoTo ONCE_AGAIN
    End If
    GetEmpDeptType = 0
End Function

Public Function GetStyleByProduct(ByVal strProduct As String) As String
    On Error GoTo ERROR_EXIT
    Dim rs As New ADODB.Recordset, cmd As New ADODB.Command
    
    Set cmd.ActiveConnection = dbMyDB
    cmd.CommandType = adCmdText
    cmd.CommandText = "SELECT material_type FROM VIEW_ProductB WHERE material_code_1='" & strProduct & "'"
    rs.CursorLocation = adUseClient
    rs.Open cmd, , adOpenStatic, adLockReadOnly
    If rs.RecordCount <> 1 Then
        MsgBox "产品信息检索错误！", vbOKOnly + vbExclamation, "错误"
        GoTo ERROR_EXIT
    End If
    GetStyleByProduct = Trim$(rs!material_type)
    Set rs = Nothing
    Set cmd = Nothing
    Exit Function
ERROR_EXIT:
    Set rs = Nothing
    Set cmd = Nothing
    m_tagErrInfo.strErrDate = Format(Now, "yyyy-mm-dd hh:mm:ss")
    m_tagErrInfo.strErrFile = "modSysSetting"
    m_tagErrInfo.strErrFunc = "GetStyleByProduct"
    m_tagErrInfo.nErrNum = Err.Number
    m_tagErrInfo.strErrDesc = Error(Err.Number)
    If Err.Number <> 0 Then Err.Clear
End Function

Public Function GetUnitID(ByVal strUnit As String) As Long
    On Error Resume Next
    Dim obj As New yxerpcom.CyxUnit
    
    Set obj.IBaseClass_ActiveConnection = dbMyDB
    If Not obj.IBaseClass_Query("SELECT * FROM yxBS_Unit WHERE name_c='" & strUnit & "'") Then
        Set obj = Nothing
        Exit Function
    End If
    GetUnitID = obj.unit_id
    Set obj = Nothing
End Function

Public Function GetColorID(ByVal strCode As String) As Long
    On Error GoTo ERROR_EXIT
    Dim oColor As New yxerpcom.CBaseOther1, str1 As String
    
    str1 = "SELECT * FROM BaseOther1 WHERE bof_type=1 AND bof_code='" & strCode & "'"
    Set oColor.IBaseClass_ActiveConnection = dbMyDB
    If Not oColor.IBaseClass_Query(str1) Then
        MsgBox "色号信息检索错误！", vbOKOnly + vbExclamation, "错误"
        GoTo ERROR_EXIT
    End If
    GetColorID = oColor.bof_id
    Set oColor = Nothing
    Exit Function
ERROR_EXIT:
    Set oColor = Nothing
    m_tagErrInfo.strErrDate = Format(Now, "yyyy-mm-dd hh:mm:ss")
    m_tagErrInfo.strErrFile = "modSysSetting"
    m_tagErrInfo.strErrFunc = "GetMaterialCode1"
    m_tagErrInfo.nErrNum = Err.Number
    m_tagErrInfo.strErrDesc = Error(Err.Number)
    If Err.Number <> 0 Then Err.Clear
End Function

Public Function GetCustCode(ByVal strName As String) As String
    Dim i As Long, bTwice As Boolean
ONCE_AGAIN:
    For i = 0 To UBound(g_tBUCust)
        If g_tBUCust(i).NameC = strName Then
            GetCustCode = g_tBUCust(i).Code1
            Exit Function
        End If
    Next i
    If Not bTwice Then
        InitBaseUseInfo 30
        bTwice = True
        GoTo ONCE_AGAIN
    End If
    GetCustCode = ""
End Function

'**********************************************************************
' 根据输入的树节点的KEY值求节点的物料代码，用于BOM表的展开遍历过程
' key 节点的记法如下： Index + 是否为叶结点 + 物料的表ID
' key 节点的记法例如："1+N+15"
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Function GetTreeCode(ByRef b_Leaf As Boolean, ByRef s_Material As String, _
        ByVal s_Key As String) As Boolean
    On Error GoTo ERROR_EXIT
    Dim str As String, i As Integer, j As Integer, strSQL As String
    Dim oItem As yxerpcom.CyxItem
    
    '是否为叶子
    str = s_Key
    i = InStr(1, str, "+N+", vbBinaryCompare)
    j = InStr(1, str, "+Y+", vbBinaryCompare)
    If i > 0 Then
        b_Leaf = False
        str = Mid$(s_Key, i + 3)
    ElseIf j > 0 Then
        b_Leaf = True
        str = Mid$(s_Key, j + 3)
    Else
        GoTo ERROR_EXIT
    End If
    '求物料Code
    strSQL = "SELECT * FROM yxBS_Item WHERE pid = " & str
    Set oItem = New yxerpcom.CyxItem
    Set oItem.IBaseClass_ActiveConnection = dbMyDB
    If oItem.IBaseClass_Query(strSQL) = False Then
        GoTo ERROR_EXIT
    End If
    
    s_Material = oItem.item_code
    Set oItem = Nothing
    GetTreeCode = True
    Exit Function
ERROR_EXIT:
    If Not oItem Is Nothing Then Set oItem = Nothing
    b_Leaf = False
    s_Material = ""
    GetTreeCode = False
    Debug.Print "ERROR: GetTreeCode!"
End Function

Public Function GetOrderTreeCode(ByRef b_Leaf As Boolean, ByRef s_Material As String, _
        ByRef s_Product As String, ByVal s_Key As String) As Boolean
    On Error GoTo ERROR_EXIT
    Dim str As String, i As Integer, j As Integer, strSQL As String
    Dim oItem As yxerpcom.CyxItem
    
    '是否为叶子
    str = s_Key
    i = InStr(1, str, "+N+", vbBinaryCompare)
    j = InStr(1, str, "+Y+", vbBinaryCompare)
    If i > 0 Then
        b_Leaf = False
        str = Mid$(s_Key, i + 3)
    ElseIf j > 0 Then
        b_Leaf = True
        str = Mid$(s_Key, j + 3)
    Else
        GoTo ERROR_EXIT
    End If
    '求物料Code
    strSQL = "SELECT * FROM yxBS_Item WHERE pid = " & str
    Set oItem = New yxerpcom.CyxItem
    Set oItem.IBaseClass_ActiveConnection = dbMyDB
    If oItem.IBaseClass_Query(strSQL) = False Then
        GoTo ERROR_EXIT
    End If
    s_Material = oItem.item_code
    Set oItem = Nothing
    '求产品Code
    i = InStr(1, s_Key, "+", vbBinaryCompare)
    str = Mid$(s_Key, 1, i - 1)
    s_Product = str
    
    GetOrderTreeCode = True
    Exit Function
ERROR_EXIT:
    If Not oItem Is Nothing Then Set oItem = Nothing
    b_Leaf = False
    s_Material = ""
    GetOrderTreeCode = False
    Debug.Print "ERROR: GetOrderTreeCode!"
End Function