+

VB开发的ERP系统

    If FieldName = "taxitem" Then
        Select Case Chk_Adm.Value
            Case 1 '本类别允许扣税
                If Not Rsc.EOF Then
                    Sql = "Update PM_SortItem set HaltFlag=0 from PM_SortItem,Rs_Items R" & _
                         " where PM_SortItem.ItemID=R.ItemId and SortID='" & Trim(LrText(0)) & "'" & _
                         " and Fieldname='" & FieldName & "'"
                    Cw_DataEnvi.DataConnect.Execute Sql
                Else    '本类别无个人税、实发工资、扣税项目这三个字段
                    Call TaxPay(FieldName)
                End If
            Case 0
                If Not Rsc.EOF Then
                    Sql = "Update PM_SortItem set HaltFlag=1 from PM_SortItem,Rs_Items R" & _
                         " where PM_SortItem.ItemID=R.ItemId and SortID='" & Trim(LrText(0)) & "'" & _
                         " and Fieldname='" & FieldName & "'"
                    Cw_DataEnvi.DataConnect.Execute Sql
                End If
        End Select
    End If
End Sub
Private Sub TaxPaywage()
    '"在本类别扣税"属性为真时，tax、Paywage自动加到该类别的项目中
    Call TaxPay("tax")
    Call TaxPay("taxitem")
    Call TaxPay("paywage")
End Sub
Private Sub TaxPay(FielaName As String)
    Dim Rsc As New ADODB.Recordset
    Dim DisOrder As Integer
    If Rsc.State = 1 Then Rsc.Close
    Set Rsc = Cw_DataEnvi.DataConnect.Execute("select ItemId from Rs_Items where ltrim(rtrim(FieldName))='" & FielaName & "'")
    If Not Rsc.EOF Then
        ItemId = Rsc!ItemId
    End If
    
    If Rsc.State = 1 Then Rsc.Close
    Set Rsc = Cw_DataEnvi.DataConnect.Execute("select DisplayOrder from PM_SortItem where Sortid='" & Trim(LrText(0)) & "' order by DisplayOrder desc")
    If Not Rsc.EOF Then
      DisOrder = Rsc!DisplayOrder + 1
    Else
      DisOrder = 1
    End If
    
    Sql = "insert PM_SortItem(SortID,ItemId,DisplayOrder ) values('" & Trim(LrText(0).Text) & "'," & ItemId & "," & DisOrder & ")"
    Cw_DataEnvi.DataConnect.Execute Sql
    
    Set Rsc = Nothing
End Sub
Private Function Cshlrxx(lrztxx As Integer) As Boolean              '初始化录入字段信息
    Dim Rsc As New ADODB.Recordset
    TextChangeLock = True       '关闭文本框Chang事件
    Call FillImageCombo(ImgCbo_Sort, "PM_ClassSe", 2)
    If lrztxx = 1 Then
    
        '增加新记录时将文本框清空
        For jsqte = 0 To Max_Text_Index
            If Len(Trim(Textstr(jsqte, 1))) <> 0 Then
                LrText(jsqte).Text = ""
                LrText(jsqte).Tag = ""
            End If
            TextValiJudgeLock(jsqte) = True
        Next jsqte
       
        '[>>
        '在此处可添加新增记录时初始化设置
        Chk_Adm.Value = 0
        Chk_Tax.Value = 0
        Chk_Extra = 0
        Chk_Extra.Enabled = False
        Chk_Copy = 0
        Chk_Halt = 0
        ImgCbo_Sort.Enabled = False
        ImgCbo_Sort.Text = ""
        Chk_Stop = 0
        '<<]
    Else
    
        '修改记录时根据记录关键字(编码)从数据表中读入其他字段内容
        With RecTemp
            
            Sqlstr = "SELECT *  FROM Pm_Sort  Where  SortId='" & Trim(CzxsGrid.TextMatrix(CzxsGrid.Row, Sydz("001", GridStr(), Szzls))) & "'"
            Set RecTemp = Cw_DataEnvi.DataConnect.Execute(Sqlstr)
       
            '记录如存在则读入其内容,否则提示记录已被其他人删除
            If Not RecTemp.EOF Then
                LrText(0).Text = Trim(.Fields("SortId") & "")            '工资类别编号
                LrText(1).Text = Trim(.Fields("SortName") & "")            '工资类别名称
                If !AdmDeductTax Then
                    Chk_Adm.Value = 1
                    ImgCbo_Sort.Enabled = True
                Else
                    Chk_Adm.Value = 0
                    ImgCbo_Sort.Enabled = False
                End If
                If !DeductTax Then
                    Chk_Tax.Value = 1
                Else
                    Chk_Tax.Value = 0
                End If
                If !NeedExtra Then
                    Chk_Extra = 1
                Else
                    Chk_Extra = 0
                End If
                If Chk_Tax Then
                    Chk_Extra.Enabled = True
                Else
                    Chk_Extra.Enabled = False
                End If
                If !DataCopy Then
                    Chk_Copy = 1
                Else
                    Chk_Copy = 0
                End If
                If !HaltFlag Then
                    Chk_Halt = 1
                Else
                    Chk_Halt = 0
                End If
                If Rsc.State = 1 Then Rsc.Close
                Sqlstr = "SELECT p.*,r.SortName as CSName  FROM Pm_Sort p,PM_Sort r  Where  p.CSortid=r.Sortid and p.SortId='" & Trim(CzxsGrid.TextMatrix(CzxsGrid.Row, Sydz("001", GridStr(), Szzls))) & "'"
                Set Rsc = Cw_DataEnvi.DataConnect.Execute(Sqlstr)
                If Not Rsc.EOF Then
                    ImgCbo_Sort.Text = Trim(Rsc.Fields("CSortID") & "") & Space(1) & Trim(Rsc.Fields("CSName"))
                Else
                    ImgCbo_Sort.Text = Trim(.Fields("CSortID") & "")
                End If
                If !SortHalt Then
                    Chk_Stop = 1
                Else
                    Chk_Stop = 0
                End If
            Else
                Tsxx = "该记录已经被其他人删除,请刷新当前数据!"
                Call Xtxxts(Tsxx, 0, 4)
                Call Cancel
                TextChangeLock = False
                Exit Function
            End If
        End With
    End If
    
    Cshlrxx = True
    TextChangeLock = False
    
End Function

Private Sub Scdqjl()                 '删 除 当 前 记 录

    Dim Yhanswer As Integer
    
    '判断用户是否有此功能执行权限,如有则写上机日志(进入)
    If Not Security_Log(Str_RightEdit, Xtczybm, 1, True) Then
         Exit Sub
    End If
    
    '非数据行不能删除
    If CzxsGrid.Row < CzxsGrid.FixedRows Then
        Exit Sub
    End If
  
    '用户确认是否删除记录
    Tsxx = "请确认是否删除当前记录?"
    Yhanswer = Xtxxts(Tsxx, 2, 2)
    
    If Yhanswer = 2 Then
        Exit Sub
    End If

    On Error GoTo Cwcl
  
    Cw_DataEnvi.DataConnect.BeginTrans

    '[>>以下需自定义部分
    Cw_DataEnvi.DataConnect.Execute "delete PM_Sort where SortID = '" + Trim(CzxsGrid.TextMatrix(CzxsGrid.Row, Sydz("001", GridStr(), Szzls))) + "'"
    '以上为自定义部分<<]
  
    Cw_DataEnvi.DataConnect.CommitTrans

    CzxsGrid.RemoveItem CzxsGrid.Row

    Exit Sub
  
Cwcl:

    Cw_DataEnvi.DataConnect.RollbackTrans
    
    If Err.Number = -2147217873 Then                '(-2147217873 为SQL Server 2000通过建立外键产生的错误号)
        Tsxx = "该编码已经被使用,不能删除!"
        Call Xtxxts(Tsxx, 0, 1)
        Exit Sub
    Else
        Tsxx = "出现未知情况,该编码不能被删除!"
        Call Xtxxts(Tsxx, 0, 1)
        Exit Sub
    End If
    
End Sub

'*******************以下区域为编写自定义过程区域**********************


'*******************以上区域为编写自定义过程区域**********************

'******************以下为基本处理程序(固定不变)************************'
Private Sub Form_KeyUp(KeyCode As Integer, Shift As Integer)        '支持热键操作

    If Shift = 2 Then
        Select Case UCase(Chr(KeyCode))
            Case "P"                                                                          'Ctrl+P 打印
                If SzToolbar.Buttons("dy").Visible And SzToolbar.Buttons("dy").Enabled Then
                    Call bbyl(False)
                End If
            Case "A"                                                                          'Ctrl+A 增加
                '判断用户是否有此功能执行权限,如有则写上机日志(进入)
                If Not Security_Log(Str_RightEdit, Xtczybm, 1, True) Then
                    Exit Sub
                End If
                If SzToolbar.Buttons("zj").Visible And SzToolbar.Buttons("zj").Enabled Then
                    Call Toolbjzt
                    Lrzt = 1
                    Call Cshlrxx(Lrzt)
                    LrText(0).Enabled = True
                    LrText(0).SetFocus
                End If
            Case "D"                                                                          'Ctrl+D 删除
                If SzToolbar.Buttons("sc").Visible And SzToolbar.Buttons("sc").Enabled Then
                    Call Scdqjl
                End If
        End Select
    End If
    
End Sub

Private Sub SzToolbar_ButtonClick(ByVal Button As MSComctlLib.Button)
   
    Select Case Button.Key
        Case "ymsz"                                          '页面设置
            Dyymctbl.Show 1
        Case "yl"                                            '预 览
            Call bbyl(True)
        Case "dy"                                            '打 印
            Call bbyl(False)
        Case "zj"                                            '增 加
            '判断用户是否有此功能执行权限,如有则写上机日志(进入)
            If Not Security_Log(Str_RightEdit, Xtczybm, 1, True) Then
                Exit Sub
            End If
            Call Toolbjzt
            Lrzt = 1
            Call Cshlrxx(Lrzt)
            LrText(0).Enabled = True
            LrText(0).SetFocus
        Case "xg"                                            '修 改
            Call Xgdqjl
        Case "sc"                                            '删 除
            Call Scdqjl
        Case "sx"                                            '刷 新
            Call Cxnrtcwg
        Case "bz"                                            '帮 助
            Call F1bz
        Case "fh"                                            '退 出
            Unload Me
        End Select
        
End Sub

Private Sub CzxsGrid_DblClick()                            '修改当前编码记录

    Call Xgdqjl
  
End Sub

Private Sub Xgdqjl()                                       '修改当前编码记录
    '判断用户是否有此功能执行权限,如有则写上机日志(进入)
    If Not Security_Log(Str_RightEdit, Xtczybm, 1, True, False) Then
        BcCommand.Enabled = False
    End If
    
    If CzxsGrid.Row < CzxsGrid.FixedRows Then
        Exit Sub
    End If
    
    Call Toolbjzt
    Lrzt = 2
    
    If Cshlrxx(Lrzt) Then
        LrText(1).SetFocus
        LrText(0).Enabled = False
    End If
  
End Sub

Private Sub Toolbjzt()                                     'Toolbar状态(编辑状态)

    StTab.TabEnabled(1) = True
    StTab.Tab = 1
    Frame1.Enabled = True
    StTab.TabEnabled(0) = False
    CzxsGrid.Enabled = False
  
    With SzToolbar
        .Buttons("ymsz").Enabled = False
        .Buttons("dy").Enabled = False
        .Buttons("yl").Enabled = False
        .Buttons("zj").Enabled = False
        .Buttons("xg").Enabled = False
        .Buttons("sc").Enabled = False
        .Buttons("sx").Enabled = False
    End With
  
End Sub

Private Sub Toolfbjzt()                                    'Toolbar状态(非编辑状态)

    StTab.TabEnabled(0) = True
    StTab.Tab = 0
    CzxsGrid.Enabled = True
    Frame1.Enabled = False
    StTab.TabEnabled(1) = False
    Lrzt = 0
    
    With SzToolbar
        .Buttons("ymsz").Enabled = True