-

VB开发的ERP系统

            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
    
ErrCtrl:
    If rs.State = 1 Then
        rs.Close
    End If
    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 FillDept2TV(sSysCode As String, tv As TreeView, cn As Connection) '填充部门树
    On Error GoTo ErrCtrl
    
    Dim s As String
    Dim rs As New ADODB.Recordset
    Dim nod As Node
    
    '初始化树
    tv.Enabled = False
    tv.Nodes.Clear
    tv.Nodes.Add , , "R", "部门"
    s = "SELECT DeptCode,DeptName ,ParentCode FROM GY_Department WHERE " & sSysCode & "=1 order by CodeLevel"
    Set rs = Cw_DataEnvi.DataConnect.Execute(s)
    With rs
        Do While Not .EOF()
            Set nod = tv.Nodes.Add("R" & Trim(!ParentCode & ""), tvwChild, "R" & Trim(!DeptCode & ""), Trim(!DeptName & ""))
            nod.Tag = Trim(!DeptCode & "")
            '展开第一行
            If Trim(!ParentCode & "") = "" Then
                nod.EnsureVisible
            End If
            .MoveNext
        Loop
        .Close
    End With
    
    Set rs = Nothing
    Set nod = Nothing
    tv.Enabled = True
    Exit Function
    
ErrCtrl:
    If rs.State = 1 Then
        rs.Close
    End If
    Set nod = Nothing
    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 GetTableNameC(sTableName As String) As String '设置表的汉语名称
    
    Dim s As String
    
    Select Case UCase(sTableName)
        Case UCase("PM_PayRoll")
            s = "工资"
        Case UCase("Rs_BasicInfo")
            s = "基本"
        Case UCase("Rs_ExtendInfo")
            s = "扩展"
        Case UCase("PM_AttendRecord")
            s = "考勤"
        Case Else
            MsgBox "不存在此表!", vbOKOnly + vbCritical
    End Select
    GetTableNameC = s
End Function

Public Function GetCol(sFields() As CFieldValue, iNoCol As Integer, iNameCol As Integer, Optional iBeginCol As Integer = 0) As Integer '查找工号列和姓名列
    '成功找到工号或者姓名返回1,没有找到返回0,错误返回-1
    On Error GoTo ErrCtrl

    Dim i As Integer
    
    iNoCol = -1
    iNameCol = -1
    GetCol = -1
    
    For i = LBound(sFields) To UBound(sFields)
        If Len(sFields(i).FieldName) >= 5 Then
            If UCase(Right(sFields(i).FieldName, 5)) = UCase("EmpNo") Then
                iNoCol = i + iBeginCol
            Else
                If Len(sFields(i).FieldName) >= 7 Then
                    If UCase(Right(sFields(i).FieldName, 7)) = UCase("EmpName") Then
                        iNameCol = i + iBeginCol
                    End If
                End If
            End If
        End If
        If iNameCol >= 0 And iNoCol >= 0 Then
            Exit For
        End If
    Next i
    If iNameCol >= 0 Or iNoCol >= 0 Then
        GetCol = 1
    Else
        GetCol = 0
    End If
    Exit Function
    
ErrCtrl:
    GetCol = -1
End Function

Public Function LenByte(s As String) As Long '计算字符串的字节数
  '返回字符串长度
    Dim i As Long
    Dim CH As String
    
    LenByte = 0
    s = Trim(s)
    For i = 1 To Len(s)
        CH = Mid(s, i, 1)
        If Asc(CH) >= 0 And Asc(CH) <= 255 Then
            LenByte = LenByte + 1
        ElseIf Asc(CH) < 0 Then   '汉字
            LenByte = LenByte + 2
        End If
    Next
End Function

Public Function PrintGrid(vs As vsFlexGrid, iVsBeginCol As Integer, iVsSumEndCol As Integer, sRCode As String, frmSetup As DY_Dyymsz, sSubTitle As String, Optional bPrint As Boolean = False) '打印网格
    On Error GoTo ErrCtrl
    
    Dim i As Long
    Dim j As Long
    Dim k As Long
    Dim m As Long
    Dim n As Long
    Dim s As String
    Dim bNext As Boolean '临时变量
    Dim bSumRow As Boolean '是否是合计行
    Dim iStartCol As Long '打印数据开始列
    Dim rs As New ADODB.Recordset
    '--------------------------------------------------控制信息-------------------------------------------------
    Dim iPrintStyle As Integer '打印方式 0每页输出一个表头 1每行输出一个表头
    Dim iSumPerPage As Integer '1每页输出合计
    Dim iSplitPage As Integer '1分页打印
    Dim sRTitle As String '标题
    Dim iShowAllCols As Integer '1 显示所有可见网格列
    
    s = "SELECT * FROM PM_ReportSort WHERE RCode='" & sRCode & "'"
    Set rs = Cw_DataEnvi.DataConnect.Execute(s)
    With rs
        If Not .EOF() Then
            iPrintStyle = !PrintStyle
            iSumPerPage = !SumPerPage
            iSplitPage = !SplitPage
            iShowAllCols = !ShowAllCols
            sRTitle = Trim(!RTitle)
        Else
            MsgBox "当前报表已被删除,无法读取格式!", vbOKOnly + vbCritical
            Exit Function
        End If
        rs.Close
    End With
    Set rs = Nothing
    
    '--------------------------------------------------控制信息完成-------------------------------------------------
    
    '--------------------------------------------------打印参数-------------------------------------------------
    '设置打印参数
    If Not SetupPage(frmSetup, DY_Tybbyldy) Then
        MsgBox "打印设置失败!", vbOKOnly + vbCritical
        Exit Function
    End If
    
    '读取打印设置
    Dim sDataFontName As String '数据字体名称
    Dim sTitleFontName As String '表头字体名称
    Dim iDataFontSize As Long '数据字体大小
    Dim iTitleFontSize As Long '表头字体大小