-

VB开发的ERP系统

    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