++

VB开发的ERP系统

        Call Xtxxts(Tsxx, 0, 1)
        Exit Sub
    Else
        Tsxx = "出现未知情况,该测评者不能被删除!"
        Call Xtxxts(Tsxx, 0, 1)
        Exit Sub
    End If

End Sub



'*******************以下区域为编写自定义过程区域**********************
Private Sub Imgcbo_Title_Click()
    str_GroupCode = ""
    str_TitleCode = GetComboKey(Imgcbo_Title, 0)
    str_titleRoot = Mid(str_TitleCode, 1, int_titleRootlen)
    str_TitleName = Imgcbo_Title.Text
    Add_Tree
    Call Cxnrtcwg
End Sub
Private Function AddTitleCode()
    Dim RecExist As New Recordset
    
    FillImageCombo Imgcbo_Title, "Khgl_TitleCompute", 1
  
    Sqlstr = "SELECT TitleCode,titleName From Kh_Title where (endflag=1  and CloseFlag=0 and CreateTime=(select max(createTime) from kh_title where endflag=1  and CloseFlag=0 ))"
    Set RecExist = Cw_DataEnvi.DataConnect.Execute(Sqlstr)
    If Not RecExist.EOF Then
        If Len(Trim(RecExist.Fields("titleName"))) > 0 Then
            Imgcbo_Title.Text = RecExist.Fields("titleName")
            str_TitleName = RecExist.Fields("titleName")
        End If
    End If
    
    str_TitleCode = GetComboKey(Imgcbo_Title, 0)
End Function
Private Function TitleRoot() As String

    Dim RecTemp As New Recordset                   '临时记录集
    
    '取考核类别编码方案
    Sqlstr = "select * from Gy_CodeScheme where ItemCode='" & Trim("Khgl_Title") & "'"
    Set RecTemp = Cw_DataEnvi.DataConnect.Execute(Sqlstr)
    int_titleRootlen = Mid(RecTemp.Fields("CodeScheme"), 1, 1)
    '取考核类别编码的根结点编码
    TitleRoot = Mid(str_TitleCode, 1, int_titleRootlen)
    RecTemp.Close

End Function


'函数dykh，调用考核窗体

Private Sub dykh()
    Dim str_Temp As String                 '考核类别编码
    Dim rec_Recordset As New Recordset     '临时记录集
    
    '判断用户是否有此功能执行权限,如有则写上机日志(进入)
    If Not Security_Log("Khgl_Result_edit", Xtczybm, 1) Then
        Exit Sub
    End If
    If CzxsGrid.Row <= 0 Then
        Exit Sub
    End If
    
    '当前测评者
    str_Temp = Trim(CzxsGrid.TextMatrix(CzxsGrid.Row, Sydz("003", GridStr(), Szzls)))
    
    If Len(Trim(str_Temp)) = 0 Then
        Tsxx = "请选择测评者!"
        Call Xtxxts(Tsxx, 0, 1)
        Exit Sub
    End If

    '设置考核类别编码
    Khgl_GroupDataSub.str_TitleCode = str_TitleCode
    Khgl_GroupDataSub.str_GroupCode = CzxsGrid.TextMatrix(CzxsGrid.Row, Sydz("001", GridStr(), Szzls))
    Khgl_GroupDataSub.str_ValListCode = CzxsGrid.TextMatrix(CzxsGrid.Row, Sydz("003", GridStr(), Szzls))
    Khgl_GroupDataSub.int_ValListCodeID = CzxsGrid.TextMatrix(CzxsGrid.Row, Sydz("005", GridStr(), Szzls))
    
    '设置考核类别名称
    Khgl_GroupDataSub.TsLabel(0).Caption = Khgl_GroupDataSub.TsLabel(0).Caption + str_TitleName
    '设置考核组名称
    Khgl_GroupDataSub.TsLabel(1).Caption = Khgl_GroupDataSub.TsLabel(1).Caption + CzxsGrid.TextMatrix(CzxsGrid.Row, Sydz("002", GridStr(), Szzls))
    '设置测评者
    Khgl_GroupDataSub.TsLabel(2).Caption = Khgl_GroupDataSub.TsLabel(2).Caption + CzxsGrid.TextMatrix(CzxsGrid.Row, Sydz("004", GridStr(), Szzls))
    '设置测评者序号
    Khgl_GroupDataSub.TsLabel(3).Caption = Khgl_GroupDataSub.TsLabel(3).Caption + CzxsGrid.TextMatrix(CzxsGrid.Row, Sydz("005", GridStr(), Szzls))
    
    Khgl_GroupDataSub.Show 1
    Call Cxnrtcwg
End Sub

Private Function MaxNum(Index As Integer) As Integer
    '读取最大号,参数0取单据最大号，1取测评者最大号
    Dim str_sql As String
    Dim rec_temp As New Recordset
   
    MaxNum = 0
    If Index = 0 Then
        str_sql = "select max(BaseMainID) as MaxNumber from Kh_BaseMain"
    Else
        str_sql = " select max(ValListCodeID) as MaxNumber from Kh_BaseMain " & _
                  " where TitleCode = '" & str_TitleCode & "'" & _
                  " and   ValListCode = '" & Trim(LrText(2).Tag) & "'" & _
                  " and   GroupCode = '" & Trim(str_GroupCode) & "'"
                  
    End If
    
    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 IsSuccess()
    '判断考核数据有效性
    Dim str_sql As String
    Dim rec_temp As New Recordset
    Dim rec_obj As New Recordset
    Dim int_row, int_col, int_Count, lsjsq As Integer
    Dim str_titleRoot As String                    '考核类别根结点编码
    
    
    '为加快显示速度,将网格刷新动作冻结
    CzxsGrid.Redraw = False
    
     '取考核类别编码方案
    sql_str = "select * from Gy_CodeScheme where ItemCode='" & Trim("Khgl_Title") & "'"
    Set rec_temp = Cw_DataEnvi.DataConnect.Execute(sql_str)
    
    '取考核类别编码的根结点编码
    str_titleRoot = Mid(str_TitleCode, 1, Mid(rec_temp.Fields("CodeScheme"), 1, 1))
    rec_temp.Close
        
    '取当前考核类别的考核要素记录数
    Sqlstr = " SELECT FactorCode " & _
             " FROM Kh_v_ValMark where TitleCode='" & str_titleRoot & "'" & _
             " Order By ValMarkID"
    Set rec_temp = Cw_DataEnvi.DataConnect.Execute(Sqlstr)
    int_Count = rec_temp.RecordCount
    rec_temp.Close
        
        
    For int_row = CzxsGrid.Rows - 1 To CzxsGrid.FixedRows Step -1
    '取当前考核组的成员
        Sqlstr = " SELECT 1," & Chr(10) & _
                " RsCount=(select count(1) from Kh_BaseMain LEFT OUTER JOIN Kh_BaseSub " & Chr(10) & _
                            " on Kh_BaseMain.BaseMainid=Kh_BaseSub.BaseMainid " & Chr(10) & _
                            " where Kh_BaseMain.TitleCode='" & str_TitleCode & "'" & Chr(10) & _
                            " and  Kh_BaseMain.GroupCode='" & CzxsGrid.TextMatrix(int_row, Sydz("001", GridStr(), Szzls)) & "'" & Chr(10) & _
                            " and  Kh_BaseMain.ValListCode='" & CzxsGrid.TextMatrix(int_row, Sydz("003", GridStr(), Szzls)) & "'" & Chr(10) & _
                            " and  Kh_BaseMain.ValListCodeID=" & CzxsGrid.TextMatrix(int_row, Sydz("005", GridStr(), Szzls)) & ")" & Chr(10) & _
                " FROM Kh_BaseMain LEFT OUTER JOIN Kh_BaseSub" & Chr(10) & _
                " on Kh_BaseMain.BaseMainid=Kh_BaseSub.BaseMainid " & Chr(10) & _
                " where Kh_BaseMain.TitleCode='" & str_TitleCode & "'" & Chr(10) & _
                " and  Kh_BaseMain.GroupCode='" & CzxsGrid.TextMatrix(int_row, Sydz("001", GridStr(), Szzls)) & "'" & Chr(10) & _
                " and  Kh_BaseMain.ValListCode='" & CzxsGrid.TextMatrix(int_row, Sydz("003", GridStr(), Szzls)) & "'" & Chr(10) & _
                " and  Kh_BaseMain.ValListCodeID=" & CzxsGrid.TextMatrix(int_row, Sydz("005", GridStr(), Szzls)) & Chr(10) & _
                " group by Kh_BaseMain.empid"
                 
                 
        Set rec_obj = Cw_DataEnvi.DataConnect.Execute(Sqlstr)
        
        '如果（考核要素个数*考核成员个数）与考核数据子表的个数相等，则认为有效，否则无效
        If rec_obj.EOF Then
            '如果没有考核成员，则认为无效
            CzxsGrid.Cell(flexcpBackColor, int_row, Qslz, int_row, CzxsGrid.Cols - 1) = &HE0E0E0
        Else
            If int_Count * rec_obj.RecordCount <> rec_obj.Fields("RsCount") Then
                CzxsGrid.Cell(flexcpBackColor, int_row, Qslz, int_row, CzxsGrid.Cols - 1) = &HE0E0E0
            End If
        End If
        rec_obj.Close

    Next int_row
    
    '为加快显示速度,将网格刷新动作冻结
    CzxsGrid.Redraw = True
End Sub


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



'******************以下为基本处理程序(固定不变)************************'

Private Sub Add_Tree() '添加树项
    
    Dim aDo_Sort As New Recordset
    Dim Sqlstr As String         '临时字符串
    
    Sqlstr = "SELECT GroupCode,GroupName from Kh_Group where TitleCode='" & str_TitleCode & "' order by TitleCode,GroupCode"
    TreeView.Nodes.Clear
    TreeView.Nodes.Add , 4, "T", "考核组", "T"
    Set aDo_Sort = Cw_DataEnvi.DataConnect.Execute(Sqlstr)
    With aDo_Sort
        Do While Not .EOF
            Set nodX = TreeView.Nodes.Add("T", 4, "!" & Trim(.Fields("GroupCode")), Trim(.Fields("GroupName")), "C")
            nodX.Tag = Trim(.Fields("GroupCode"))
            nodX.EnsureVisible
            .MoveNext
        Loop

    End With
  
End Sub
 
'编码方案
Private Sub Text_CodScheme()

    Dim aDo_Sort As New Recordset
    Dim i As Integer, h As Integer
    Set aDo_Sort = Cw_DataEnvi.DataConnect.Execute("select * from Gy_CodeScheme where ItemCode='" & Trim(CodSchemeIndex) & "'")
    CodScheme = Trim(aDo_Sort!CodeScheme)
    aDo_Sort.Close
    '-------------
    StTab.Tab = 1
    Lbl_codescheme.Caption = ""
    For i = 1 To Len(CodScheme)
        For h = 1 To Val(Mid(CodScheme, i, 1))
            Lbl_codescheme = Lbl_codescheme & "*"
        Next
        Lbl_codescheme = Lbl_codescheme & " "
    Next i
    Lbl_codescheme = Trim(Lbl_codescheme)

End Sub



Private Sub imgSplitter_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    
    With imgSplitter
        picSplitter.Move .Left, .Top, .Width \ 2, .Height - 20
    End With
    picSplitter.Visible = True
    mbMoving = True

End Sub

Private Sub imgSplitter_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    
    Dim sglPos As Single
    If mbMoving Then
        sglPos = X + imgSplitter.Left
        If sglPos < sglSplitLimit Then
            picSplitter.Left = sglSplitLimit
        ElseIf sglPos > Me.Width - sglSplitLimit Then
            picSplitter.Left = Me.Width - sglSplitLimit
        Else
            picSplitter.Left = sglPos
        End If
    End If

End Sub

Private Sub imgSplitter_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    
    SizeControls picSplitter.Left
    picSplitter.Visible = False
    mbMoving = False
   ' StTab.Refresh

End Sub

Private Sub SizeControls(X As Single)
    
    On Error Resume Next

    '设置 Width 属性
    If X < 2000 Then X = 2000
    If X > (Me.Width - 5000) Then X = Me.Width - 5000
    TreeView.Width = X - 100
    imgSplitter.Left = X
    StTab.Left = X + 40
    StTab.Width = Me.Width - (TreeView.Width + 300)
    '设置 Top 属性
    TreeView.Top = tbToolBar.Height + picTitles.Height
    StTab.Top = TreeView.Top
    '设置 height 属性
    TreeView.Height = Me.ScaleHeight - (picTitles.Top + picTitles.Height)
    'Frame1.Width = StTab.Width - Frame1.Left * 2
    Dim St_tab As Integer
    St_tab = StTab.Tab
    StTab.Tab = 0
    CzxsGrid.Width = StTab.Width - CzxsGrid.Left * 2
    StTab.Tab = St_tab
    StTab.Height = TreeView.Height
    imgSplitter.Top = TreeView.Top
    imgSplitter.Height = TreeView.Height

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("Khgl_Result_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_Result_edit", Xtczybm, 1) Then
                Exit Sub
            End If
            If Not (Len(str_GroupCode) > 0) Then Exit Sub
            Call Toolbjzt
            Lrzt = 1
            Call Cshlrxx(Lrzt)