++

VB开发的ERP系统

    '判断用户是否有此功能执行权限,如有则写上机日志(进入)
    If Not Security_Log("Khgl_Title_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("001", GridStr(), Szzls)))
    
    If Len(Trim(str_Temp)) = 0 Then
        Tsxx = "请选择考核类别!"
        Call Xtxxts(Tsxx, 0, 1)
        Exit Sub
    End If
    Select Case khlbsy
        Case "zb"
            '设置考核类别编码
            Khgl_Target.str_TitleCode = str_Temp
            '设置考核类别名称
            Khgl_Target.tsLabel(0).Caption = Khgl_Target.tsLabel(0).Caption + Trim(CzxsGrid.TextMatrix(CzxsGrid.Row, Sydz("002", GridStr(), Szzls)))
            Khgl_Target.Show 1
            
        Case "ys"
            '设置考核类别编码
            Khgl_ValMark.str_TitleCode = str_Temp
            '设置考核类别名称
            Khgl_ValMark.tsLabel(0).Caption = Khgl_ValMark.tsLabel(0).Caption + Trim(CzxsGrid.TextMatrix(CzxsGrid.Row, Sydz("002", GridStr(), Szzls)))
            Khgl_ValMark.Show 1
            
        Case "cp"
            '设置考核类别编码
            Khgl_Appraise.str_TitleCode = str_Temp
            '设置考核类别名称
            Khgl_Appraise.tsLabel(0).Caption = Khgl_Appraise.tsLabel(0).Caption + Trim(CzxsGrid.TextMatrix(CzxsGrid.Row, Sydz("002", GridStr(), Szzls)))
            Khgl_Appraise.Show 1
            
        Case "dx"
            '设置考核类别编码
            Khgl_Object.str_TitleCode = str_Temp
            '设置考核类别名称
            Khgl_Object.tsLabel(0).Caption = Khgl_Object.tsLabel(0).Caption + Trim(CzxsGrid.TextMatrix(CzxsGrid.Row, Sydz("002", GridStr(), Szzls)))
            Khgl_Object.Show 1

        Case "gb"
            '计算标志=0不允许关闭
            If Val(CzxsGrid.TextMatrix(CzxsGrid.Row, Sydz("010", GridStr(), Szzls))) = 0 Then
                Tsxx = "该考核类别没有计算,不能关闭!"
                Call Xtxxts(Tsxx, 0, 1)
                Exit Sub
            End If
            '关闭标志=1不能再次关闭
            If Val(CzxsGrid.TextMatrix(CzxsGrid.Row, Sydz("011", GridStr(), Szzls))) = 1 Then
                Tsxx = "该考核类别已经关闭,不能再次关闭!"
                Call Xtxxts(Tsxx, 0, 1)
                Exit Sub
            End If
            
            rec_Recordset.Open "SELECT * FROM Kh_Title WHERE TitleCode= '" + str_Temp + "'", Cw_DataEnvi.DataConnect, adOpenDynamic, adLockOptimistic
            If Not rec_Recordset.EOF Then
                rec_Recordset.Fields("CloseFlag") = 1
                rec_Recordset.Update
                Tsxx = "该考核类别关闭成功!"
                Call Xtxxts(Tsxx, 0, 4)
            End If
            rec_Recordset.Close
            '刷新网格
            Call Cxnrtcwg
            
        Case "kb"
            '编码方案
            Khgl_CopyTitle.CodScheme = CodScheme
            Khgl_CopyTitle.Lbl_codescheme = Me.Lbl_codescheme.Caption
            '考核类别编码列号
            Khgl_CopyTitle.int_col = Sydz("001", GridStr(), Szzls)
            
            Set rec_Recordset = Cw_DataEnvi.DataConnect.Execute("SELECT * FROM Kh_v_Title where TitleCode='" & Trim(str_Temp) & "'")
    
            '设置考核类别编码
            Khgl_CopyTitle.LrText(6).Text = str_Temp
            '设置考核类别名称
            Khgl_CopyTitle.LrText(7).Text = rec_Recordset.Fields("TitleName")
            
            Khgl_CopyTitle.LrText(0).Text = str_Temp
            Khgl_CopyTitle.LrText(1).Text = rec_Recordset.Fields("TitleName")
            Khgl_CopyTitle.LrText(2).Text = Format(Xtrq, "yyyy-mm-dd")
            Khgl_CopyTitle.LrText(3).Tag = rec_Recordset.Fields("CheckCode")    '测评规则
            Khgl_CopyTitle.LrText(3).Text = rec_Recordset.Fields("CheckName")    '测评规则
            Khgl_CopyTitle.LrText(4).Text = rec_Recordset.Fields("TitleDigit")    '保留小数
            If rec_Recordset.Fields("LockFlag") = True Then
                Khgl_CopyTitle.Opt_LockFlag(1).Value = True
            Else
                Khgl_CopyTitle.Opt_LockFlag(0).Value = True
            End If
            rec_Recordset.Close
            
            Khgl_CopyTitle.Show 1
                         
            '填 充 网 格
            Call Cxnrtcwg
            Add_Tree
            
            Exit Sub
    End Select
End Sub
           


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

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

Private Sub Add_Tree() '添加树项
    Dim aDo_Sort As New Recordset
    TreeView.Nodes.Clear
    TreeView.Nodes.Add , 4, "T", "考核类别", "T"
    
    Set aDo_Sort = Cw_DataEnvi.DataConnect.Execute("select a.*,mj=(select count(*) from Kh_Title where Kh_Title.ParentCode=a.TitleCode) from Kh_Title a order by a.TitleCode")
    
    With aDo_Sort
        Do While Not .EOF
            If Trim("" & aDo_Sort!ParentCode) = "" Then
                If !mj < 1 Then
                    Set nodX = TreeView.Nodes.Add("T", 4, "T" & Trim(.Fields("TitleCode")), "(" & Trim(.Fields("TitleCode")) & ")" & Trim(.Fields("TitleName")), "C")
                Else
                    Set nodX = TreeView.Nodes.Add("T", 4, "T" & Trim(.Fields("TitleCode")), "(" & Trim(.Fields("TitleCode")) & ")" & Trim(.Fields("TitleName")), "Cl")
                End If
                nodX.EnsureVisible
            Else
                If !mj < 1 Then
                    Set nodX = TreeView.Nodes.Add("T" & Trim(!ParentCode), 4, "T" & Trim(.Fields("TitleCode")), "(" & Trim(.Fields("TitleCode")) & ")" & Trim(.Fields("TitleName")), "C")
                Else
                    Set nodX = TreeView.Nodes.Add("T" & Trim(!ParentCode), 4, "T" & Trim(.Fields("TitleCode")), "(" & Trim(.Fields("TitleCode")) & ")" & Trim(.Fields("TitleName")), "Cl")
                End If
            End If
            .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_Title_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_Title_edit", Xtczybm, 1) Then
                Exit Sub
            End If
            Call Toolbjzt
            Lrzt = 1
            Call Cshlrxx(Lrzt)
            If CzxsGrid.Row > 0 Then
                LrText(0) = Trim(CzxsGrid.TextMatrix(CzxsGrid.Row, Sydz("001", GridStr(), Szzls)))
            End If
            LrText(0).Enabled = True
            LrText(0).SetFocus
            Opt_LockFlag(0).Value = True
            LrText(3).Enabled = True
            Ydcommand1(3).Enabled = True
        Case "xg"                                            '修 改
            Call Xgdqjl
        Case "sc"                                            '删 除
            Call Scdqjl
        Case "sx"                                            '刷 新
            Call Cxnrtcwg
            Add_Tree
            
        Case "zb"                                           '指标
            Call dykhlb("zb")
            
        Case "ys"                                           '要素
            Call dykhlb("ys")
            
        Case "cp"                                           '测评
            Call dykhlb("cp")
            
        Case "dx"                                           '对象
            Call dykhlb("dx")
            
        Case "gb"                                           '关闭
            Call dykhlb("gb")
            
        Case "kb"                                           '拷贝
            Call dykhlb("kb")
            
            
        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_Title_edit", Xtczybm, 1) Then
        Exit Sub
    End If
    If CzxsGrid.Row < CzxsGrid.F