++

VB开发的ERP系统

    jdzygs = 10
    Select Case KeyAscii
        Case vbKeyReturn
            If Kjjdzy(jdzygs) Then
                KeyAscii = 0
            End If
        Case 39           '屏蔽"'"
            KeyAscii = 0
    End Select

End Sub

Private Sub Form_Load()
    
    SizeControls imgSplitter.Left
  
    '填充考核类别列表框
    Call AddTitleCode
  
    str_titleRoot = TitleRoot()
    
    Add_Tree

  
    '打印报表标题信息
    ReportTitle = "考核组考核数据录入"
   
    '调入打印页面设置窗体
    XtReportCode = "Khgl_GroupData"
    Load Dyymctbl
  
    '以下为文本框处理程序(读入文本框录入信息)
    TextGroupCode = "Khgl_GroupData"
    Call Drwbkxx(TextGroupCode, Textvar(), Textboolean(), Textint(), Textstr())
    Call Wbkcsh
  
    '调入网格设置信息
    GridCode = "Khgl_GroupData"
    Call BzWgcsh(CzxsGrid, GridCode, GridInf(), GridBoolean(), GridInt(), GridStr())
    Qslz = GridInf(1)
    Sjhgd = GridInf(2)
    Szzls = CzxsGrid.Cols - 1
    
    '填 充 网 格
    Call Cxnrtcwg
     
    '初始化toolbar,tab卡状态
    StTab.Tab = 0
    StTab.TabEnabled(1) = False
    
    '显示当前考核类别名称
    Imgcbo_Title.Refresh
         
    'Frame1.Enabled = False
   
    '设置为非录入状态
    Lrzt = 0
    
End Sub

Private Sub Cxnrtcwg()                               '查询内容填充网格
    
    Dim Sqlstr As String              '查询连接串
    Dim Jsqte As Long                 '查询临时使用变量
  
    '为加快显示速度,将网格刷新动作冻结
    CzxsGrid.Redraw = False
    
    '[>>查询连接串
    Sqlstr = " SELECT DISTINCT dbo.Kh_BaseMain.ValListCode    , dbo.Kh_ValList.ValListName , " & _
             "        dbo.Kh_BaseMain.ValListCodeID  , dbo.Kh_BaseMain.GroupCode   ," & _
             "        dbo.Kh_Group.GroupName " & _
             " FROM   dbo.Kh_ValList " & _
             "        RIGHT OUTER JOIN dbo.Kh_BaseMain ON            " & _
             "        dbo.Kh_ValList.ValListCode = dbo.Kh_BaseMain.ValListCode " & _
             "        LEFT OUTER JOIN  dbo.Kh_Group ON " & _
             "        dbo.Kh_BaseMain.GroupCode = dbo.Kh_Group.GroupCode " & _
             " where  dbo.Kh_BaseMain.GroupCode='" & str_GroupCode & "'" & _
             " and    dbo.Kh_BaseMain.TitleCode='" & str_TitleCode & "'" & _
             " order by dbo.Kh_BaseMain.ValListCode,dbo.Kh_BaseMain.ValListCodeID  "
  
    '<<]
  
    Set Cxnrrec = Cw_DataEnvi.DataConnect.Execute(Sqlstr)
    With Cxnrrec
        CzxsGrid.Rows = CzxsGrid.FixedRows
        If .EOF And .BOF Then
            CzxsGrid.Redraw = True
            Exit Sub
        End If
        Jsqte = CzxsGrid.FixedRows
        Do While Not .EOF
            CzxsGrid.AddItem ""
            Call Jltcwg(Cxnrrec, Jsqte)                              '调入填充网格子过程
            CzxsGrid.RowHeight(Jsqte) = Sjhgd                        '设置网格高度
            .MoveNext
            Jsqte = Jsqte + 1
        Loop
    End With
  
    '将网格刷新动作解冻
    CzxsGrid.Redraw = True
    '判断考核数据有效性
    Call IsSuccess
End Sub

Private Sub Jltcwg(Jlbrec As ADODB.Recordset, Rowjsq As Long)           '记录内容填充网格
        
    '[>>以下为自定义部分
    With Jlbrec
        CzxsGrid.TextMatrix(Rowjsq, Sydz("001", GridStr(), Szzls)) = Trim(.Fields("GroupCode") & "")        '考核组编码
        CzxsGrid.TextMatrix(Rowjsq, Sydz("002", GridStr(), Szzls)) = Trim(.Fields("GroupName") & "")        '考核组名称
        CzxsGrid.TextMatrix(Rowjsq, Sydz("003", GridStr(), Szzls)) = Trim(.Fields("ValListCode") & "")      '测评者编码
        CzxsGrid.TextMatrix(Rowjsq, Sydz("004", GridStr(), Szzls)) = Trim(.Fields("ValListName") & "")      '测评者
        CzxsGrid.TextMatrix(Rowjsq, Sydz("005", GridStr(), Szzls)) = Trim(.Fields("ValListCodeID") & "")    '测评者序号
        
    End With
    '以上为自定义部分<<]

End Sub

Private Sub Form_Resize()
    
    On Error Resume Next
    Dim St_tab As Integer
    If Me.Height < 7000 Then Me.Height = 7000
    If Me.Width < 10000 Then Me.Width = 10000

    StTab.Width = Me.Width - (TreeView.Width + 300)
    StTab.Height = Me.Height - (StTab.Top + 400)
    TreeView.Height = Me.Height - (TreeView.Top + 400)
    imgSplitter.Height = TreeView.Height

    St_tab = StTab.Tab
    StTab.Tab = 0
    CzxsGrid.Width = StTab.Width - CzxsGrid.Left * 2
    CzxsGrid.Height = StTab.Height - 600
    StTab.Tab = St_tab
    
    GsToolbar.Left = Me.Width - GsToolbar.Width - 140
    
End Sub

Private Sub Form_Unload(Cancel As Integer)             '窗体卸载
    
    Set Cxnrrec = Nothing
    Set Rec_CodeSet = Nothing
    Unload Dyymctbl

End Sub

Private Function Bclrsj() As Boolean                   '判断录入数据有效性,并保存数据
    
    Dim Jsqte As Integer
    Dim MaxNumber, MaxID As Integer '考核数据最大号，测评者最大号
    Dim rec_temp As New Recordset   '临时记录集
  
    '对文本框录入内容进行为零和为空判断(固定不变)
    With Rec_CodeSet
        For Jsqte = 0 To Max_Text_Index
            If Textint(Jsqte, 8) = 1 Then     '字段不能为空
                If Len(Trim(LrText(Jsqte).Text)) = 0 Then
                    Tsxx = Textstr(Jsqte, 7) & "不能为空!"
                    Call Xtxxts(Tsxx, 0, 1)
                    LrText(Jsqte).SetFocus
                    Bclrsj = False
                    Exit Function
                End If
            Else
                If Textint(Jsqte, 8) = 2 Then   '字段不能为零
                    If Val(Trim(LrText(Jsqte).Text)) = 0 Then
                        Tsxx = Textstr(Jsqte, 7) & "不能为零!"
                        Call Xtxxts(Tsxx, 0, 1)
                        LrText(Jsqte).SetFocus
                        Bclrsj = False
                        Exit Function
                    End If
                End If
            End If
        Next Jsqte
    
        '对需要进行事后判断的文本框录入内容进行有效性判断 (固定不变)
        For Jsqte = 0 To Max_Text_Index
            If Textint(Jsqte, 9) = 0 Or Textint(Jsqte, 9) = 2 Then
                If Not TextYxxpd(Jsqte) Then
                    Exit Function
                End If
            End If
        Next Jsqte
   
        If Lrzt = 1 Then  '增 加
        
            '[>>判断编码是否重复
            If .State = 1 Then .Close
            .Open "SELECT * FROM Kh_BaseMain ", Cw_DataEnvi.DataConnect, adOpenDynamic, adLockOptimistic
'            If Not .EOF Then
'                Tsxx = "类别编码重复!"
'                Call Xtxxts(Tsxx, 0, 1)
'                LrText(0).SetFocus
'
'                Bclrsj = False
'                Exit Function
'            End If
    

            '判断记录内容无误后,将记录内容写入数据表
            On Error GoTo Swcwcl
    
            Cw_DataEnvi.DataConnect.BeginTrans
            
            MaxNumber = MaxNum(0)
            MaxID = MaxNum(1)
            rec_temp.Open "select EmpID from Kh_GroupSub where GroupCode='" & str_GroupCode & "'", Cw_DataEnvi.DataConnect, adOpenDynamic, adLockOptimistic
            
            Do While Not rec_temp.EOF
               .AddNew
               .Fields("BaseMainID") = MaxNumber                    'ID号
               .Fields("TitleCode") = str_TitleCode                 '考核类别
               .Fields("EmpID") = rec_temp.Fields("EmpID")          '考核对象id号
               .Fields("GroupCode") = str_GroupCode                 '考核组编码
               .Fields("ValListCode") = Trim(LrText(2).Tag)         '测评者
               .Fields("ValListCodeID") = MaxID                     '测评者序号
               .Fields("BaseTotal") = 0                             '考核总分
        
               .Update
               MaxNumber = MaxNumber + 1
               rec_temp.MoveNext
            Loop
                        
    
            Cw_DataEnvi.DataConnect.CommitTrans
   
   
            '将记录加入网格
            Call Cxnrtcwg

            Tsxx = "保存完毕!"
            Call Xtxxts(Tsxx, 0, 4)
            Call Cshlrxx(1)
            LrText(2).SetFocus

            '将网格按编码排序
'            With CzxsGrid
'                .Col = Sydz("001", GridStr(), Szzls)
'                CzxsGrid.Sort = flexSortStringAscending
'            End With
            '<<]
       
        End If
     
        '保存记录成功,函数返回真值
        Bclrsj = True
        Exit Function
    End With
 
Swcwcl:
    Cw_DataEnvi.DataConnect.RollbackTrans
    Tsxx = "存盘过程中出现错误,程序自动恢复保存前状态!"
    Call Xtxxts(Tsxx, 0, 1)
    Exit Function

End Function

Private Function Cshlrxx(lrztxx As Integer) As Boolean              '初始化录入字段信息
    
    TextChangeLock = True       '关闭文本框Chang事件
    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
        '[>>
        '在此处可添加新增记录时初始化设置
        With RecTemp
            Sqlstr = "SELECT GroupCode,GroupName FROM Kh_Group Where GroupCode='" & str_GroupCode & "' "
            Set RecTemp = Cw_DataEnvi.DataConnect.Execute(Sqlstr)
            '记录如存在则读入其内容,否则提示记录已被其他人删除
            If Not RecTemp.EOF Then
                LrText(0).Text = Trim(.Fields("GroupCode") & "")                   '考核组编码
                LrText(1).Text = Trim(.Fields("GroupName") & "")                   '考核组名称
            End If
        End With
        LrText(0).Enabled = False
        LrText(1).Enabled = False

        '<<]
    End If
    Cshlrxx = True
    TextChangeLock = False

End Function

Private Sub Scdqjl()                 '删 除 当 前 记 录
    
    Dim yhAnswer As Integer
    Dim aDo_Rec As New Recordset
    Dim str_sql As String
    '判断用户是否有此功能执行权限,如有则写上机日志(进入)
    If Not Security_Log("Khgl_Result_edit", Xtczybm, 1) 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
 
    '[>>以下需自定义部分
    str_sql = " delete Kh_BaseSub  from Kh_BaseSub,Kh_BaseMain " & _
                " where Kh_BaseMain.GroupCode     = '" & Trim(CzxsGrid.TextMatrix(CzxsGrid.Row, Sydz("001", GridStr(), Szzls))) & "'" & _
                " and   Kh_BaseMain.ValListCode   = '" & Trim(CzxsGrid.TextMatrix(CzxsGrid.Row, Sydz("003", GridStr(), Szzls))) & "'" & _
                " and   Kh_BaseMain.ValListCodeid =  " & Val(Trim(CzxsGrid.TextMatrix(CzxsGrid.Row, Sydz("005", GridStr(), Szzls)))) & _
                " and   Kh_BaseMain.BaseMainID    =  Kh_BaseSub.BaseMainID "
    Cw_DataEnvi.DataConnect.Execute str_sql
    
    str_sql = " delete Kh_BaseMain  " & _
                " where GroupCode     = '" & Trim(CzxsGrid.TextMatrix(CzxsGrid.Row, Sydz("001", GridStr(), Szzls))) & "'" & _
                " and   ValListCode   = '" & Trim(CzxsGrid.TextMatrix(CzxsGrid.Row, Sydz("003", GridStr(), Szzls))) & "'" & _
                " and   ValListCodeid =  " & Val(Trim(CzxsGrid.TextMatrix(CzxsGrid.Row, Sydz("005", GridStr(), Szzls))))
    Cw_DataEnvi.DataConnect.Execute str_sql
  
    'Add_Tree
    '以上为自定义部分<<]
  
    Cw_DataEnvi.DataConnect.CommitTrans
  
    '将记录加入网格
    Call Cxnrtcwg

    Exit Sub
  
Cwcl:
    Cw_DataEnvi.DataConnect.RollbackTrans
    If Err.Number = -2147217873 Then                '(-2147217873 为SQL Server 2000通过建立外键产生的错误号)
        Tsxx = "该测评者已经被使用,不能删除!"