+

VB开发的ERP系统

            Exit Sub
        End If
    
        '判断记录内容无误后,将记录内容写入数据表
        On Error GoTo Swcwcl
    
        Cw_DataEnvi.DataConnect.BeginTrans
    
        .AddNew
        .Fields("TitleCode") = Trim(LrText(0).Text)         '类别编码
        .Fields("TitleName") = Trim(LrText(1).Text)         '类别名称
        .Fields("CreateTime") = Trim(LrText(2).Text)        '创建日期
        .Fields("CheckCode") = Trim(LrText(3).Tag)          '测评规则
        .Fields("TitleDigit") = Trim(LrText(4).Text)        '保留小数
        If Opt_LockFlag(0).Value = True Then
            .Fields("LockFlag") = 0                         '下限封闭
        Else
            .Fields("LockFlag") = 1                         '上限封闭
        End If
        .Fields("Remark") = Trim(LrText(5).Text)            '备注
        .Fields("ParentCode") = ParentCode                  '上级编码
        .Fields("CodeLevel") = CodeLevel                    '编码级次
        .Fields("ComputeFlag") = 0                          '计算标志
        .Fields("CloseFlag") = 0                            '关闭标志
    
        .Update
        
        Cw_DataEnvi.DataConnect.Execute "update Kh_Title set EndFlag=0  where TitleCode='" & ParentCode & "'"
        
        '考核指标
        str_sql = " insert into Kh_Target(TitleCode,CheckCode,TargetWeigh) " & _
                  " (select '" & Trim(LrText(0).Text) & "' ,CheckCode,TargetWeigh " & _
                  " from Kh_Target where TitleCode='" & Trim(LrText(6).Text) & "')"
        Cw_DataEnvi.DataConnect.Execute str_sql
        '考核要素
        str_sql = " insert into Kh_ValMark(TitleCode,CheckCode,FactorCode,FactorWeigh) " & _
                  " (select '" & Trim(LrText(0).Text) & "' ,CheckCode,FactorCode,FactorWeigh " & _
                  " from Kh_ValMark where TitleCode='" & Trim(LrText(6).Text) & "')"
        Cw_DataEnvi.DataConnect.Execute str_sql
        '测评者
        str_sql = " insert into Kh_Appraise(TitleCode,ValListCode,AppraiseWeigh) " & _
                  " (select '" & Trim(LrText(0).Text) & "' ,ValListCode,AppraiseWeigh " & _
                  " from Kh_Appraise where TitleCode='" & Trim(LrText(6).Text) & "')"
        Cw_DataEnvi.DataConnect.Execute str_sql
        '考核对象
        str_sql = " insert into kh_object(TitleCode,EmpID) " & _
                  " (select '" & Trim(LrText(0).Text) & "' ,EmpID " & _
                  " from kh_object where TitleCode='" & Trim(LrText(6).Text) & "')"
        Cw_DataEnvi.DataConnect.Execute str_sql
        
        
        Cw_DataEnvi.DataConnect.CommitTrans
        
    End With
       
    Me.Hide
    Exit Sub

Swcwcl:
    Cw_DataEnvi.DataConnect.RollbackTrans
    Tsxx = "存盘过程中出现错误,程序自动恢复确定前状态!"
    Call Xtxxts(Tsxx, 0, 1)
    Exit Sub
    
End Sub

Private Sub QxCommand_Click()                                    '取消(Fixed)
    Me.Hide
End Sub

Private Function Lrtjyxxpd() As Boolean                          '用户录入条件有效性判断
    
    Dim Jsqte As Integer
    Lrtjyxxpd = False
    
    '对需要进行事后判断的文本框录入内容进行有效性判断 (Fixed)
    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
        If Len(Trim(LrText(Jsqte).Text)) = 0 Then
            Select Case Jsqte
                Case 0
                    Tsxx = "目标考核类别编码不能为空!"
                    Call Xtxxts(Tsxx, 0, 1)
                    LrText(Jsqte).SetFocus
                    Exit Function
                Case 1
                    Tsxx = "目标考核类别名称不能为空!"
                    Call Xtxxts(Tsxx, 0, 1)
                    LrText(Jsqte).SetFocus
                    Exit Function
                Case 2
                    Tsxx = "创建时间不能为空!"
                    Call Xtxxts(Tsxx, 0, 1)
                    LrText(Jsqte).SetFocus
                    Exit Function
                Case 3
                    Tsxx = "测评规则不能为空!"
                    Call Xtxxts(Tsxx, 0, 1)
                    LrText(Jsqte).SetFocus
                    Exit Function
                Case 4
                    Tsxx = "保留小数不能为空!"
                    Call Xtxxts(Tsxx, 0, 1)
                    LrText(Jsqte).SetFocus
                    Exit Function
            End Select
        End If
        
    Next Jsqte
    
    If Val(LrText(4).Text) > 6 Then
        Tsxx = "保留小数最大值为6!"
        Call Xtxxts(Tsxx, 0, 1)
        LrText(Index).SetFocus
        Exit Function
    End If
    
    '[>>以下为依据实际情况自定义部分
    Dim i As Integer, LevelLeng As Integer, tf As Boolean
    For i = 1 To Len(CodScheme)
        LevelLeng = LevelLeng + Val(Mid(CodScheme, i, 1))
        If Len(Trim(LrText(0))) = LevelLeng Then
            tf = True: Exit For
        Else
            tf = False
        End If
    Next i
    '--------------
    If tf = False Then
        Tsxx = "非法编码方式！  "
        Call Xtxxts(Tsxx, 0, 1)
        LrText(Index).SetFocus
        Exit Function
    End If
    '---------------
    If Len(Trim(LrText(0))) <> Val(Mid(CodScheme, 1, 1)) Then
        With Khgl_Title.CzxsGrid
            ParentCode = Mid(Trim(LrText(0)), 1, LevelLeng - Val(Mid(CodScheme, i, 1)))
            code_row = .FindRow(ParentCode, , int_col)
            If code_row = -1 Then
                ParentCode = ""
                Tsxx = "没有上级编码!  "
                Call Xtxxts(Tsxx, 0, 1)
                LrText(Index).SetFocus
                Exit Function
            End If
        End With
    End If
    CodeLevel = i
    
    '<<]以上为依据实际情况自定义部分
    
    Lrtjyxxpd = True
End Function





'*************以下为文本框录入处理程序(固定不变部分)*************'

Private Sub Wbklrwbcl(Index As Integer)    '文本框录入事后处理程序
    
    '以下为依据实际情况自定义部分[
    
    '在此填写文本框录入事后处理程序
    
    ']以上为依据实际情况自定义部分
    
End Sub

Private Sub LrText_Change(Index As Integer)
    
    '屏蔽程序改变控制
    If TextChangeLock Then
        Exit Sub
    End If
    
    TextValiJudgeLock(Index) = False    '打开有效性判断锁
    
    '限制字段录入长度
    
    TextChangeLock = True  '加锁(防止执行Lrtext_Change)
    
    Call TextChangeLimit(LrText(Index), Textint(Index, 1))  '去掉无效字符
    
    Select Case Textint(Index, 1)
    Case 8, 11      '金额型
        Call Sjgskz(LrText(Index), Xtjezws - Xtjexsws - 1, Xtjexsws)
    Case 9, 12      '数量型
        Call Sjgskz(LrText(Index), Xtslzws - Xtslxsws - 1, Xtslxsws)
    Case 10          '单价型
        Call Sjgskz(LrText(Index), Xtdjzws - Xtdjxsws - 1, Xtdjxsws)
    Case Else        '其他小数类型控制
        If Textint(Index, 6) <> 0 Or Textint(Index, 7) <> 0 Then
            Call Sjgskz(LrText(Index), Textint(Index, 6), Textint(Index, 7))
        End If
    End Select
    
    TextChangeLock = False '解锁
    
End Sub

Private Sub LrText_GotFocus(Index As Integer)                                                 '文本框得到焦点,显示相应信息
    
    Call TextShow(Index)
    CurTextIndex = Index
    LrText(Index).SelStart = Len(LrText(Index))
    
End Sub

Private Sub LrText_KeyDown(Index As Integer, KeyCode As Integer, Shift As Integer)            '字段按F2键提供帮助
    
    Select Case KeyCode
    Case vbKeyF2
        Call Text_Help(Index)
    End Select
    
End Sub

Private Sub LrText_KeyPress(Index As Integer, KeyAscii As Integer)                            '文本框录入事中控制
    Call InputFieldLimit(LrText(Index), Textint(Index, 1), KeyAscii)
End Sub

Private Sub LrText_LostFocus(Index As Integer)                                                '文本框失去焦点
    
    '显示相应信息但不能进行有效性判断
    
End Sub

Private Sub Ydcommand1_MouseDown(Index As Integer, Button As Integer, Shift As Integer, x As Single, y As Single)     '按钮提供帮助
    Call Text_Help(Index)
End Sub

Private Sub Text_Help(Index As Integer)                                                       '录入字段帮助
    If Not Textboolean(Index, 1) Then
        Exit Sub
    End If
    
    '调用帮助
    Call Drbmhelp(Textint(Index, 2), Textstr(Index, 4), Trim(LrText(Index).Text))
    
    '根据设置选择显示编码和名称,并进行存储
    If Len(Xtfhcs) <> 0 Then
        If Textint(Index, 3) = 1 Then
            LrText(Index).Text = Xtfhcsfz
            LrText(Index).Tag = Xtfhcs
        Else
            LrText(Index).Text = Xtfhcs
            LrText(Index).Tag = Xtfhcsfz
        End If
    End If
    
    LrText(Index).SetFocus
    
End Sub

Private Sub TextShow(Index As Integer)        '文本框得到焦点,显示相应信息
    
    '填写文本框得到焦点,进行相应信息处理程序
    
End Sub

Private Sub Wbkcsh()                          '录入文本框初始化
    
    Dim Jsqte As Integer
    
    '最大录入文本框索引值
    Max_Text_Index = Textvar(1)
    
    ReDim TextValiJudgeLock(Max_Text_Index)
    For Jsqte = 0 To Max_Text_Index
        
        If Len(Trim(Textstr(Jsqte, 1))) <> 0 Then
            If Textboolean(Jsqte, 1) Then
                If Jsqte <> 0 And Not Textboolean(Jsqte, 3) Then
                    Load Ydcommand1(Jsqte)
                End If
                Ydcommand1(Jsqte).Visible = True
                Ydcommand1(Jsqte).Move LrText(Jsqte).Left + LrText(Jsqte).Width, LrText(Jsqte).Top
            End If
            TextChangeLock = True
            LrText(Jsqte).Text = ""
            LrText(Jsqte).Tag = ""
            If Textint(Jsqte, 5) <> 0 Then
                LrText(Jsqte).MaxLength = Textint(Jsqte, 5)
            End If
            TextChangeLock = False
        End If
        
        TextValiJudgeLock(Jsqte) = True
    Next Jsqte
    
End Sub

Private Function TextYxxpd(Index As Integer) As Boolean           '文本框有效性判断
    Dim Sqlstr As String
    Dim Findrec As ADODB.Recordset
    
    '文本框内容未曾改变不进行有效性判断
    If TextValiJudgeLock(Index) Then
        TextYxxpd = True
        Exit Function
    End If
    
    '文本框内容为空认为有效,并清空其Tag值
    If Trim(LrText(Index)) = "" Then
        LrText(Index).Tag = ""
        Call Wbklrwbcl(Index)
        TextValiJudgeLock(Index) = True
        TextYxxpd = True
        Exit Function
    End If
    
    '可在此加入不做有效性判断的理由
    
    Select Case Textint(Index, 4)
    Case 1      '编码型
        Sqlstr = Trim(Textstr(Index, 5))
        Sqlstr = Replace(Sqlstr, "@", "'" + Trim(LrText(Index).Text) + "'")
        Set Findrec = Cw_DataEnvi.DataConnect.Execute(Sqlstr)
        If Findrec.EOF Then
            Call Xtxxts(Trim(Textstr(Index, 6)), 0, 1)
            LrText(Index).SetFocus
            Exit Function
        Else
            Select Case Textint(Index, 3)
            Case 0
                If Len(Trim(Textstr(Index, 2))) <> 0 Then
                    LrText(Index).Text = Trim(Findrec.Fields(Trim(Textstr(Index, 2))))
                End If
                If Len(Trim(Textstr(Index, 3) & "")) <> 0 Then
                    LrText(Index).Tag = Trim(Findrec.Fields(Trim(Textstr(Index, 3))))
                End If
            Case 1
                If Len(Trim(Textstr(Index, 3) & "")) <> 0 Then
                    LrText(Index).Text = Trim(Findrec.Fields(Trim(Textstr(Index, 3))))
                End If
                If Len(Trim(Textstr(Index, 2))) <> 0 Then
                    LrText(Index).Tag = Trim(Findrec.Fields(Trim(Textstr(Index, 2))))
                End If
            End Select
        End If
    Case 2      '日期型
        If IsDate(LrText(Index).Text) Then
            LrText(Index).Text = Format(LrText(Index).Text, "yyyy-mm-dd")
            If Val(Mid(LrText(Index), 1, 4)) < 1900 Then
                LrText(Index).Text = "1900" + Mid(LrText(Index), 5, 6)
            End If
        Else
            Tsxx = "非法公历日期!(格式:" + Format(Date, "yyyy-mm-dd") + ")"
            Call Xtxxts(Tsxx, 0, 1)
            LrText(Index).SetFocus
            Exit Function
        End If
    Case 3      '其他类型
    End Select
    
    '如果有效则加锁,用户不改变内容则不再进行有效性判断
    TextValiJudgeLock(Index) = True
    
    '调用文本框事后处理程序
    Call Wbklrwbcl(Index)
    
    '有效性判断通过则返回True
    TextYxxpd = True
    
End Function