-

VB开发的ERP系统

Attribute VB_Name = "XtsyModule"

'系统私有模块用来放置一些子系统独有的过程与函数
Public str_Code As String                               '存储列内容参数
Public sParam As String
Public Const DATA_NUMERIC As Integer = 5 '数字行
Public Const DATA_STRING As Integer = 0 '字符型
Public Const DATA_DATE As Integer = 7 '日期型
Const PRINTSTYLE_ONETITLE = 0 '每页打印表头
Const PRINTSTYLE_ALLTITLE = 1 '每行打印表头


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


'******************************************************************
'*    模 块 名 称 :私有模块
'*    功 能 描 述 :
'*    程序员姓名  :苗鹏
'*    最后修改人  :苗鹏
'*    最后修改时间:2002/01/01
'*    备        注:
'******************************************************************

Public Function GetTableField(sExec As String, sTableName As String, sFieldName As String, s As String) As Integer
    '分离表名和字段名,s为分隔符
    On Error GoTo ErrCtrl
    Dim i As Integer
    For i = 1 To Len(sExec)
        If Mid(sExec, i, 1) = s Then
            sTableName = Left(sExec, i - 1)
            sFieldName = Right(sExec, Len(sExec) - i)
            Exit For
        End If
    Next i
    If i <= Len(sExec) Then
        GetTableField = 1
    Else
        GetTableField = 0
    End If
    Exit Function
ErrCtrl:
    GetTableField = -1
End Function

Public Function InitView(tv As TreeView, Optional Ssql As String = " 1=1 ")
    '初始化字段树
'    On Error GoTo ErrCtrl
    
    Dim rs As New ADODB.Recordset
    Dim s As String
    Dim nodX As Node
    
    If Ssql = "" Then
        Ssql = " 1=1  "
    End If
    tv.Nodes.Clear
    Set nodX = tv.Nodes.Add(, , "R", "备选项目")
    '读取表
    s = "select distinct TableName as TableFrom from Rs_Items where " & Ssql
    
    Set rs = Cw_DataEnvi.DataConnect.Execute(s)
       
    With rs
        If .EOF() Then
            Exit Function
        End If
        Do While Not .EOF()
            Set nodX = tv.Nodes.Add("R", tvwChild, UCase(Trim(!TableFrom)), GetTableNameC(Trim(!TableFrom)))
            nodX.EnsureVisible
            .MoveNext
        Loop
    End With
    
    '读取字段
    s = "select FieldName  as FieldName,CHName as FieldNameC,TableName as TableFrom " & Chr(10) _
        & ",Correlation as FieldRelation,CorTable as CorTable ,IndexCode as TCode,IndexName as TName,AddMinusItem " & Chr(10) _
        & " from Rs_Items where " & Ssql  'TableName is not Null "
    Set rs = Cw_DataEnvi.DataConnect.Execute(s)
    With rs
        If .EOF() Then
            Exit Function
        End If
        Do While Not .EOF()
            '末级节点的Tag值为此字段的英文全名
            If !AddMinusItem = 1 And Trim(Ssql) = Trim("1=1") Then
                '如果是选入工资表的字段，添加工资表节点
                Set nodX = tv.Nodes.Add(UCase("PM_PayRoll"), tvwChild, UCase("PM_PayRoll") & "." & UCase(Trim(!FieldName)), UCase(Trim(!FieldNameC)))
                If Trim(!CorTable & "") <> "" And Trim(!TCode & "") <> "" And Trim(!TName & "") <> "" Then
                    nodX.Tag = Trim(!FieldRelation & "") & "@" & Trim(!CorTable & "") & "@" & Trim(!TCode & "") & "@" & Trim(!TName & "")
                End If
                
            End If
            Set nodX = tv.Nodes.Add(UCase(Trim(!TableFrom)), tvwChild, UCase(Trim(!TableFrom) & "." & Trim(!FieldName)), UCase(Trim(!FieldNameC)))
            If Trim(!CorTable & "") <> "" And Trim(!TCode & "") <> "" And Trim(!TName & "") <> "" Then
                nodX.Tag = Trim(!FieldRelation & "") & "@" & Trim(!CorTable & "") & "@" & Trim(!TCode & "") & "@" & Trim(!TName & "")
            End If
            
            .MoveNext
        Loop
    End With
    
        '添加会计年，会计期间，工资类别到工资表节点
        If IsNodeExist("PM_PayRoll", tv) Then
            Set nodX = tv.Nodes.Add(UCase("PM_PayRoll"), tvwChild, UCase("PM_PayRoll.KjYear"), "会计年")
            Set nodX = tv.Nodes.Add(UCase("PM_PayRoll"), tvwChild, UCase("PM_PayRoll.Period"), "会计月")
            Set nodX = tv.Nodes.Add(UCase("PM_PayRoll"), tvwChild, UCase("PM_PayRoll.SortID"), "工资类别")
            nodX.Tag = "0@PM_Sort@SortID@SortName"
        End If
        
        '添加会计年，会计期间到考勤表节点
        If IsNodeExist("PM_AttendRecord", tv) Then
            Set nodX = tv.Nodes.Add(UCase("PM_AttendRecord"), tvwChild, UCase("PM_AttendRecord.KjYear"), "会计年")
            Set nodX = tv.Nodes.Add(UCase("PM_AttendRecord"), tvwChild, UCase("PM_AttendRecord.Period"), "会计月")
        End If
      
    Set rs = Nothing
    
    Exit Function
ErrCtrl:
    Set rs = Nothing
    
    Dim smsg As String
    Dim smsgSys As String
    smsg = GetError(Err.Number)
    smsgSys = Err.Number & Err.Description & "!"
    MsgBox IIf(smsg = "", smsgSys, smsg), vbOKOnly + vbCritical
End Function
Public Function GetFieldHelp(sExp As String, sID As String, sTable As String, sCode As String, sName As String)
    Dim i As Integer
    Dim j As Integer
    Dim k As Integer
    Dim s(3) As String
    
    If sExp = "" Then
        Exit Function
    End If
    j = 1
    k = 0
    '取ID,关联表,编码,名称
    Do While i <= Len(sExp)
        For i = j To Len(sExp)
            If Mid(sExp, i, 1) = "@" Then
                s(k) = Mid(sExp, j, i - j)
                j = i + 1
                k = k + 1
                Exit For
            End If
        Next i
        If i > Len(sExp) Then
            sName = Mid(sExp, j, i - j)
        End If
    Loop
    sID = s(0)
    sTable = s(1)
    sCode = s(2)
        
End Function

Public Function GetError(iNum As Long) As String
'    On Error Resume Next
    Dim msg As String
    Select Case iNum
        Case -2147217873
            msg = "违反唯一性或者编码已经使用!"
        Case -2147217913
            msg = "录入了错误的日期格式,正确格式为 2001-09-12" & Chr(10) _
                & "或者录入了错误的数字格式,正确格式为 123456789.12"
        Case -2147217900
            msg = "语法错误!"
        Case Else
            msg = ""
    End Select
    GetError = msg
End Function

Public Function ReplByPos(sExepress As String, sReplace As String, Optional iStart As Integer = 0, Optional iEnd As Integer = 0) As String
  '把sExepress的第iStart字起到iEnd结束的字符替换成sReplace
  Dim i As Integer
  Dim j As Integer
  Dim sLeft As String
  Dim sRight As String
  
  If iStart > Len(sExepress) Then
    MsgBox "开始位置超出字符长度", vbOKOnly + vbCritical
    Exit Function
  End If
  If iStart > iEnd Then
    MsgBox "开始位置超出结束位置", vbOKOnly + vbCritical
    Exit Function
  End If
  
  sLeft = Left(sExepress, iStart - 1)
  sRight = Right(sExepress, Len(sExepress) - iEnd + 1)
  
  ReplByPos = sLeft & sReplace & sRight
  
End Function
Public Function IsItemExist(sName As String, coll As Collection, Optional iType As Integer = 0) As Integer
    'itype=0 不区分大小写 1 区分大小写
    '返回sName的位置或-1
    Dim i As Integer
    With coll
        If .count = 0 Then
            IsItemExist = -1
            Exit Function
        End If
        If iType = 0 Then
            For i = 1 To .count
                If UCase(sName) = UCase(.Item(1)) Then
                    Exit For
                End If
            Next i
        Else
            For i = 1 To .count
                If sName = .Item(1) Then
                    Exit For
                End If
            Next i
        End If
        If i > .count Then
            IsItemExist = -1
        Else
            IsItemExist = i
        End If
    End With
End Function

Public Function GetSQLFrom(coll As Collection, sPriTableName As String) As String
    '根据所提供的表名,连接成From语句
    Dim s As String
    Dim st As String
    Dim i As Integer
    Dim j As Integer
    Dim k As Integer
'    On Error GoTo ErrCtrl
    If sPriTableName = "" Then
        MsgBox "请输入主表名"
        Exit Function