-

VB开发的ERP系统

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

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 Drxtztcs()                                   '读入系统帐套参数
   
    Dim Ztcsbrec As New ADODB.Recordset
    Dim RecTemp As New ADODB.Recordset
    Dim Sqlstr As String
  
    With Ztcsbrec
        '金额总位数
        .Open "Select * From Gy_AccInformation Where SystemCode='Cwzz'", Cw_DataEnvi.DataConnect, adOpenDynamic, adLockOptimistic
        .MoveFirst
        .Find "itemcode='cwjezws'"
        If Not Ztcsbrec.EOF Then
            Xtjezws = Val(Trim(Ztcsbrec.Fields("itemvalue")))
        End If
        
        '数量总位数
        .MoveFirst
        .Find "itemcode='cwslzws'"
        If Not Ztcsbrec.EOF Then
            Xtslzws = Val(Trim(Ztcsbrec.Fields("itemvalue")))
        End If
   
        '单价总位数
        .MoveFirst
        .Find "itemcode='cwdjzws'"
        If Not Ztcsbrec.EOF Then
            Xtdjzws = Val(Trim(Ztcsbrec.Fields("itemvalue")))
        End If
        
        '金额小数位数
        .MoveFirst
        .Find "itemcode='cwjexsws'"
        If Not Ztcsbrec.EOF Then
            Xtjexsws = Val(Trim(Ztcsbrec.Fields("itemvalue")))
        End If
   
        '数量小数位数
        .MoveFirst
        .Find "itemcode='cwslxsws'"
        If Not Ztcsbrec.EOF Then
            Xtslxsws = Val(Trim(Ztcsbrec.Fields("itemvalue")))
        End If
        
        '单价小数位数
        .MoveFirst
        .Find "itemcode='cwdjxsws'"
        If Not Ztcsbrec.EOF Then
            Xtdjxsws = Val(Trim(Ztcsbrec.Fields("itemvalue")))
        End If
        .Close
    End With
  
End Sub

Public Function GetDeptHp(bMinLvl As Boolean, sDName As String) As String
    Dim frm As New Hp_Dept_Frm
    With frm
        .bMinLvl = bMinLvl
        .Show 1
        GetDeptHp = .sDept
        sDName = .sDeptName
    End With
    Set frm = Nothing
End Function

'单据打印输出
Public Sub Bill_TextPrint(LrText As Object, Text_code As String, XtReportCode As String, Optional PrintDirect As Boolean = False)
    Dim aDo_Rec As New Recordset
    With DY_Tybbyldy
        '=====================
        Set aDo_Rec = Cw_DataEnvi.DataConnect.Execute("select * from Xt_dybbcs where bbbm='" & XtReportCode & "'")
        .Tydy.PaperSize = aDo_Rec!PaperSize
        .Tydy.Orientation = aDo_Rec!PaperScfx
        .Tydy.MarginLeft = aDo_Rec!bbzbj
        .Tydy.MarginTop = aDo_Rec!bbsbj
        aDo_Rec.Close
        '=====================

        Set aDo_Rec = Cw_DataEnvi.DataConnect.Execute("select * from Xt_text_input where text_group_code='" & Text_code & "' order by text_index")
        '<<<<<<<<
        .Tydy.StartDoc
      
            '=========
            Do While Not aDo_Rec.EOF '表头数据
                If aDo_Rec!YnPrint = True Then
                    .Tydy.CurrentX = aDo_Rec!LabelLeft: .Tydy.CurrentY = aDo_Rec!PrintTop
                    .Tydy = Trim(aDo_Rec!Text_Name) & ":"
                    .Tydy.CurrentX = aDo_Rec!PrintLeft: .Tydy.CurrentY = aDo_Rec!PrintTop
                    .Tydy = LrText(aDo_Rec!text_Index)
                End If
                aDo_Rec.MoveNext
            Loop
            '==========
         
        .Tydy.EndDoc
        
        '判断是直接打印还是预览
        If Not PrintDirect Then
            .Show 1                                     '预览
        Else
            Call DY_DytsFrm.Output_Printer              '直接打印输出
            Unload DY_Tybbyldy                          '卸载打印预览窗体
            Unload DY_DytsFrm                           '卸载打印选择提示选项
        End If
           
    End With

End Sub



Public Sub Print_Empchange() '人事变动打印
Dim Max_y As Integer
Dim tmpRs As New Recordset

With DY_Tybbyldy.Tydy
        '-----------------
        .X1 = 0: .Y1 = 0: .X2 = 0: .Y2 = 0
        '=====================
        Set tmpRs = Cw_DataEnvi.DataConnect.Execute("select * from Xt_dybbcs where bbbm='" & XtReportCode & "'")
        .PaperSize = tmpRs!PaperSize
        .Orientation = tmpRs!PaperScfx
        .MarginLeft = tmpRs!bbzbj
        .MarginTop = tmpRs!bbsbj
        .MarginBottom = tmpRs!bbxbj
        .MarginRight = tmpRs!bbybj
        .StartDoc
        
        .CurrentX = "3.5in"
        .FontName = Trim(tmpRs!Bbbtfont)
        .FontSize = Trim(tmpRs!Bbbtsize)
        .FontBold = True
        DY_Tybbyldy.Tydy = "人事变动处理"
        
        .CurrentX = "1in": .CurrentY = "1.4in"
        .FontSize = Trim(tmpRs!Bbsjqsize)
        .FontName = Trim(tmpRs!Bbsjqfont)
        .FontBold = False
        
        tmpRs.Close
     
      Dim r As Integer
      Dim Height_Y As Integer
      Height_Y = 2100
      For r = 0 To Ed_EmpChgFrm.TsLabel.count - 1
         .CurrentX = 1600 + Ed_EmpChgFrm.TsLabel(r).Left
         .CurrentY = Height_Y + Ed_EmpChgFrm.TsLabel(r).Top
         DY_Tybbyldy.Tydy = Ed_EmpChgFrm.TsLabel(r).Caption
         .CurrentX = 1600 + Ed_EmpChgFrm.LrText(r).Left + 100
         .CurrentY = Height_Y + Ed_EmpChgFrm.TsLabel(r).Top
         DY_Tybbyldy.Tydy = Ed_EmpChgFrm.LrText(r).Text
         If .CurrentY > Max_y Then Max_y = .CurrentY
      Next r

'   设置照片的位置，程序手动调的

     '----------------
     .EndDoc
     DY_Tybbyldy.Show 1
 End With
End Sub


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