-

VB开发的ERP系统

        Loop
        .Close
    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
    tv.Enabled = True
    Exit Function

ErrCtrl:
    If rs.State = 1 Then
        rs.Close
    End If
    Set rs = Nothing
    tv.Enabled = True
    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 '返回错误描述
    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 'coll中是否包涵sName的项目
    '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(i)) Then
                    Exit For
                End If
            Next i
        Else
            For i = 1 To .Count
                If sName = .Item(i) 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语句
    On Error GoTo ErrCtrl
    
    Dim s As String
    Dim st As String
    Dim i As Integer
    Dim j As Integer
    Dim k As Integer
    
    If sPriTableName = "" Then
        MsgBox "请输入主表名!", vbOKOnly + vbInformation
        Exit Function
    End If
    
    s = ""
    With coll
        If .Count = 0 Then
            s = " " & sPriTableName & Chr(10) & " "
            GetSQLFrom = s
            Exit Function
        End If
        '判断主表,因为每个表的连接字段不同,所以要分开处理
        Select Case UCase(sPriTableName)
            Case UCase("PM_PayRoll")    '工资表
                s = " PM_PayRoll left outer join  PM_AttendRecord  " & Chr(10) _
                    & " on  PM_PayRoll.EmpID=PM_AttendRecord.EmpID AND PM_PayRoll.Period=PM_AttendRecord.Period AND PM_PayRoll.KjYear=PM_AttendRecord.KjYear " & Chr(10) _
                    & " Left Outer Join PM_TaxData " & Chr(10) _
                    & " on PM_PayRoll.EmpID=PM_TaxData.EmpID AND PM_PayRoll.Period=PM_TaxData.Period AND PM_PayRoll.KjYear=PM_TaxData.KjYear AND PM_PayRoll.SortID=PM_TaxData.SortID " & Chr(10)
            Case UCase("PM_AttendRecord")   '考勤表
                i = IsItemExist("PM_PayRoll", coll)
                If i <> -1 Then
                    s = " PM_AttendRecord left outer join  PM_PayRoll  " & Chr(10) _
                        & " on  PM_PayRoll.EmpID=PM_AttendRecord.EmpID AND PM_PayRoll.Period=PM_AttendRecord.Period AND PM_PayRoll.KjYear=PM_AttendRecord.KjYear " & Chr(10) _
                        & " Left Outer Join PM_TaxData " & Chr(10) _
                        & " on PM_AttendRecord.EmpID=PM_TaxData.EmpID AND PM_AttendRecord.Period=PM_TaxData.Period AND PM_AttendRecord.KjYear=PM_TaxData.KjYear  " & Chr(10)
                Else
                    s = " PM_AttendRecord  " & Chr(10)
                End If
            Case UCase("PM_TaxData")    '所得税表
                i = IsItemExist("PM_PayRoll", coll)
                If i <> -1 Then
                    s = " PM_TaxData left outer join  PM_AttendRecord  " & Chr(10) _
                        & " on  PM_TaxData.EmpID=PM_AttendRecord.EmpID AND PM_TaxData.Period=PM_AttendRecord.Period AND PM_TaxData.KjYear=PM_AttendRecord.KjYear " & Chr(10) _
                        & " Left Outer Join PM_PayRoll " & Chr(10) _
                        & " on PM_PayRoll.EmpID=PM_TaxData.EmpID AND PM_PayRoll.Period=PM_TaxData.Period AND PM_PayRoll.KjYear=PM_TaxData.KjYear AND PM_PayRoll.SortID=PM_TaxData.SortID " & Chr(10)
                Else
                    s = "PM_TaxData"
                End If
            Case Else
                s = sPriTableName
        End Select
                
        '连接剩下的表
        For k = 1 To .Count
            If UCase(sPriTableName) <> UCase(.Item(k)) And _
                Trim(UCase(.Item(k))) <> "" And _
                Trim(UCase(.Item(k))) <> UCase("PM_PayRoll") And _
                Trim(UCase(.Item(k))) <> UCase("PM_AttendRecord") And _
                Trim(UCase(.Item(k))) <> UCase("PM_TaxData") Then
                s = s & " left outer join " & Trim(.Item(k)) & " on " & Trim(.Item(k)) & ".EmpID=" & sPriTableName & ".EmpID " & Chr(10)
            End If
        Next k
        
    End With
    GetSQLFrom = s
    Exit Function
    
ErrCtrl:
    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 AddTableFrom(coll As Collection, sName As String) '添加用户查询必须的表
    On Error GoTo ErrCtrl
    
    Dim i As Integer
    '如果没有定义查询条件，简单添加表名
    '如果表名集合第一项为“”，则删除第一项
    
    With coll
        If coll.Count = 0 Then
            .Add UCase(sName)
            Exit Function
        End If
        If Trim(.Item(1)) = "" Then
            .Remove (1)
        End If
        For i = 1 To .Count
            If UCase(.Item(i)) = UCase(sName) Then
                Exit For
            End If
        Next
        If i > .Count Then
            .Add UCase(sName)
        End If
    End With
    Exit Function

ErrCtrl:
    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 IsNodeExist(skey As String, tv As TreeView) As Boolean '测试树是否包含Key为skey的节点
    On Error GoTo ErrCtrl
    
    Dim i As Integer
    With tv
        For i = 1 To .Nodes.Count
            If UCase(.Nodes(i).Key) = UCase(skey) Then
                IsNodeExist = True
                Exit Function
            End If
        Next
    End With
    IsNodeExist = False
    Exit Function

ErrCtrl:
    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 FillValue2TV(sCond As String, tv As TreeView)    '填充字段的可能值,sCond 的格式为 数字@表名@编码@名称

    On Error GoTo ErrCtrl
    
    '如果没有条件,退出
    tv.Nodes.Clear
    If Trim(sCond) = "" Then
        Exit Function
    End If
    
    Dim sID As String
    Dim sTable As String
    Dim sCode As String
    Dim sName As String
    Dim rs As New ADODB.Recordset
    Dim s As String
    tv.Nodes.Clear
    
    '取得字段帮助
    GetFieldHelp sCond, sID, sTable, sCode, sName
'    填充值
    With tv
        If UCase(sTable) = UCase("GY_Department") Then
            '如果是部门帮助,调用填充部门帮助
            FillDept2TV "RsPmFlag", tv, Cw_DataEnvi.DataConnect
        Else
            '判断字段帮助
            If Trim(sID) = "" Or Trim(sTable) = "" Or Trim(sCode) = "" Or Trim(sName) = "" Then
                MsgBox "字段帮助出现错误!", vbOKOnly + vbCritical
                GoTo ErrCtrl
            End If
            If Trim(sID) = "0" Then
                s = "SELECT " & sCode & " AS TCode, " & sName & " AS TName FROM " & sTable
            Else
                s = "SELECT " & sCode & " AS TCode, " & sName & " AS TName FROM " & sTable & " WHERE SortID='" & sID & "'"
            End If
           
            Set rs = Cw_DataEnvi.DataConnect.Execute(s)
            If Not rs.EOF() Then
                .Nodes.Add , , "R", "备选值"
                Do While Not rs.EOF()
                    .Nodes.Add "R", tvwChild, "R" & Trim(rs!TCode), Trim(rs!TName)
                    rs.MoveNext
                Loop
                rs.Close
            End If
            Set rs = Nothing
        End If
    End With
    Exit Function