企业管理

开发平台：
Visual Basic

-：源码内容
							Attribute VB_Name = "XtsyModule"
'系统私有模块用来放置一些子系统独有的过程与函数
Public str_Code As String                               '存储列内容参数
Public KjYear As Integer                                '当前会计年
Public Period As Integer                                '当前会计月
Public sParam As String
Public sParam2 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 '每行打印表头
Dim Sql As String
Dim SqlField As String
Dim Rsc As New ADODB.Recordset
Public Function Item_Info(sys As Integer)   '项目查询连接
'sys=0,人事系统调用;sys=1,工资系统调用
    Dim tmpRs As New Recordset
    Dim sSql As String
    If sys = 0 Then
        Set tmpRs = Cw_DataEnvi.DataConnect.Execute("select * from Rs_Items WHERE SID='1' ")
    Else
        Set tmpRs = Cw_DataEnvi.DataConnect.Execute("select * from Rs_Items WHERE SID='2' OR Pm='1' ")
    End If
    With tmpRs
        Do While Not .EOF
            
            If Trim(!CorTable) = "" Then                                               '非编码型的
                If Trim(!TableName) = "Rs_BasicInfo" Then
                    sSql = sSql & ",B." & !FieldName
                Else
                    sSql = sSql & ",E." & !FieldName
                End If
            Else
                If Trim(tmpRs!CorTable) = "Rs_CorSub" Then                                  '这个字段是编码型的，并且相关项的字段在Rs_CorSub
                    If Trim(!TableName) = "Rs_BasicInfo" Then
                        sSql = sSql & ",N_" & !FieldName & "=(select ListName from Rs_CorSub c where convert(varchar(18),c.ListId)=B." & !FieldName & ")"
                        sSql = sSql & ",B." & !FieldName
                    Else
                        sSql = sSql & ",N_" & !FieldName & "=(select ListName from Rs_CorSub c where convert(varchar(18),c.ListId)=E." & !FieldName & ")"
                        sSql = sSql & ",E." & !FieldName
                    End If
                    '-----------------
                Else                                                                         '这个字段是编码型的，但是相关项的字段表不确定的情况
                        If Trim(!TableName) = "Rs_BasicInfo" Then
                            sSql = sSql & ",N_" & !FieldName & "=(select " & Trim(tmpRs!IndexName) & " from " & Trim(tmpRs!CorTable) & " c where c." & Trim(tmpRs!IndexCode) & "=B." & !FieldName & ")"
                            sSql = sSql & ",B." & !FieldName
                        Else
                            sSql = sSql & ",N_" & !FieldName & "=(select " & Trim(tmpRs!IndexName) & " from " & Trim(tmpRs!CorTable) & " c where c." & Trim(tmpRs!IndexCode) & "=E." & !FieldName & ")"
                            sSql = sSql & ",E." & !FieldName
                        End If
                End If
            End If
            
            
            .MoveNext
        Loop
        sSql = "SELECT " & Mid(sSql, 2, Len(sSql) - 1) & " FROM Rs_ExtendInfo E,Rs_BasicInfo B"
    End With
    Item_Info = sSql
End Function
Public Sub Drxtztcs()                                   '读入系统帐套参数
   
    Dim Ztcsbrec As New ADODB.Recordset
    Dim RecTemp As New ADODB.Recordset
    Dim Sqlstr As String
    
    '读入本位币
    Sqlstr = "SELECT ForeignCurrCode,ForeignCurrName FROM Gy_ForeignCurrency WHERE StandardFlag=1"
    Set RecTemp = Cw_DataEnvi.DataConnect.Execute(Sqlstr)
    XtSCurrCode = Trim(RecTemp.Fields("ForeignCurrCode"))
    XtSCurrName = Trim(RecTemp.Fields("ForeignCurrName"))
    
    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 CurrPeriod()
    '读入当前会计期间
    Dim Rsc As New ADODB.Recordset
    Set Rsc = Cw_DataEnvi.DataConnect.Execute("SELECT * FROM gy_kjrlb WHERE pmjzbz=0 order by kjyear,period")
    With Rsc
        If Not Rsc.EOF Then
           KjYear = Trim(!KjYear)
           Period = Trim(!Period)
        End If
    End With
End Sub
Public Function DynaFillImageCombo(Combote As ImageCombo, ComboCode As String, AddType As Integer, SqlString As String) '填充列表框(ImageCombo)并定
    '可在查询条件里加动态的条件
    '函数参数：列表框(ImageCombo)，ComboCode列表框分组编码
    'AddType 项目填充类型(0-填充索引+内容,无空记录 1-仅填充内容,无空记录 2-填充索引+内容,有空记录 3-仅填充内容,有空记录)
    'SqlString  补充条件
    Dim Rec_Combo As ADODB.Recordset              '填充属性
    Dim Rec_FillText As ADODB.Recordset           '填充内容
    Dim ci As ComboItem
    Dim jsqte As Integer                          '临时计数器
    Dim Sql As String
    Combote.ComboItems.Clear
    jsqte = 1
  
    '填充列表框内容
    Set Rec_Combo = Cw_DataEnvi.DataConnect.Execute("SELECT * FROM Xt_ImageCombo WHERE combo_code='" + Trim(ComboCode) + "'")
    
    With Rec_Combo
        Combote.Locked = True
        If AddType = 2 Or AddType = 3 Then
            Set ci = Combote.ComboItems.Add(, "@")
            jsqte = jsqte + 1
        End If
        Sql = Trim(.Fields("Sql_String")) & SqlString
        Set Rec_FillText = Cw_DataEnvi.DataConnect.Execute(Sql)
        
        Do While Not Rec_FillText.EOF
            Select Case AddType
                Case 0, 2                              '填充索引+内容
                    Set ci = Combote.ComboItems.Add(, "@" + Trim(Rec_FillText.Fields(Trim(.Fields("ItemKey")))), Trim(Rec_FillText.Fields(Trim(.Fields("ItemKey")))) + " " + Trim(Rec_FillText.Fields(Trim(.Fields("ItemText")))))
                Case 1, 3                              '仅填充记录内容
                    Set ci = Combote.ComboItems.Add(, "@" + Trim(Rec_FillText.Fields(Trim(.Fields("ItemKey")))), Trim(Rec_FillText.Fields(Trim(.Fields("ItemText")))))
            End Select
            jsqte = jsqte + 1
            Rec_FillText.MoveNext
        Loop
        If Combote.ComboItems.Count <> 0 Then
            Combote.ComboItems.Item(1).Selected = True
        End If
    End With
End Function
Public Sub CmdUP(CzxsGrid As vsFlexGrid) '向上移动网格中数据的上、下行序
    Dim Temp As String
    Dim i As Long
    With CzxsGrid
        For i = .FixedCols To .Cols - 1
            Temp = .TextMatrix(.Row - 1, i)
            .TextMatrix(.Row - 1, i) = .TextMatrix(.Row, i)
            .TextMatrix(.Row, i) = Temp
        Next
        .Row = .Row - 1
    End With
End Sub
Public Sub CmdDown(CzxsGrid As vsFlexGrid)    '向下移动网格中数据的上、下行序
    Dim Temp As String
    Dim i As Long
    With CzxsGrid
        For i = .FixedCols To .Cols - 1
            Temp = .TextMatrix(.Row + 1, i)
            .TextMatrix(.Row + 1, i) = .TextMatrix(.Row, i)
            .TextMatrix(.Row, i) = Temp
        Next
        .Row = .Row + 1
    End With
End Sub
Public Function StopDelItem(ItemId As Integer, FieldName As String, ChName As String, OpeStatus As String, SortId As String) As Boolean
    '停用、删除项目必须符合以下条件，
    'itemid--项目编号  FieldName--项目字段名  ChName--项目名称  OpeStatus--操作状态（停用、删除） SortId--工资类别
    Dim Rsc As New ADODB.Recordset
    Dim Sql As String
       
    With Rsc
        If LCase(Trim(FieldName)) = "tax" Or LCase(Trim(FieldName)) = "paywage" Or LCase(Trim(FieldName)) = "taxitem" Then
            If .State = 1 Then .Close
            .Open "SELECT * FROM PM_Sort WHERE SortId='" & SortId & "'", Cw_DataEnvi.DataConnect, adOpenDynamic, adLockOptimistic
            If Not .EOF Then
               If !DeductTax = True Or (!AdmDeductTax = True And LCase(Trim(FieldName)) = "taxitem") Then
                   Call Xtxxts("本工资类别是扣税类别，不能删除“" & ChName & "”!", 0, 1)
                   StopDelItem = False
                   Exit Function
               End If
            End If
        End If
        
       '没有用在公式的字段中
        If .State = 1 Then .Close
        Sql = "SELECT * FROM PM_Formula WHERE ltrim(rtrim(FieldName)) ='" & _
             FieldName & "' AND sortid='" & SortId & "'"
        .Open Sql, Cw_DataEnvi.DataConnect, adOpenDynamic, adLockOptimistic
        If Not .EOF Then
            Call Xtxxts("公式的计算字段使用了“" & ChName & "”，不能" & OpeStatus & "!", 0, 1)
            StopDelItem = False
            Exit Function
        End If
        '没有用在公式的内容中
        If .State = 1 Then .Close
        Sql = "SELECT * FROM PM_Formula WHERE charindex('" & FieldName & _
            "',Fcontent)<>0 AND sortid='" & SortId & "'"
        .Open Sql, Cw_DataEnvi.DataConnect, adOpenDynamic, adLockOptimistic
        If Not .EOF Then
            Call Xtxxts("公式内容使用了“" & ChName & "”，不能" & OpeStatus & "!", 0, 1)
            StopDelItem = False
            Exit Function
        End If
        '没有用在公式的限定条件中
        If .State = 1 Then .Close
        Sql = "SELECT * FROM PM_Formula WHERE charindex('" & FieldName & _
              "',FLimit)<>0 AND sortid='" & SortId & "'"
        .Open Sql, Cw_DataEnvi.DataConnect, adOpenDynamic, adLockOptimistic
        If Not .EOF Then
            Call Xtxxts("公式的限定条件使用了“" & ChName & "”，不能" & OpeStatus & "!", 0, 1)
            StopDelItem = False
            Exit Function
        End If
        '没有用在标准表的字段中
        If .State = 1 Then .Close
        Sql = "SELECT * FROM PM_StandTbl WHERE ltrim(rtrim(BzbResuItem))='" & _
              FieldName & "' AND sortid='" & SortId & "'"
        .Open Sql, Cw_DataEnvi.DataConnect, adOpenDynamic, adLockOptimistic
        If Not .EOF Then
            Call Xtxxts("标准表的结果项目使用了“" & ChName & "”，不能" & OpeStatus & "!", 0, 1)
            StopDelItem = False
            Exit Function
        End If
        '没有用在标准表的限定条件中
        If .State = 1 Then .Close
        Sql = "SELECT * FROM PM_StandTbl WHERE charindex('" & FieldName & _
               "',BzbCond)<>0 AND sortid='" & SortId & "'"
        .Open Sql, Cw_DataEnvi.DataConnect, adOpenDynamic, adLockOptimistic
        If Not .EOF Then
            Call Xtxxts("标准表的限定条件使用了“" & ChName & "”，不能" & OpeStatus & "!", 0, 1)
            StopDelItem = False
            Exit Function
        End If
        '没有用在银行代发的项目中
        If .State = 1 Then .Close
        Sql = "SELECT * FROM PM_BankItem WHERE ltrim(rtrim(DataContent))='" & _
              FieldName & "' AND sortid ='" & SortId & "'"
        .Open Sql, Cw_DataEnvi.DataConnect, adOpenDynamic, adLockOptimistic
        If Not .EOF Then
            Call Xtxxts("“" & ChName & "”是银行代发文件项目，不能" & OpeStatus & "!", 0, 1)
            StopDelItem = False
            Exit Function
        End If
        '不是报表显示项目
        If .State = 1 Then .Close
        Sql = "SELECT * FROM PM_ReportItem WHERE ltrim(rtrim(FieldName))='" & FieldName & "'" & _
              " AND PmSort='" & SortId & "'"
        .Open Sql, Cw_DataEnvi.DataConnect, adOpenDynamic, adLockOptimistic
        If Not .EOF Then
            Call Xtxxts("“" & ChName & "”是报表显示项目，不能" & OpeStatus & "!", 0, 1)
            StopDelItem = False
            Exit Function
        End If
        '没有用在复制数据的清空项中
        If .State = 1 Then .Close
        Sql = "SELECT * FROM PM_SortItem WHERE ItemID=" & ItemId & _
              " AND sortid='" & SortId & "' AND ClearFlag=1"
        .Open Sql, Cw_DataEnvi.DataConnect, adOpenDynamic, adLockOptimistic
        If Not .EOF Then
            Call Xtxxts("“" & ChName & "”是清空项目，不能" & OpeStatus & "!", 0, 1)
            StopDelItem = False
            Exit Function
        End If
'
        '不是计算月平均工资项目
        If .State = 1 Then .Close
        Sql = "SELECT * FROM PM_SortItem WHERE ItemID=" & ItemId & _
              " AND sortid='" & SortId & "' AND EndMonth=1"
        .Open Sql, Cw_DataEnvi.DataConnect, adOpenDynamic, adLockOptimistic
        If Not .EOF Then
            Call Xtxxts("“" & ChName & "”是计算月平均工资项目，不能" & OpeStatus & "!", 0, 1)
            StopDelItem = False
            Exit Function
        End If
        
    End With
    StopDelItem = True
    Set Rsc = Nothing
End Function
Public Function DelRsItem(FieldName As String, ChName As String) As Boolean
    '删除人事项目的限制
    Dim Rsc As New ADODB.Recordset
    Dim Sql As String
    Const OpeStatus = "删除"
    With Rsc
        '没有用在公式的内容中
        If .State = 1 Then .Close
        Sql = "SELECT * FROM PM_Formula WHERE charindex('" & FieldName & _
            "',Fcontent)<>0 "
        .Open Sql, Cw_DataEnvi.DataConnect, adOpenDynamic, adLockOptimistic
        If Not .EOF Then
            Call Xtxxts("公式内容使用了“" & ChName & "”，不能" & OpeStatus & "!", 0, 1)
            DelRsItem = False
            Exit Function
        End If
        '没有用在公式的限定条件中
        If .State = 1 Then .Close
        Sql = "SELECT * FROM PM_Formula WHERE charindex('" & FieldName & _
              "',FLimit)<>0 "
        .Open Sql, Cw_DataEnvi.DataConnect, adOpenDynamic, adLockOptimistic
        If Not .EOF Then
            Call Xtxxts("公式的限定条件使用了“" & ChName & "”，不能" & OpeStatus & "!", 0, 1)
            DelRsItem = False
            Exit Function
        End If
        '没有用在标准表的字段中
        If .State = 1 Then .Close
        Sql = "SELECT * FROM PM_StandTbl WHERE ltrim(rtrim(BzbHxItem))='" & _
              FieldName & "' OR ltrim(rtrim(BzbVxItem))='" & _
              FieldName & "'"
        .Open Sql, Cw_DataEnvi.DataConnect, adOpenDynamic, adLockOptimistic
        If Not .EOF Then
            Call Xtxxts("标准表的项目使用了“" & ChName & "”，不能" & OpeStatus & "!", 0, 1)
            DelRsItem = False
            Exit Function
        End If
        '没有用在标准表的限定条件中
        If .State = 1 Then .Close
        Sql = "SELECT * FROM PM_StandTbl WHERE charindex('" & FieldName & _
               "',BzbCond)<>0 "
        .Open Sql, Cw_DataEnvi.DataConnect, adOpenDynamic, adLockOptimistic
        If Not .EOF Then
            Call Xtxxts("标准表的限定条件使用了“" & ChName & "”，不能" & OpeStatus & "!", 0, 1)
            DelRsItem = False
            Exit Function
        End If
        '没有用在银行代发的项目中
        If .State = 1 Then .Close
        Sql = "SELECT * FROM PM_BankItem WHERE ltrim(rtrim(DataContent))='" & _
              FieldName & "' "
        .Open Sql, Cw_DataEnvi.DataConnect, adOpenDynamic, adLockOptimistic
        If Not .EOF Then
            Call Xtxxts("“" & ChName & "”是银行代发文件项目，不能" & OpeStatus & "!", 0, 1)
            DelRsItem = False
            Exit Function
        End If
        '不是报表显示项目
        If .State = 1 Then .Close
        Sql = "SELECT * FROM PM_ReportItem WHERE ltrim(rtrim(FieldName))='" & FieldName & "'"
        .Open Sql, Cw_DataEnvi.DataConnect, adOpenDynamic, adLockOptimistic
        If Not .EOF Then
            Call Xtxxts("“" & ChName & "”是报表显示项目，不能" & OpeStatus & "!", 0, 1)
            DelRsItem = False
            Exit Function
        End If
        '不是工资表引用的人事项目
        If .State = 1 Then .Close
        Sql = "SELECT * FROM Rs_Items WHERE AddMinusItem=1 AND FieldName<>'deptcode'" & _
              " AND FieldName<>'EmpNO' AND FieldName<>'EmpName' AND FieldName<>'EmpSort'" & _
              " and ltrim(rtrim(FieldName))='" & FieldName & "'"
        .Open Sql, Cw_DataEnvi.DataConnect, adOpenDynamic, adLockOptimistic
        If Not .EOF Then
            Call Xtxxts("“" & ChName & "”已在工资表中使用，不能" & OpeStatus & "!", 0, 1)
            DelRsItem = False
            Exit Function
        End If
        '在人事表中没有数据
        If .State = 1 Then .Close
        Sql = "select * from Rs_BasicInfo b inner join Rs_ExtendInfo e on b.EmpId=e.Empid " & _
            " where " & FieldName & " is not  null and ltrim(rtrim(" & FieldName & "))<>''"
        .Open Sql, Cw_DataEnvi.DataConnect, adOpenDynamic, adLockOptimistic
        If Not .EOF Then
            Call Xtxxts("“" & ChName & "”已在人事表中有数据，不能" & OpeStatus & "!", 0, 1)
            DelRsItem = False
            Exit Function
        End If
     End With
     DelRsItem = True
End Function
Public Sub Print_EmpInfo() '人事档案打印
Dim Max_y As Integer
With DY_Tybbyldy.Tydy
        '-----------------
        .X1 = 0: .Y1 = 0: .X2 = 0: .Y2 = 0
        '-----------------
    .PaperSize = pprA3
    .MarginLeft = "10mm"
    .MarginRight = "10mm"
    .MarginTop = "5mm"
    .MarginBottom = "5mm"
    
     .StartDoc
     .CurrentX = "3.5in"
     .FontName = "宋体": .FontBold = True
     .FontSize = 14
     DY_Tybbyldy.Tydy = "人事档案"
  
     .FontSize = 10
     .CurrentX = "1in": .CurrentY = "1.4in"
     .FontBold = False
     .FontSize = 10
     '--------------------------
      Dim r As Integer
      Dim Height_Y As Integer
      Height_Y = 2100
      For r = 1 To Ed_EmpArInfoFrm.Lbl_ItmName.Count - 1
         .CurrentX = 1600 + Ed_EmpArInfoFrm.Lbl_ItmName(r).Left
         .CurrentY = Height_Y + Ed_EmpArInfoFrm.Lbl_ItmName(r).Top
         DY_Tybbyldy.Tydy = Ed_EmpArInfoFrm.Lbl_ItmName(r).Caption & ":"
         .CurrentX = 1600 + Ed_EmpArInfoFrm.Txt_RsItm(r).Left + 100
         .CurrentY = Height_Y + Ed_EmpArInfoFrm.Lbl_ItmName(r).Top
         DY_Tybbyldy.Tydy = Ed_EmpArInfoFrm.Txt_RsItm(r).Text
         If .CurrentY > Max_y Then Max_y = .CurrentY
      Next r
    
     .FontBold = True
     .CurrentX = "1in": .CurrentY = .CurrentY + 200
     .FontBold = False
     '------------------
      .CurrentX = .CurrentX + 100
    If Ed_EmpArInfoFrm.Pic_Emp.Height + .CurrentY > .PageHeight - 1675 Then .NewPage
    .CurrentY = Ed_EmpArInfoFrm.Pic_Emp.Top + Height_Y + 100 '               .CurrentY + 100
    .CurrentX = Ed_EmpArInfoFrm.Pic_Emp.Left + 600
    .X1 = .CurrentX
    .Y1 = .CurrentY
    .X2 = Ed_EmpArInfoFrm.Pic_Emp.Width + .CurrentX
    .Y2 = Ed_EmpArInfoFrm.Pic_Emp.Height + .CurrentY
    .CurrentY = .CurrentY + Ed_EmpArInfoFrm.Pic_Emp.Height
    .Picture = Ed_EmpArInfoFrm.Pic_Emp.Picture
     '----------------
     .EndDoc
     DY_Tybbyldy.Show 1
 End With
End Sub
Public Sub initializtion()
    '删除工资数据表
    Sql = ""
    Sql = "delete pm_payroll"                       '工资表
    Sql = Sql & " delete pm_AttendRecord"            '考勤表
    Sql = Sql & " delete pm_OpeDept"                 '操作员部门权限
    Sql = Sql & " delete pm_OpeSort"                 '操作员类别权限
    Sql = Sql & " delete pm_TaxRate"                 '税率表
    Sql = Sql & " delete pm_TaxData"                 '税率数据表
    Sql = Sql & " delete pm_BankItem"                '银行代发项目
    Sql = Sql & " delete pm_BankPara"                '银行代发路径
    Sql = Sql & " delete pm_StandTblData"            '标准表数据
    Sql = Sql & " delete pm_StandTbl"                '标准表
    Sql = Sql & " delete pm_SortEmp"                 '类别人员
    Sql = Sql & " delete pm_SortItem"                '类别项目
    Sql = Sql & " delete pm_ReportItem"              '报表项目
    Sql = Sql & " delete pm_Formula"                 '公式
    Sql = Sql & " delete pm_Bank"                    '银行信息
    Sql = Sql & " delete pm_Sort"                    '工资类别
    '删除工资表、考勤表中的自定义字段,首先删除缺省值。用DropColumn函数
    
    '将选用的人事字段的addminusitem置0
    Sql = Sql & " update rs_items set addminusitem=0 WHERE (sid=1 OR sid=2 ) AND ltrim(rtrim(fieldname))<>'deptcode' AND ltrim(rtrim(fieldname))<>'empsort'" & _
          " AND ltrim(rtrim(fieldname))<>'empno' AND ltrim(rtrim(fieldname))<>'empname'"
    '将rs_items的工资项目、考勤项目删除。
    Sql = Sql & " delete rs_items WHERE (sid=3 OR sid =4) AND ynroot=0 "
    '将会计日历表复原
    Sql = Sql & " update gy_kjrlb set pmjzbz=0 "
    SqlField = DropColumn
    On Error GoTo Err1
    Cw_DataEnvi.DataConnect.BeginTrans
    If Trim(SqlField) <> "" Then
      Cw_DataEnvi.DataConnect.Execute SqlField
    End If
    Cw_DataEnvi.DataConnect.Execute Sql
    Call Xtxxts("数据初始化成功！", 0, 4)
    Cw_DataEnvi.DataConnect.CommitTrans
    Exit Sub
Err1:
   Cw_DataEnvi.DataConnect.RollbackTrans
   Call Xtxxts("数据初始化不成功！", 0, 1)
End Sub
Private Function DropColumn() As String
  '删除工资表
   SqlField = ""
   If Rsc.State = 1 Then Rsc.Close
   Set Rsc = Cw_DataEnvi.DataConnect.Execute("SELECT * FROM rs_items WHERE sid=3  AND ynroot=0 ")
   With Rsc
     Do While Not .EOF
       SqlField = SqlField & " alter table pm_Payroll drop CONSTRAINT df_" & Trim(!FieldName)
       SqlField = SqlField & " alter table pm_payroll drop column " & Trim(!FieldName)
       .MoveNext
     Loop
   End With
   '删除考勤表
   If Rsc.State = 1 Then Rsc.Close
   Set Rsc = Cw_DataEnvi.DataConnect.Execute("SELECT * FROM rs_items WHERE sid=4 ")
   With Rsc
     Do While Not .EOF
       SqlField = SqlField & " alter table pm_attendRecord drop CONSTRAINT df_" & Trim(!FieldName)
       SqlField = SqlField & " alter table pm_attendRecord drop column " & Trim(!FieldName)
       .MoveNext
     Loop
   End With
   '删除工资表中的人事项目
   If Rsc.State = 1 Then Rsc.Close
   Set Rsc = Cw_DataEnvi.DataConnect.Execute("SELECT FieldName FROM rs_Items WHERE (Sid=1 OR Sid=2) AND addminusItem=1 AND " & _
           " FieldName<>'DeptCode' AND FieldName<>'EmpNO' AND FieldName<>'EmpName' AND FieldName<>'Empsort' ")
   With Rsc
        Do While Not .EOF
            SqlField = SqlField & " alter table PM_Payroll drop column " & Trim(Rsc!FieldName)
            .MoveNext
        Loop
   End With
   
   DropColumn = SqlField
End Function
'******************************************************************
'*    模 块 名 称 :私有模块
'*    功 能 描 述 :
'*    程序员姓名  :苗鹏
'*    最后修改人  :苗鹏
'*    最后修改时间:2002/01/10
'*    备        注:
'******************************************************************
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
    tv.Enabled = False
    Set nodx = tv.Nodes.Add(, , "R", "备选项目")
    '读取表
    s = "SELECT DISTINCT TableName AS TableFrom FROM Rs_Items WHERE SID<10 AND " & 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
        .Close
    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 SID<10 AND " & 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
        .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
    
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
        
        '--------------------------------------------------读取数据信息完成-------------------------------------------------
        
        '--------------------------------------------------计算打印信息-------------------------------------------------
        '计算数据行折行信息
        ReDim iColsPerPage(0)
        iColsPerPage(0) = iStartCol
        Dim iWidth As Long
        iWidth = 0
        For i = LBound(iColWidth) + 1 + iStartCol To UBound(iColWidth)
            
            iWidth = iWidth + iColWidth(i)
            If iWidth > iClientWidth Then
                iWidth = 0
                i = i - 1
                ReDim Preserve iColsPerPage(UBound(iColsPerPage) + 1)
                iColsPerPage(UBound(iColsPerPage)) = i
            End If
        Next i
        If iWidth <> 0 Then
            ReDim Preserve iColsPerPage(UBound(iColsPerPage) + 1)
            iColsPerPage(UBound(iColsPerPage)) = UBound(sData, 2) + 1
        End If
        
        '计算每页可以打印的行数
        If iSumPerPage = 1 Then
            i = 1
        Else
            i = 0
        End If
        j = UBound(sTitle) + 2
        If iPrintStyle = PRINTSTYLE_ONETITLE Then
            iRowsPerPage = (iClientHeight - iTitleFontHeight - iDataFontHeight - 1000)  (UBound(iColsPerPage) * (iDataFontHeight + 100)) - i
        Else
            j = UBound(sTitle) + 2
            iRowsPerPage = (iClientHeight - iTitleFontHeight - iDataFontHeight - 1000)  (UBound(iColsPerPage) * j * (iDataFontHeight + 250)) - i
        End If
        If bLimitRowPerPage = True Then
            If iRowsPerPage > iLimitRowsPerPage Then
                iRowsPerPage = iLimitRowsPerPage
            End If
        End If
        
        '计算分页信息
        ReDim iPages(0)
        iPages(0) = -1
        If iVsSumEndCol = -1 Or iSplitPage = 0 Then '如果没有分页情况,只需判断本页最多能够打印的行数
            For i = LBound(sData) To UBound(sData)
                If i Mod iRowsPerPage = iRowsPerPage - 1 Then
                    ReDim Preserve iPages(UBound(iPages) + 1)
                    iPages(UBound(iPages)) = i
                End If
            Next i
        Else
        '如果有分页情况,则首先判断是否是分页行,然后循环判断下边的行
        '如果是合计行则加入本页(在数据行数小于可打印行数的情况下)
            For i = LBound(sData) To UBound(sData) '数据行数达到最大行
                
                If (i - iPages(UBound(iPages))) Mod iRowsPerPage = 0 And i <> 0 Then
                    ReDim Preserve iPages(UBound(iPages) + 1)
                    iPages(UBound(iPages)) = i
                    If Len(sData(i, iVsSumEndCol)) >= 3 Then
                        s = Right(sData(i, iVsSumEndCol), 3)
                    Else
                        s = ""
                    End If
                        
                    If s = "合计:" Or s = "小计:" Then
                        bSumRow = True
                    End If
                Else '合计分页
                    If Len(sData(i, iVsSumEndCol)) >= 3 Then
                        s = Right(sData(i, iVsSumEndCol), 3)
                    Else
                        s = ""
                    End If
                    If s = "合计:" Or s = "小计:" Or bSumRow = True Then
                        bNext = False
                        bSumRow = False
                        If iVsSumEndCol = 0 Then
                            ReDim Preserve iPages(UBound(iPages) + 1)
                            iPages(UBound(iPages)) = i
                        Else
                            
                            For j = iVsSumEndCol To iVsBeginCol + 1 Step -1
                                If Len(sData(i + 1, j - 1)) >= 3 Then
                                    s = Right(sData(i + 1, j - 1), 3)
                                Else
                                    s = ""
                                End If
                                If s = "合计:" Or s = "小计:" Then
                                    bNext = True
                                    i = i + 1
                                    '如果当前行达到最大行,分页
                                    If (i - iPages(UBound(iPages))) Mod iRowsPerPage = 0 Then
                                        ReDim Preserve iPages(UBound(iPages) + 1)
                                        iPages(UBound(iPages)) = i
                                        bNext = False
                                    End If
                                End If
                            Next j
                            '如果到了第0列,分页
                            If j = iVsBeginCol Then
                                ReDim Preserve iPages(UBound(iPages) + 1)
                                iPages(UBound(iPages)) = i
                            End If
                        End If
                        '因为如果bNext=true 则数据行多移动了一行,减去
                        If bNext = True Then
                            i = i - 1
                        End If
                        '判断起始列的合计情况
                        bNext = False
                        Do While True
                            If i < UBound(sData) Then
                                If Len(sData(i + 1, iVsBeginCol)) >= 3 Then
                                    s = Right(sData(i + 1, iVsBeginCol), 3)
                                Else
                                    s = ""
                                End If
                                If s = "小计:" Or s = "合计:" Then
                                    i = i + 1
                                    bNext = True
                                Else
                                    Exit Do
                                End If
                            Else
                                Exit Do
                            End If
                        Loop
                        If bNext = True Then
                            ReDim Preserve iPages(UBound(iPages) + 1)
                            iPages(UBound(iPages)) = i
                        End If
                    End If
                End If
            Next i
        End If
        '剩下的行也要占一页
        If iPages(UBound(iPages)) <> UBound(sData) Then
            ReDim Preserve iPages(UBound(iPages) + 1)
            iPages(UBound(iPages)) = UBound(sData)
        End If
            
    End With
'    如果某页的行数为0则删除列,上面的分页程序繁琐,有时候会造成某页的数据行为0
'    的情况,在此进行处理,有必要重新考虑分页的程序结构???
    Dim iPagesB() As Long
    ReDim iPagesB(0)
    iPagesB(0) = iPages(0)
    For i = 1 To UBound(iPages)
        If iPages(i) <> iPages(i - 1) Then
            ReDim Preserve iPagesB(UBound(iPagesB) + 1)
            iPagesB(UBound(iPagesB)) = iPages(i)
        End If
    Next i
    ReDim iPages(UBound(iPagesB))
    iPages = iPagesB
    '合计每行的数据形成本页合计
    Dim sTotal() As String
    ReDim sTotal(0, 0)
    If iSumPerPage = 1 Then
        If UBound(iPages) >= 1 Then
            ReDim sTotal(UBound(iPages) - 1, UBound(sData, 2))
            For i = 0 To UBound(sTotal) '行
                For j = LBound(iCols) + 1 To UBound(iCols) '列
                    If iColType(j) = DATA_NUMERIC Then
                        For n = iPages(i) + 1 To iPages(i + 1)
                            bNext = False
                            '合计行的信息不加入本页合计
                            For m = iVsBeginCol To IIf(iVsSumEndCol = -1, 0, iVsSumEndCol)
                                If Len(sData(n, m)) >= 3 Then
                                    s = Right(sData(n, m), 3)
                                Else
                                    s = ""
                                End If
                                If s = "合计:" Or s = "小计:" Then
                                    bNext = True
                                    Exit For
                                End If
                            Next m
                            If bNext = False Then
                                sTotal(i, j - 1) = Val(sTotal(i, j - 1)) + Val(Replace(sData(n, j - 1), ",", ""))
                            End If
                        Next n
                    End If
                Next j
            Next i
        End If
    End If
    
    '格式化合计信息
    bNext = False
    If iShowAllCols = 0 Then
        
        For i = LBound(sData) To UBound(sData)
            If bNext = True Then
                Exit For
            End If
            For j = iVsSumEndCol To LBound(sData, 2) Step -1
                
                If Len(sData(i, j)) >= 3 Then
                    s = Right(sData(i, j), 3)
                Else
                    s = ""
                End If
                If s = "小计:" Then
                   
                    If i - 1 >= 0 Then
                        sData(i, iVsSumEndCol + 1) = Replace(sData(i - 1, j), s, "") & s
                    Else
                        bNext = True
                        Exit For
                    End If
                End If
                If sData(i, j) = "合计:" Then
                    sData(i, iVsSumEndCol + 1) = "合计:"
                End If
                
            Next j
        Next i
    End If
    
    If bNext = True Then
        For i = LBound(sData) To UBound(sData)
            For j = iVsSumEndCol To LBound(sData, 2) Step -1
                If sData(i, j) <> "" Then
                    If sData(i, j) = "合计:" Then
                        sData(i, iVsSumEndCol + 1) = sData(i, j)
                    Else
                        sData(i, iVsSumEndCol + 1) = Replace(sData(i, j), "小计:", "") & "小计:"
                    End If
                    Exit For
                End If
            Next j
        Next i
    End If
    '--------------------------------------------------计算打印信息完毕-------------------------------------------------
    
    
    '--------------------------------------------------打印数据-------------------------------------------------
    '输送数据
    Dim dy As Long
    dy = 0
    With DY_Tybbyldy.Tydy
        .StartDoc
            For i = LBound(iPages) + 1 To UBound(iPages)
                .FontName = sTitleFontName
                .FontSize = iTitleFontSize
                .CalcText = sRTitle
                .CurrentX = (iClientWidth - .TextWid) / 2 + iPageLeft
                .CurrentY = iPageTop
                DY_Tybbyldy.Tydy = sRTitle
                .CurrentX = (iClientWidth - .TextWid) / 2 + iPageLeft - 500
                .CurrentY = .CurrentY + 100
                .CalcText = sRTitle
                .DrawLine .CurrentX, .CurrentY, (iClientWidth + .TextWid) / 2 + iPageLeft + 500, .CurrentY
                .CurrentY = .CurrentY + 200
                .CurrentX = .MarginLeft
                .FontName = sDataFontName
                .FontSize = iDataFontSize
                dy = .CurrentY
                '打印分组信息
                If iSplitPage = 1 And iVsSumEndCol <> -1 Then
                    If Len(sData(iPages(i - 1) + 1, iVsSumEndCol)) >= 3 Then
                        If Right(sData(iPages(i - 1) + 1, iVsSumEndCol), 3) = "小计:" Then
                            If iPages(i - 1) >= 0 Then
                                DY_Tybbyldy.Tydy = sTitle(UBound(sTitle), iVsSumEndCol) & ":" & sData(iPages(i - 1) + 1 - 1, iVsSumEndCol) & Space(10) & sSubTitle
                            End If
                        Else
                            DY_Tybbyldy.Tydy = sTitle(UBound(sTitle), iVsSumEndCol) & ":" & sData(iPages(i - 1) + 1, iVsSumEndCol) & Space(10) & sSubTitle
                        End If
                    Else
                        DY_Tybbyldy.Tydy = sTitle(UBound(sTitle), iVsSumEndCol) & ":" & sData(iPages(i - 1) + 1, iVsSumEndCol) & Space(10) & sSubTitle
                    End If
                Else
                    DY_Tybbyldy.Tydy = sSubTitle
                End If
                .CurrentX = .PageWidth - .MarginRight - .TextWidth("第100页 共100页 ")
                .CurrentY = dy
                DY_Tybbyldy.Tydy = "第" & i & "页 共" & UBound(iPages) & "页 "
                If iPrintStyle = PRINTSTYLE_ONETITLE Then '只输出一个表头
                    For j = LBound(iColsPerPage) + 1 To UBound(iColsPerPage)
                        .CurrentX = .MarginLeft
                        .CurrentY = .CurrentY + 100
                        
                        .StartTable
                            '设置表格属性
                            .TableCell(tcRows) = iPages(i) - iPages(i - 1) + UBound(sTitle) + 1
                            .TableCell(tcCols) = iColsPerPage(j) - iColsPerPage(j - 1)
                            
                            For m = 1 To .TableCell(tcRows) '行高
                                .TableCell(tcRowHeight, m) = iDataFontHeight + 100
                            Next m
                            For m = 1 To .TableCell(tcCols) '列宽
                                .TableCell(tcColWidth, , m) = iColWidth(m + iColsPerPage(j - 1))
                            Next m
                            '填充表头
                            For m = 1 To UBound(sTitle) + 1
                                For k = 1 To .TableCell(tcCols)
                                    .TableCell(tcAlign, m, k) = 6
                                    .TableCell(tcText, m, k) = Trim(sTitle(m - 1, k + iColsPerPage(j - 1) - 1))
                                    .CalcText = .TableCell(tcText, m, k)
                                    If (.TableCell(tcColWidth, , k) - .TextWid - 100) > 0 Then
                                        .TableCell(tcText, m, k) = Space((.TableCell(tcColWidth, , k) - .TextWid - 100) / .TextWidth("测试")) & .TableCell(tcText, m, k)
                                    End If
                                Next k
                            Next m
                            '填充数据
                            For m = UBound(sTitle) + 1 + 1 To .TableCell(tcRows)
                                For k = 1 To .TableCell(tcCols)
                                    If iColType(k + iColsPerPage(j - 1)) = DATA_NUMERIC Then
                                        .TableCell(tcAlign, m, k) = 8 'RightMiddle
                                    Else
                                        .TableCell(tcAlign, m, k) = 6 'LeftMiddle
                                    End If
                                    If Len(sData(m + iPages(i - 1) - 1, k + iColsPerPage(j - 1) - 1)) >= 3 Then
                                        If Right(sData(m + iPages(i - 1) - 1, k + iColsPerPage(j - 1) - 1), 3) <> "小计:" And _
                                            Right(sData(m + iPages(i - 1) - 1, k + iColsPerPage(j - 1) - 1), 3) <> "合计:" Then
                                            s = sData(m + iPages(i - 1) - 1, k + iColsPerPage(j - 1) - 1)
                                        End If
                                    End If
                                    If Trim(iColFormat(k + iColsPerPage(j - 1))) = "" Then
                                        .TableCell(tcText, m, k) = sData(m + iPages(i - 1) - 1, k + iColsPerPage(j - 1) - 1)
                                    Else
                                        .TableCell(tcText, m, k) = Format(sData(m + iPages(i - 1) - 1, k + iColsPerPage(j - 1) - 1), iColFormat(k + iColsPerPage(j - 1)))
                                    End If
                                Next k
                            Next m
                            '填充合计信息
                            If iSumPerPage = 1 And UBound(sTotal) > 0 Then
                                .TableCell(tcRows) = .TableCell(tcRows) + 1
                                .TableCell(tcRowHeight, .TableCell(tcRows)) = iDataFontHeight + 100
                                For k = 1 To .TableCell(tcCols)
                                    If iColType(k + iColsPerPage(j - 1)) = DATA_NUMERIC Then
                                        .TableCell(tcAlign, .TableCell(tcRows), k) = 8 'RightMiddle
                                    Else
                                        .TableCell(tcAlign, .TableCell(tcRows), k) = 6 'LeftMiddle
                                    End If
                                    .TableCell(tcText, .TableCell(tcRows), k) = Format(sTotal(i - 1, k + iColsPerPage(j - 1) - 1), iColFormat(k + iColsPerPage(j - 1)))
                                Next k
                                If j = 1 Then
                                    .TableCell(tcText, .TableCell(tcRows), 1) = "本页小计:"
                                End If
                            End If
                        .EndTable
                    Next j
                Else '每行数据输出表头
                    For n = iPages(i - 1) + 1 To iPages(i) 'n为数据行
                        For j = LBound(iColsPerPage) + 1 To UBound(iColsPerPage) 'j为一个数据行分的断
                            .CurrentX = .MarginLeft
                            .CurrentY = .CurrentY + 100
                            
                            .StartTable
                                '设置表格属性
                                .TableCell(tcRows) = UBound(sTitle) + 1 + 1
                                .TableCell(tcCols) = iColsPerPage(j) - iColsPerPage(j - 1)
                                
                                For m = 1 To .TableCell(tcRows) '行高
                                    .TableCell(tcRowHeight, m) = iDataFontHeight + 100
                                Next m
                                For m = 1 To .TableCell(tcCols) '列宽
                                    .TableCell(tcColWidth, , m) = iColWidth(m + iColsPerPage(j - 1))
                                Next m
                                '填充表头
                                For m = 1 To UBound(sTitle) + 1
                                    For k = 1 To .TableCell(tcCols)
                                        .TableCell(tcAlign, m, k) = 6
                                        .TableCell(tcText, m, k) = Trim(sTitle(m - 1, k + iColsPerPage(j - 1) - 1))
                                        .CalcText = .TableCell(tcText, m, k)
                                        If (.TableCell(tcColWidth, , k) - .TextWid - 100) > 0 Then
                                            .TableCell(tcText, m, k) = Space((.TableCell(tcColWidth, , k) - .TextWid - 100) / .TextWidth("测试")) & .TableCell(tcText, m, k)
                                        End If
                                    Next k
                                Next m
                                '填充数据
                                For k = 1 To .TableCell(tcCols)
                                    If iColType(k + iColsPerPage(j - 1)) = DATA_NUMERIC Then
                                        .TableCell(tcAlign, m, k) = 8 'RightMiddle
                                    Else
                                        .TableCell(tcAlign, m, k) = 6 'LeftMiddle
                                    End If
                                    If Trim(iColFormat(k + iColsPerPage(j - 1) - 1)) = "" Then
                                        .TableCell(tcText, .TableCell(tcRows), k) = sData(n, k + iColsPerPage(j - 1) - 1)
                                    Else
                                        .TableCell(tcText, .TableCell(tcRows), k) = Format(sData(n, k + iColsPerPage(j - 1) - 1), iColFormat(k + iColsPerPage(j - 1) - 1))
                                    End If
                                Next k
                                
                            .EndTable
                        Next j
                        '如果不是本页的最后一行并且后边没有本业合计,添加分隔线
                        If n <> iPages(i) Or iSumPerPage = 1 Then
                            .CurrentY = .CurrentY + 200
                            .CurrentX = .MarginLeft
                            .PenStyle = psDash
                            .DrawLine .CurrentX, .CurrentY, .PageWidth - .MarginRight, .CurrentY
                            .PenStyle = psSolid
                        End If
                    Next n
                    
                    '添加本页合计信息
                    If iSumPerPage = 1 Then
                        For j = LBound(iColsPerPage) + 1 To UBound(iColsPerPage) 'j为一个数据行分的断
                            .CurrentX = .MarginLeft
                            .CurrentY = .CurrentY + 100
                            .StartTable
                                '设置表格属性
                                .TableCell(tcRows) = UBound(sTitle) + 1 + 1
                                .TableCell(tcCols) = iColsPerPage(j) - iColsPerPage(j - 1)
                                
                                For m = 1 To .TableCell(tcRows) '行高
                                    .TableCell(tcRowHeight, m) = iDataFontHeight + 100
                                Next m
                                For m = 1 To .TableCell(tcCols) '列宽
                                    .TableCell(tcColWidth, , m) = iColWidth(m + iColsPerPage(j - 1))
                                Next m
                                '填充表头
                                For m = 1 To UBound(sTitle) + 1
                                    For k = 1 To .TableCell(tcCols)
                                        .TableCell(tcAlign, m, k) = 6
                                        .TableCell(tcText, m, k) = Trim(sTitle(m - 1, k + iColsPerPage(j - 1) - 1))
                                        .CalcText = .TableCell(tcText, m, k)
                                        If (.TableCell(tcColWidth, , k) - .TextWid - 100) > 0 Then
                                            .TableCell(tcText, m, k) = Space((.TableCell(tcColWidth, , k) - .TextWid - 100) / .TextWidth("测试")) & .TableCell(tcText, m, k)
                                        End If
                                    Next k
                                Next m
                                '填充数据
                                For k = 1 To .TableCell(tcCols)
                                    If iColType(k + iColsPerPage(j - 1)) = DATA_NUMERIC Then
                                        .TableCell(tcAlign, m, k) = 8 'RightMiddle
                                    Else
                                        .TableCell(tcAlign, m, k) = 6 'LeftMiddle
                                    End If
                                    .TableCell(tcText, .TableCell(tcRows), k) = Format(sTotal(i - 1, k + iColsPerPage(j - 1) - 1), iColFormat(k + iColsPerPage(j - 1)))
                                Next k
                                If j = LBound(iColsPerPage) + 1 Then
                                    .TableCell(tcText, .TableCell(tcRows), 1) = "本页小计:"
                                End If
                            .EndTable
                        Next j
                    End If
                    
                End If
                If i <> UBound(iPages) Then
                    .NewPage
                End If
            Next i
        .EndDoc
        DY_Tybbyldy.PageHScroll.Max = .Pagecount
        DY_Tybbyldy.PageHScroll.Min = 1
        DY_Tybbyldy.PageHScroll.Value = 1
    End With
    If bPrint = False Then
        DY_Tybbyldy.Show 1
    Else
        DY_Tybbyldy.Tydy.PrintDoc
    End If
    
    Exit Function
ErrCtrl:
    If rs.State = 1 Then
        rs.Close
    End If
    Set rs = Nothing
End Function
Public Function SetupPage(frmSetup As DY_Dyymsz, frmPrint As DY_Tybbyldy) As Boolean '打印设置
    Dim Tsxx As String
    Dim Papername(1 To 70) As String
  
    Papername(1) = "Letter, 8 1/2 x 11 英寸"
    Papername(2) = "Letter Small, 8

						