++

VB开发的ERP系统

    Dim RecExist As New Recordset           '临时记录集
    Dim str_sql As String                   '临时字符串
    Dim str_ValListCode   As String
    Dim int_ValListCodeID As Integer
    Dim int_EmpID  As Integer
    
    '打开单据子表动态集
    If Rec_CodeSetSub.State = 1 Then Rec_CodeSetSub.Close
    Rec_CodeSetSub.Open "Select * From Kh_GroupSub Where 1=2", Cw_DataEnvi.DataConnect, adOpenDynamic, adLockOptimistic
    With Rec_CodeSetSub
        '判断考核组是否被考核数据表使用
        str_sql = " select ValListCode,ValListCodeID from Kh_BaseMain " & _
                  " where  TitleCode     = '" & str_TitleCode & "'" & _
                  " and    GroupCode     = '" & Trim(LrText(0).Text) & "'"
                  
        Set RecExist = Cw_DataEnvi.DataConnect.Execute(str_sql)
        
        If RecExist.EOF Then   '没有被考核数据表使用
            For int_temp = 1 To LvListView.ListItems.count
                int_EmpID = Mid(LvListView.ListItems(int_temp).Key, 2, Len(LvListView.ListItems(int_temp).Key))
                '将已选人员写入考核组子表
                .AddNew
                .Fields("GroupCode") = Trim(LrText(0).Text)                                                      '考核组编码
                .Fields("EmpID") = int_EmpID                                                                     '职员id号
                .Update
            Next int_temp
        Else   '被考核数据表使用
            str_ValListCode = RecExist.Fields("ValListCode")
            int_ValListCodeID = RecExist.Fields("ValListCodeid")
            For int_temp = 1 To LvListView.ListItems.count
                int_EmpID = Mid(LvListView.ListItems(int_temp).Key, 2, Len(LvListView.ListItems(int_temp).Key))
                
                '将已选人员写入考核组子表
                .AddNew
                .Fields("GroupCode") = Trim(LrText(0).Text)                                                       '考核组编码
                .Fields("EmpID") = int_EmpID                                                                      '职员id号
                .Update
                                
                If RecExist.State = 1 Then RecExist.Close
                '判断考核人员是否存在,如果不存在则增加
                str_sql = " select * from Kh_BaseMain " & _
                          " where  TitleCode     = '" & str_TitleCode & "'" & _
                          " and    GroupCode     = '" & Trim(LrText(0).Text) & "'" & _
                          " and    ValListCode   = '" & str_ValListCode & "'" & _
                          " and    ValListCodeid =  " & int_ValListCodeID & _
                          " and    Empid =  " & int_EmpID
                
                RecExist.Open str_sql, Cw_DataEnvi.DataConnect, adOpenDynamic, adLockOptimistic
                If RecExist.EOF Then
                    RecExist.AddNew
                    RecExist.Fields("BaseMainID") = MaxNum()                                                 '考核数据表ID号
                    RecExist.Fields("TitleCode") = str_TitleCode                                             '考核类别
                    RecExist.Fields("ValListCode") = str_ValListCode                                         '测评者
                    RecExist.Fields("ValListCodeID") = int_ValListCodeID                                     '测评者序号
                    RecExist.Fields("GroupCode") = Trim(LrText(0).Text)                                      '考核组编码
                    RecExist.Fields("EmpID") = int_EmpID                                                     '对象编码
                    RecExist.Fields("BaseTotal") = 0                                                         '考核总分
                    RecExist.Update
                    
                End If
                
            Next int_temp
            
            '删除考核数据表中已不属于该组的成员
            str_sql = "  DELETE FROM Kh_BaseMain " & _
                      "  WHERE  TitleCode  = '" & Trim(str_TitleCode) & "'" & _
                      "  and    GroupCode  = '" & Trim(LrText(0).Text) & "'" & _
                      "  and    Empid not IN " & _
                      " (SELECT Kh_GroupSub.Empid from Kh_GroupSub,Kh_Group " & _
                      "  where  Kh_Group.TitleCode='" & Trim(str_TitleCode) & "'" & _
                      "  and    Kh_Group.GroupCode='" & Trim(LrText(0).Text) & "'" & _
                      "  and    Kh_GroupSub.GroupCode=Kh_Group.GroupCode )"
            Cw_DataEnvi.DataConnect.Execute (str_sql)

        End If
    End With
    RecExist.Close
    
End Sub
Private Sub Imgcbo_Title_Click()
    str_TitleCode = GetComboKey(Imgcbo_Title, 0)
    Call Cxnrtcwg
End Sub


Private Sub Command1_Click(Index As Integer)
    Dim int_temp As Integer
    Dim lvlistitem As ListItem
    
    Select Case Index
        Case 0
        
            For int_temp = 1 To LvListAll.ListItems.count
                Set lvlistitem = LvListView.ListItems.Add(, LvListAll.ListItems(int_temp).Key, LvListAll.ListItems(int_temp).Text, , "dr")
                     lvlistitem.Tag = LvListAll.ListItems(int_temp).Tag
            Next int_temp
            LvListAll.ListItems.Clear
        Case 1
            If LvListAll.ListItems.count > 0 Then
                Set lvlistitem = LvListView.ListItems.Add(, LvListAll.SelectedItem.Key, LvListAll.SelectedItem.Text, , "dr")
                    lvlistitem.Tag = LvListAll.SelectedItem.Tag
                LvListAll.ListItems.Remove LvListAll.SelectedItem.Key
         End If
         
        Case 2
            If LvListView.ListItems.count > 0 Then
                Set lvlistitem = LvListAll.ListItems.Add(, LvListView.SelectedItem.Key, LvListView.SelectedItem.Text, , "dr")
                lvlistitem.Tag = LvListView.SelectedItem.Tag
                LvListView.ListItems.Remove LvListView.SelectedItem.Key
            End If
        Case 3
            For int_temp = 1 To LvListView.ListItems.count
                Set lvlistitem = LvListAll.ListItems.Add(, LvListView.ListItems(int_temp).Key, LvListView.ListItems(int_temp).Text, , "dr")
                lvlistitem.Tag = LvListView.ListItems(int_temp).Tag
            Next int_temp
            LvListView.ListItems.Clear
    End Select
End Sub

Private Sub AddLvlist()
    LvListAll.ColumnHeaders.Add 1, , "待选人员", LvListAll.Width - 68
    LvListView.ColumnHeaders.Add 1, , "已选人员", LvListView.Width - 68
    LvListView.View = lvwReport
    LvListAll.View = lvwReport
End Sub
Private Sub lvListInput(tcfs As Integer)
    '参数填充方式：是否填充待选人员，1是0否
    Dim str_Sqltemp As String
    Dim rst_temp As New ADODB.Recordset
    Dim lvlistitem As ListItem
    Dim str_GroupCode As String
    
    On Error GoTo errExecute
    
    LvListAll.ListItems.Clear
    LvListView.ListItems.Clear
        
    If tcfs = 0 Then
        '填充待选人员
        str_Sqltemp = " SELECT * from Kh_v_Object" & _
                      " WHERE TitleCode='" & Trim(str_TitleCode) & "'"
        Set rst_temp = Cw_DataEnvi.DataConnect.Execute(str_Sqltemp)
        LvListView.ListItems.Clear
        With rst_temp
            Do While Not .EOF
                Set lvlistitem = LvListAll.ListItems.Add(, "~" & Trim(.Fields("EmpID")), Trim(.Fields("EmpName")), , "dr")
                lvlistitem.Tag = Trim(.Fields("EmpNo"))
                .MoveNext
            Loop
            .Close
            
        End With
    
    Else
        '填充待选人员
        str_GroupCode = Trim(LrText(0).Text)
    
        str_Sqltemp = " SELECT * from Kh_v_Object" & _
                      " where  TitleCode='" + str_TitleCode + "'" & _
                      " and Kh_v_Object.EmpID not in ( select isnull(EmpID,-1) from Kh_v_groupsub where TitleCode='" & Trim(str_TitleCode) & "' and GroupCode='" & str_GroupCode & "' )"

        Set rst_temp = Cw_DataEnvi.DataConnect.Execute(str_Sqltemp)
        With rst_temp
               
            Do While Not .EOF
               Set lvlistitem = LvListAll.ListItems.Add(, "~" & Trim(.Fields("EmpID")), Trim(.Fields("EmpName")), , "dr")
               lvlistitem.Tag = Trim(.Fields("EmpNo"))
               .MoveNext
            Loop
            .Close
                
        End With
        '填充已选人员
        str_Sqltemp = " SELECT * from Kh_v_GroupSub" & _
                      " where TitleCode='" & Trim(str_TitleCode) & "' and  GroupCode='" & str_GroupCode & "' "
        Set rst_temp = Cw_DataEnvi.DataConnect.Execute(str_Sqltemp)
        With rst_temp
               
            Do While Not .EOF
                If Len(Trim(.Fields("EmpID"))) > 0 Then
                    Set lvlistitem = LvListView.ListItems.Add(, "~" & Trim(.Fields("EmpID")), Trim(.Fields("EmpName")), , "dr")
                    lvlistitem.Tag = Trim(.Fields("EmpNo"))
                End If
                .MoveNext
            Loop
            .Close
                
        End With
    End If
            
    
    Set rst_temp = Nothing
    Exit Sub
'进行错误处理
errExecute:
    If Err.Number = -2147467259 Then
        Tsxx = "数据库连接失败,请检查网络!"
        Call Xtxxts(Tsxx, 0, 1)
        Exit Sub
    Else
        Tsxx = "出现未知情况,请重新执行该功能!"
        Call Xtxxts(Tsxx, 0, 1)
        Exit Sub
    End If

End Sub

Private Function MaxNum() As Integer
    '读取最大号,参数0取单据最大号，1取测评者最大号
    Dim str_sql As String
    Dim rec_temp As New Recordset
   
    MaxNum = 0
    
    str_sql = "select max(BaseMainID) as MaxNumber from Kh_BaseMain"
    
    Set rec_temp = Cw_DataEnvi.DataConnect.Execute(str_sql)
    
    If Not IsNull(Trim(rec_temp.Fields("MaxNumber"))) Then
        MaxNum = Trim(rec_temp.Fields("MaxNumber"))
    Else
        MaxNum = 0
    End If
    
    MaxNum = MaxNum + 1
End Function

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

'*******************************以下为基本处理程序(固定不变)*******************************************'
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("Khgl_Group_edit", Xtczybm, 1) 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("Khgl_Group_edit", Xtczybm, 1) Then
                Exit Sub
            End If
            If Not Len(Trim(str_TitleCode)) > 0 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("Khgl_Group_edit", Xtczybm, 1) Then
        Exit Sub
    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
    '设置考核规则组合框不可用
    Imgcbo_Title.Enabled = False