-

VB开发的ERP系统

Attribute VB_Name = "XtsyModule"
'系统私有模块用来放置一些子系统独有的过程与函数
Public str_Code As String                               '存储列内容参数

Public conAlart As Long                                 '高储低储预警
Public conArea As Long                                  '货区管理
Public conExceed As Long                                '超限额领料
Public conForbid As Long                                '盘点冻结出入库
Public conBatch As Long                                 '批次管理
Public conQuan As Long                                  '保值期管理
Public conAllow As Long                                 '允许负出库
Public conHLJudge As Long                               '高储和低储判断标准
Public strHlpR As String
Public strM As String                                    '物料编码

Public S1 As String
Public PriceMode As String
Public RBFlag As Integer                                 '红字兰字标识
Const AreaString = "货区"
Const BatchString = "批号"
Const QuanString = "失效日期"

Public Sub Drxtztcs()                                   '读入系统帐套参数
   
    Dim Ztcsbrec As New ADODB.Recordset
    Dim RecTemp As New ADODB.Recordset
    Dim Sqlstr As String
  
    With Ztcsbrec
        '金额总位数
        .Open "Select * From Gy_AccInformation Where SystemCode='Cwzz'", Cw_DataEnvi.DataConnect, adOpenDynamic, adLockOptimistic
        .MoveFirst
        .Find "itemcode='cwjezws'"
        If Not Ztcsbrec.EOF Then
            Xtjezws = Val(Trim(Ztcsbrec.Fields("itemvalue")))
        End If
        
        '数量总位数
        .MoveFirst
        .Find "itemcode='cwslzws'"
        If Not Ztcsbrec.EOF Then
            Xtslzws = Val(Trim(Ztcsbrec.Fields("itemvalue")))
        End If
   
        '单价总位数
        .MoveFirst
        .Find "itemcode='cwdjzws'"
        If Not Ztcsbrec.EOF Then
            Xtdjzws = Val(Trim(Ztcsbrec.Fields("itemvalue")))
        End If
        
        '金额小数位数
        .MoveFirst
        .Find "itemcode='cwjexsws'"
        If Not Ztcsbrec.EOF Then
            Xtjexsws = Val(Trim(Ztcsbrec.Fields("itemvalue")))
        End If
   
        '数量小数位数
        .MoveFirst
        .Find "itemcode='cwslxsws'"
        If Not Ztcsbrec.EOF Then
            Xtslxsws = Val(Trim(Ztcsbrec.Fields("itemvalue")))
        End If
        
        '单价小数位数
        .MoveFirst
        .Find "itemcode='cwdjxsws'"
        If Not Ztcsbrec.EOF Then
            Xtdjxsws = Val(Trim(Ztcsbrec.Fields("itemvalue")))
        End If
        .Close
    End With
  
End Sub

Public Sub getSysDef()
'模块功能：得到系统设置信息
    Dim adoRec As New ADODB.Recordset
    Dim intNum As Integer

    If adoRec.State = 1 Then adoRec.Close
    Set adoRec = Cw_DataEnvi.DataConnect.Execute("select * from gy_accinformation where systemcode='kf'")
    With adoRec
        If Not .EOF Then
            .MoveFirst
            For intNum = 1 To .RecordCount
                Select Case Trim(.Fields("itemcode"))
                    Case "KF_Area"
                        conArea = Val(.Fields("itemvalue"))
                    Case "KF_Batch"
                        conBatch = Val(.Fields("itemvalue"))
                    Case "KF_Quan"
                        conQuan = Val(.Fields("itemvalue"))
                    Case "KF_Exceed"
                        conExceed = Val(.Fields("itemvalue"))
                    Case "KF_Forbid"
                        conForbid = Val(.Fields("itemvalue"))
                    Case "KF_Alart"
                        conAlart = Val(.Fields("itemvalue"))
                    Case "KF_Allow"
                        conAllow = Val(.Fields("itemvalue"))
                    Case "KF_HLFlag"
                        conHLJudge = Val(.Fields("itemvalue"))
                End Select
                .MoveNext
            Next intNum
        End If
        .Close
    End With
    Set adoRec = Nothing
End Sub
Public Function Clrkdkfsc() As Boolean
'模块功能：判断材料入库单是否由库存系统生成

    Dim adoRec As New ADODB.Recordset
    Dim intNum As Integer

    If adoRec.State = 1 Then adoRec.Close
    Set adoRec = Cw_DataEnvi.DataConnect.Execute("select * from gy_accinformation where systemcode='chhs' AND itemcode='Chhs_ClrkdKfsc'")
    With adoRec
        If Not .EOF Then
            If Trim(.Fields("itemvalue")) = 1 Then
                Clrkdkfsc = True
            Else
                Clrkdkfsc = False
            End If
        End If
    End With
    adoRec.Close
    Set adoRec = Nothing

End Function
Public Function CheckRefTable(KeyValue As Variant, KeyName As String, RefTable As String, Optional KeyCon As String, Optional KeyConName As String) As Boolean
 Dim adoReturn As New ADODB.Recordset
 Dim str As String
 Dim Status As Integer
 
  CheckRefTable = False
  Status = 0
    If KeyCon <> "" Then
     Status = 1
    End If
        str = "KF_SP_CheckRefTable '" & Trim(KeyValue) & "','" & Trim(KeyName) & "','" & Trim(RefTable) & "','" & Trim(KeyCon) & "','" & Trim(KeyConName) & "'," & Val(Status)
        Set adoReturn = Cw_DataEnvi.DataConnect.Execute(str)
        If Not adoReturn.EOF Then
         If adoReturn.Fields("f1") Then
          CheckRefTable = True
         Else
          CheckRefTable = False
         End If
        End If
        adoReturn.Close
        Set adoReturn = Nothing
End Function

Public Function LrTextFHXZ(lrzfasc As Integer) As Boolean       '文本框录入非特殊符号限制
    LrTextFHXZ = True
    If (lrzfasc >= -23645 And lrzfasc <= -23643) Or lrzfasc = -23617 Or lrzfasc = -24150 Or (lrzfasc <= -24156 And lrzfasc >= -24158) Or lrzfasc = -23647 Or lrzfasc = -24147 Or lrzfasc = -23621 Or lrzfasc = -23636 Or lrzfasc = -23638 Or lrzfasc = 124 Or lrzfasc = 94 Or lrzfasc = 96 Or lrzfasc = 126 Or lrzfasc = 247 Or lrzfasc = 165 Or (lrzfasc <= 64 And lrzfasc >= 58) Or (lrzfasc >= 42 And lrzfasc <= 45) Or lrzfasc = 46 Or (lrzfasc >= 32 And lrzfasc <= 39) Then
        LrTextFHXZ = False
        lrzfasc = 0
    End If
End Function

Public Sub ShowOrHideCol(WglrGrid As vsFlexGrid, strGridCode As String, GridStr() As String, Szzls As Integer)
'函数功能：显示或隐藏相应列
    
    Dim adoRec As New ADODB.Recordset                   'ADO连接
    Dim strColTitle As String                           '列标题
    Dim strColIndex As String                           '列索引
    Dim strSQL As String                                '查询连接字符串
    
    strSQL = "SELECT * FROM XT_Grid WHERE Grid_Code='" & strGridCode & "' AND ColHidden=1 ORDER BY ColIndex"
    Set adoRec = Cw_DataEnvi.DataConnect.Execute(strSQL)
    
    With adoRec
        If Not .EOF Then
            .MoveFirst
            Do While Not .EOF
                strColIndex = Trim(.Fields("ColIndex"))
                strColTitle = Trim(.Fields("ColTitle1"))
                If conArea = 1 And AreaString = strColTitle Then
                    WglrGrid.ColHidden(Sydz(strColIndex, GridStr(), Szzls)) = False
                End If
                If conBatch = 1 And BatchString = strColTitle Then
                    WglrGrid.ColHidden(Sydz(strColIndex, GridStr(), Szzls)) = False
                End If
                If conQuan = 1 And QuanString = strColTitle Then
                    WglrGrid.ColHidden(Sydz(strColIndex, GridStr(), Szzls)) = False
                End If
                .MoveNext
            Loop
        End If
    End With
    
    adoRec.Close
    Set adoRec = Nothing
    
End Sub

Public Function FunHlpR(str1 As String, str2 As String, str3 As String) As String
'通用帮助函数     str1----帮助编码  str2---条件字段    str3----条件值

 Dim adoTemp As New ADODB.Recordset
    Set adoTemp = Cw_DataEnvi.DataConnect.Execute("KF_SP_Xthelp '" & Trim(str1) & "','" & Trim(str2) & "','" & Trim(str3) & "'")
    If Not adoTemp.EOF Then
        FunHlpR = Trim(adoTemp.Fields("r1"))
    End If
End Function
Public Function HelpString(intCount As Integer, hlpCondition() As String, hlpValue() As String) As String

    Dim tempJsq As Integer
    
    ReDim hlpCondition(0 To intCount - 1)
    ReDim hlpValue(0 To intCount - 1)
    
    HelpString = HelpString & hlpCondition(0) & "='" & hlpValue(0) & "'"
    If intCount > 1 Then
        For tempJsq = 1 To intCount - 1
            HelpString = HelpString & " and " & hlpCondition(tempJsq) & "='" & hlpValue(tempJsq) & "'"
        Next tempJsq
    End If
    
End Function
Public Function CheckArea(strWhCode As String, strArea As String, AreaCode As String, AreaName As String) As Boolean
'函数功能：进行货区管理时,用户输入货区的合法性检查,CheckArea=True时表示货区输入有误
    
    Dim adoRec As New ADODB.Recordset                   'ADO连接
    Dim strSQL As String                                '查询连接字符串
    
    strSQL = "SELECT * FROM KF_MArea WHERE WhCode='" & strWhCode & "' and (MArea='" & strArea & "' OR MAreaName='" & strArea & "') and endflag=1"
    Set adoRec = Cw_DataEnvi.DataConnect.Execute(strSQL)
    
    With adoRec
        If .EOF Then
            CheckArea = True
        Else
            CheckArea = False
            AreaCode = .Fields("MArea")
            AreaName = .Fields("MAreaName")
        End If
    End With
    
    adoRec.Close
    Set adoRec = Nothing

End Function
Public Function CheckBillDate(LrText As TextBox, Kjyear As Integer, Period As Integer) As Boolean
'函数功能：判断用户输入的制单日期是否已经结帐,CheckBillDate为True时,表示已经结帐

    Dim RecTemp As New ADODB.Recordset
    Dim Sqlstr As String
    Dim Tsxx As String
    
    Sqlstr = "Select * FROM  Gy_Kjrlb Where Qsrq<='" & LrText & "' and zzrq>='" & LrText & "' and kjyear=" & Mid(LrText, 1, 4)
    Set RecTemp = Cw_DataEnvi.DataConnect.Execute(Sqlstr)
    
    With RecTemp
        If Not .EOF Then
            If .Fields("kfjzbz") Then
               CheckBillDate = True
               Tsxx = "所选会计期间已经结帐,不能再填制单据!"
               Call Xtxxts(Tsxx, 0, 1)
               LrText.SetFocus
               Exit Function
            Else
               CheckBillDate = False
               Kjyear = Val(.Fields("kjyear"))
               Period = Val(.Fields("Period"))
            End If
        Else
            CheckBillDate = True
            Tsxx = "所选年度不正确!"
            Call Xtxxts(Tsxx, 0, 1)
            LrText.SetFocus
            Exit Function
        End If
    End With
    
    RecTemp.Close
    Set RecTemp = Nothing

End Function
Public Function CheckStartFinish() As Boolean
'函数功能：判断初始化是否完成
    Dim RecTemp As New ADODB.Recordset
    Dim Sqlstr As String
    Dim Tsxx As String
    
    Sqlstr = "Select * FROM  Gy_AccInformation Where systemcode='KF' and itemcode='KFInit'"
    Set RecTemp = Cw_DataEnvi.DataConnect.Execute(Sqlstr)
    
    With RecTemp
        If CBool(.Fields("ItemValue")) = True Then
            CheckStartFinish = True
        Else
            CheckStartFinish = False
        End If
    End With
        
    RecTemp.Close
    Set RecTemp = Nothing
        
End Function
Public Function KFHLJudge(Status As Integer, strWhCode As String, strMNum As String, strMArea As String, dblEndQuan As Double, InOutFlag As Integer, MainID As Long)
'函数功能：库存高储和低储判断--Status=0(输入数量与物料表中的高储和低储值比较)   Status=1(输入数量与现存量表中的高储和低储值比较)
    
    Dim RecTemp As New ADODB.Recordset
    Dim recADO As New ADODB.Recordset
    Dim tempSQL As String
    Dim tempQuan As Double
    Dim Sqlstr As String
    Dim Tsxx As String
    Dim dblHigh As Double
    Dim dblLow As Double
    Dim dblNow As Double

    '从收发记录主表中得到结果
    If strMArea <> "" Then
        tempSQL = "Select sum(AddupIssueQuan) as AddupIssueQuan from gy_inoutsub where inoutMainID=" & MainID & " and MNumber='" & Trim(strMNum) & "' and MArea='" & Trim(strMArea) & "'"
    Else
        tempSQL = "Select sum(AddupIssueQuan) as AddupIssueQuan FROM Gy_InOutsub WHERE inoutMainID=" & MainID & " and MNumber='" & Trim(strMNum) & "' and MArea IS NULL "
    End If

    If Status = 0 Then
        Sqlstr = "Select HighStorage,LowStorage,NowStorage FROM  Gy_Material Where MNumber='" & Trim(strMNum) & " '"
    Else
        If strMArea <> "" Then
            Sqlstr = "Select Max(HighQuan) AS HighQuan,MIN(LowQuan) AS LowQuan,SUM(EndQuan) AS EndQuan FROM  Kf_NowQuan Where MNumber='" & Trim(strMNum) & " ' and WhCode='" & Trim(strWhCode) & "' and MArea='" & Trim(strMArea) & "'"
        Else
            Sqlstr = "Select Max(HighQuan) AS HighQuan,MIN(LowQuan) AS LowQuan,SUM(EndQuan) AS EndQuan FROM  Kf_NowQuan Where MNumber='" & Trim(strMNum) & " ' and WhCode='" & Trim(strWhCode) & "' and MArea IS NULL"
        End If
    End If
    '从收发记录表中查找符合条件的记录
    Set recADO = Cw_DataEnvi.DataConnect.Execute(tempSQL)
    With recADO
        If Not .EOF Then
            If Not IsNull(.Fields("AddupIssueQuan")) Then
                tempQuan = .Fields("AddupIssueQuan")
            End If
        End If
    End With
    recADO.Close
    Set recADO = Nothing

    Set RecTemp = Cw_DataEnvi.DataConnect.Execute(Sqlstr)
    
    With RecTemp
        If Not .EOF Then
            If Status = 0 Then
                dblHigh = .Fields("HighStorage")