-

VB开发的ERP系统

    
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 '表头字体大小
    Dim iRowsPerPage As Long '每行显示数据行数
    Dim bLimitRowPerPage As Boolean '是否每页限制行数
    Dim iLimitRowsPerPage As Long '每页限制行数
    Dim iClientHeight As Long '页面可用高度
    Dim iPageLeft As Long '左边界
    Dim iClientWidth As Long '页面可用宽度
    Dim iPageTop As Long '上边界
    Dim iTitleFontHeight As Long '标题高度
    Dim iDataFontHeight As Long '数据高度
    
    With frmSetup
        sTitleFontName = .Btztlabel.Caption
        sDataFontName = .SjztLabel.Caption
        iTitleFontSize = Val(.Btzhlabel.Caption)
        iDataFontSize = Val(.Sjzhlabel.Caption)
        bLimitRowPerPage = .ZdhsCheck.Value
        iLimitRowsPerPage = Val(.BbhsText)
    End With
    With DY_Tybbyldy.Tydy
        .StartDoc
            .FontName = sTitleFontName
            .FontSize = iTitleFontSize
            .CalcText = "测试"
            iTitleFontHeight = .TextHei
            .FontName = sDataFontName
            .FontSize = iDataFontSize
            .CalcText = "测试"
            iDataFontHeight = .TextHei
        .EndDoc
        .KillDoc
        iPageHeight = .PageHeight
        iClientHeight = .PageHeight - .MarginBottom - .MarginTop
        iPageTop = .MarginTop
        iClientWidth = .PageWidth - .MarginLeft - .MarginRight
        iPageLeft = .MarginLeft
    End With
    
    '--------------------------------------------------打印参数完成-------------------------------------------------
    
    
    '--------------------------------------------------读取数据信息-------------------------------------------------
    '定义打印开始列
    If iShowAllCols = 1 Then
        iStartCol = iVsBeginCol
    Else
        iStartCol = iVsSumEndCol + 1
    End If
    
    '读取有效数据
    Dim sData() As String '网格表体数据
    Dim sTitle() As String '表头数据
    Dim iPages() As Long '打印分页信息,第i页结束行在sData()中的位置是iPages(i)
    Dim iTitleRows() As String '打印的表头行值
    Dim iDataRows() As String '打印的数据行值
    Dim iColsPerPage() As Long '每行在页面上的折行信息 第i行的结束列对应sData()中的iColsPerPage(i)列
    Dim iCols() As Long '需要打印的列值
    Dim iColWidth() As Long '需要打印的列款
    Dim iColType() As Long '需要打印的列数据类型
    Dim iColFormat() As String '需要打印的列格式
    With vs
        '读取有效列
        ReDim iCols(0)
        iCols(0) = 0
        ReDim iColWidth(0)
        iColWidth(0) = 0
        ReDim iColType(0)
        iColType(0) = 0
        ReDim iColFormat(0)
        iColFormat(0) = ""
        For i = 0 To .Cols - 1
            If Not .ColHidden(i) Then
                ReDim Preserve iCols(UBound(iCols) + 1)
                iCols(UBound(iCols)) = i
                ReDim Preserve iColWidth(UBound(iColWidth) + 1)
                If .ColWidth(i) >= iClientWidth Then
                    MsgBox "纸张宽度太小不能输出报表,请重新设置!", vbOKOnly + vbCritical
                    Exit Function
                End If
                iColWidth(UBound(iColWidth)) = .ColWidth(i)
                ReDim Preserve iColType(UBound(iColType) + 1)
                iColType(UBound(iColType)) = Val(.TextMatrix(0, i))
                ReDim Preserve iColFormat(UBound(iColFormat) + 1)
                iColFormat(UBound(iColFormat)) = .ColFormat(i)
            End If
        Next i
        If UBound(iCols) = 0 Then
            
            Exit Function
        End If
        '读取有效表头行
        ReDim iTitleRows(0)
        iTitleRows(0) = 0
        For i = 0 To .FixedRows - 1
            If .RowHidden(i) = False Then
                ReDim Preserve iTitleRows(UBound(iTitleRows) + 1)
                iTitleRows(UBound(iTitleRows)) = i
            End If
        Next i
        If UBound(iTitleRows) = 0 Then
            Exit Function
        End If
        
        '读取有效数据行
        ReDim iDataRows(0)
        iDataRows(0) = 0
        For i = .FixedRows To .Rows - 1
            If .RowHidden(i) = False Then
                ReDim Preserve iDataRows(UBound(iDataRows) + 1)
                iDataRows(UBound(iDataRows)) = i
            End If
        Next i
        If UBound(iDataRows) = 0 Then
            Exit Function
        End If
        
        '读取表头数据
        ReDim sTitle(UBound(iTitleRows) - 1, UBound(iCols) - 1)
        For i = LBound(iTitleRows) + 1 To UBound(iTitleRows)
            For j = LBound(iCols) + 1 To UBound(iCols)
                sTitle(i - LBound(iTitleRows) - 1, j - LBound(iCols) - 1) = .TextMatrix(iTitleRows(i), iCols(j))
            Next j
        Next i

        '读取表体数据
        ReDim sData(UBound(iDataRows) - 1, UBound(iCols) - 1)
        For i = LBound(iDataRows) + 1 To UBound(iDataRows)
            For j = LBound(iCols) + 1 To UBound(iCols)
                sData(i - LBound(iDataRows) - 1, j - LBound(iCols) - 1) = .TextMatrix(iDataRows(i), iCols(j))
            Next j
        Next i
        
        '--------------------------------------------------读取数据信息完成-------------------------------------------------
        
        '--------------------------------------------------计算打印信息-------------------------------------------------
        '计算数据行折行信息