+

VB开发的ERP系统

            
            If GetDataType = -1 Then
                Call Xtxxts("请选择项目类型!", 0, 3)
                Exit Function
            End If
        
            '[>>判断项目名称是否重复
            If .State = 1 Then .Close
            .Open "SELECT * FROM Rs_Items WHERE ChName = '" + Trim(LrText(0).Text) + "'", 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
'            首先获得项目编号
            nnulStr = "SELECT 'RsU'+RIGHT('000'+CONVERT(VARCHAR(3),(CONVERT(int,RIGHT(MAX(Fieldname),3))+1)),3) FROM rs_items WHERE fieldname LIKE 'RsU%'"
            nulStr = "SELECT 'RsU'+RIGHT('000'+CONVERT(VARCHAR(3),ISNULL(max(Fieldname),0)+1),3) FROM rs_items WHERE fieldname LIKE 'RsU%' "
            sSql = "IF EXISTS(SELECT * FROM Rs_Items WHERE fieldname LIKE 'Rsu%') " + Chr$(10) _
                    & "SELECT fname= (" & nnulStr & ")" & Chr$(10) _
                    & " ELSE " + Chr$(10) _
                    & "SELECT fname= (" & nulStr & ")"
            Cw_DataEnvi.DataConnect.BeginTrans
            
            Set tmpRs = Cw_DataEnvi.DataConnect.Execute(sSql)
            If Not tmpRs.EOF Then FieldName = tmpRs!fName
'           向人事项目表存入项目记录
'           向相关帮助表名和字段名填入相应数据
            If LrText(3).Tag = "" Then
                sSql = "INSERT INTO Rs_Items (ItemId,ChName,FieldType,FieldLength,SID,FieldName,TableName,Width,FieldDotL,Correlation) " + Chr$(10) _
                & " SELECT ii=(SELECT ISNULL(MAX(ItemId),0)+1 FROM rs_items)," + Chr$(10) _
                & "'" & Trim(LrText(0).Text) & "','" & GetDataType & "','" & tLen & "','" & frmOwner & "','" & FieldName & "'" + Chr$(10) _
                & ",'Rs_ExtendInfo','" & tLen * 105 & "','" & dLen & "','" & LrText(3).Tag & "'"
            Else
                sSql = "INSERT INTO Rs_Items (ItemId,ChName,FieldType,FieldLength,SID,FieldName,TableName,Width,FieldDotL,Correlation,CorTable,IndexCode,IndexName) " + Chr$(10) _
                & " SELECT ii=(SELECT ISNULL(MAX(ItemId),0)+1 FROM rs_items)," + Chr$(10) _
                & "'" & Trim(LrText(0).Text) & "','" & GetDataType & "','" & tLen & "','" & frmOwner & "','" & FieldName & "'" + Chr$(10) _
                & ",'Rs_ExtendInfo','" & tLen * 105 & "','" & dLen & "','" & LrText(3).Tag & "','Rs_CorSub','ListId','ListName'"
            End If
            
            Cw_DataEnvi.DataConnect.Execute sSql
            
            sSql = "ALTER TABLE Rs_ExtendInfo ADD " & FieldName & " VARCHAR(50) NULL"
            Cw_DataEnvi.DataConnect.Execute sSql
            
            Cw_DataEnvi.DataConnect.CommitTrans

            '将记录加入网格
            Sqlstr = "SELECT * FROM Rs_Items WHERE FieldName = '" & FieldName & "'"
            Set Cxnrrec = Cw_DataEnvi.DataConnect.Execute(Sqlstr)
   
            With CzxsGrid
                .AddItem ""
                .RowHeight(.Rows - 1) = Sjhgd
                .Select .Rows - 1, Qslz
                Call Jltcwg(Cxnrrec, .Rows - 1)
            End With

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

            '将网格按编码排序
'            With CzxsGrid
'                .Col = Sydz("001", GridStr(), Szzls)
'                CzxsGrid.Sort = flexSortStringAscending
'            End With
            '<<]
    
        Else  '否则为修改记录
 
            If .State = 1 Then .Close
            .Open "SELECT * FROM Rs_Items WHERE ChName = '" + Trim(LrText(0).Text) + "' and ItemId <>'" & ItemId & "'", Cw_DataEnvi.DataConnect, adOpenDynamic, adLockOptimistic

            If Not .EOF Then
                Tsxx = "项目名称重复!"
                Call Xtxxts(Tsxx, 0, 1)
                LrText(1).SetFocus
        
                Bclrsj = False
                Exit Function
            End If
            
            
            On Error GoTo Swcwcl

            Cw_DataEnvi.DataConnect.BeginTrans

            If .State = 1 Then .Close
             If LrText(3).Tag = "" Then
                sSql = "Update Rs_Items SET ChName= '" & Trim(LrText(0).Text) + "" & "', FieldType= '" & GetDataType & "',FieldLength='" & tLen & "" & "', FieldDotL ='" & dLen & "', Correlation='" & LrText(3).Tag & "',Cortable='',IndexCode='',IndexName='' WHERE ItemId ='" & ItemId & "'"
             Else
                sSql = "Update Rs_Items SET ChName= '" & Trim(LrText(0).Text) + "" & "', FieldType= '" & GetDataType & "',FieldLength='" & tLen & "" & "', FieldDotL ='" & dLen & "', Correlation='" & LrText(3).Tag & "',Cortable='Rs_CorSub',IndexCode='ListId',IndexName='ListName' WHERE ItemId ='" & ItemId & "'"
             End If
             Cw_DataEnvi.DataConnect.Execute (sSql)
             
             Cw_DataEnvi.DataConnect.CommitTrans
   
'            '刷新当前网格
             Call Cxnrtcwg
   
        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              '初始化录入字段信息
Dim i As Integer
    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
       
        '[>>
        '在此处可添加新增记录时初始化设置
        For i = 0 To 2
            LrText(i).Enabled = True
        Next i
        Cbo_ItmType.Enabled = True
        Call FillCbo
        '<<]
    Else
    
        '修改记录时根据记录关键字(编码)从数据表中读入其他字段内容
        
            Sqlstr = "SELECT * FROM Rs_Items Where ItemId ='" & Trim(CzxsGrid.TextMatrix(CzxsGrid.Row, 0)) & "'"

            Set RecTemp = Cw_DataEnvi.DataConnect.Execute(Sqlstr)
       
            '记录如存在则读入其内容,否则提示记录已被其他人删除
            If Not RecTemp.EOF Then
                ItemId = RecTemp.Fields("itemId")                         '保存当前修改的记录标示
                LrText(0).Text = Trim(RecTemp.Fields("ChName") & "")             '项目名称
                LrText(1).Text = Trim(RecTemp.Fields("FieldLength") & "")        '项目长度
                LrText(2).Text = Trim(RecTemp.Fields("FieldDotL"))
                Call LocateTypeCbo(Trim(RecTemp.Fields("FieldType")))
                If GetHelpName(Trim(RecTemp.Fields("Correlation"))) <> "000" Then
                    LrText(3).Text = GetHelpName(Trim(RecTemp.Fields("Correlation")))
                    LrText(3).Tag = Trim(RecTemp.Fields("Correlation") & "")
                End If
'           前台是用不同背景颜色表示不同表的字段  非白色的是 Rs_BasicInfo 只能修改相关帮助
                If CzxsGrid.TextMatrix(CzxsGrid.Row, 0) < 25 Then
                    For i = 0 To 2
                        LrText(i).Enabled = False
                    Next i
                    Cbo_ItmType.Enabled = False
                Else
                    For i = 0 To 2
                        LrText(i).Enabled = True
                    Next i
                    Cbo_ItmType.Enabled = True
                End If
            End If
       
    End If
    
    Cshlrxx = True
    TextChangeLock = False
    
End Function

Private Sub Scdqjl()                 '删 除 当 前 记 录

    Dim Yhanswer As Integer
  
    '判断用户是否有此功能执行权限,如有则写上机日志(进入)
    If Not Security_Log(Str_RightEdit, Xtczybm, 1, True) Then
         Exit Sub
    End If
  
    '非数据行不能删除
    If CzxsGrid.Row < CzxsGrid.FixedRows Then
        Exit Sub
    End If
    
    '网格0列存储的是itmid
    If CzxsGrid.TextMatrix(CzxsGrid.Row, 0) < 25 Then
        Call Xtxxts("人事基本项目，不能删除", 0, 1)
        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

    '[>>以下需自定义部分
    If DelRsItem(CzxsGrid.TextMatrix(CzxsGrid.Row, 1), CzxsGrid.TextMatrix(CzxsGrid.Row, Sydz("001", GridStr(), Szzls))) = True Then
        Cw_DataEnvi.DataConnect.Execute "delete Rs_Items where ItemId = '" + Trim(CzxsGrid.TextMatrix(CzxsGrid.Row, 0)) + "'"
        Cw_DataEnvi.DataConnect.Execute "ALTER TABLE Rs_ExtendInfo DROP COLUMN " + CzxsGrid.TextMatrix(CzxsGrid.Row, 1)
        CzxsGrid.RemoveItem CzxsGrid.Row
    End If
    '以上为自定义部分<<]
  
    Cw_DataEnvi.DataConnect.CommitTrans
    Exit Sub
  
Cwcl:

    Cw_DataEnvi.DataConnect.RollbackTrans
    
    If Err.Number = -2147217873 Then                '(-2147217873 为SQL Server 2000通过建立外键产生的错误号)
        Tsxx = "该编码已经被使用,不能删除!"
        Call Xtxxts(Tsxx, 0, 1)
        Exit Sub
    Else
        Tsxx = "出现未知情况,该编码不能被删除!"
        Call Xtxxts(Tsxx, 0, 1)
        Exit Sub
    End If
    
End Sub



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

Private Function GetDataType() As Integer
'将下拉框的类型转变成系统统一的代号
    Select Case Cbo_ItmType.Text
    Case "字符型"
        GetDataType = 0
    Case "数字型"
        GetDataType = 5
    Case "日期型"
        GetDataType = 7
    Case Else
        GetDataType = -1
    End Select
    
End Function

Private Function LocateTypeCbo(Code As Integer)
'填充类型下拉框

    With Cbo_ItmType
        Select Case Code
        
        Case 0
            .Text = .List(0)
        Case 5
            .Text = .List(1)
        Case 7
            .Text = .List(2)
        Case Else
        End Select
    End With

End Function

Private Function ConvertCode2Type(Code As Integer) As String
'把数据表里存储的类型代号.翻译过来
    With Cbo_ItmType
        Select Case Code
        
        Case 0
            ConvertCode2Type = "字符型"
        Case 5
            ConvertCode2Type = "数字型"
        Case 7
            ConvertCode2Type = "日期型"
        Case Else
        End Select
    End With
End Function

Private Function GetHelpName(aStr As String) As String
Dim tmpRs As New ADODB.Recordset
Dim sSql As String

sSql = "SELECT * FROM Rs_CorMain Where SortId = '" & Trim(aStr) & "'"
Set tmpRs = Cw_DataEnvi.DataConnect.Execute(sSql)
If Not tmpRs.EOF Then
    GetHelpName = tmpRs.Fields("SortName")
Else
    GetHelpName = ""
End If

End Function

Private Function CanModify(fName As String) As Boolean
'针对人事项目指定相关项的和已经录入数据项目进行控制
Dim tmpRs As New ADODB.Recordset
Dim aStr As String

CanModify = False
On Error GoTo errD
If CzxsGrid.TextMatrix(CzxsGrid.Row, 0) < 25 Then
    aStr = "SELECT 1 FROM Rs_BasicInfo WHERE " & fName & " IS NOT null AND " & fName & "<>'' "
Else
    aStr = "SELECT 1 FROM Rs_ExtendInfo WHERE " & fName & " IS NOT null AND " & fName & "<>'' "
End If
Set tmpRs = Cw_DataEnvi.DataConnect.Execute(aStr)
If Not tmpRs.EOF Then
    Call Xtxxts("该项目已经录入数据，不能修改!", 0, 3)
    tmpRs.Close
    Exit Function
End If
tmpRs.Close

CanModify = True
Exit Function
errD:
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(Str_RightEdit, Xtczybm, 1, True) 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).SetFocus
                    LrText(0).Enabled = True
                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(Str_RightEdit, Xtczybm, 1, True) 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