+

VB开发的ERP系统

            With CzxsGrid
                .AddItem ""
                .RowHeight(.Rows - 1) = Sjhgd
                .Select .Rows - 1, Qslz
                Call Jltcwg(Cxnrrec, .Rows - 1)
            End With
            Cxnrrec.Close
   

            Call Cshlrxx(1)
            LrText(0).SetFocus
   
            '<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
   
        Else                                                            '修改
            sSql = "UPDATE Xt_Grid SET ColTitle1 ='" _
                    & Trim(LrText(0).Text) & "',Text_Data_Type ='" & GetDataType & "'" _
                    & ",Text_Length = '" & tLen & "', Text_Deci_Length = '" & dLen & "'" _
                    & ",ColAlignment = '" & GetDataAlign & "' Where FieldsName = '" & CzxsGrid.TextMatrix(CzxsGrid.Row, 0) & "'"
            Cw_DataEnvi.DataConnect.Execute sSql

            Call Cxnrtcwg
 
        End If
        Bclrsj = True
        Call Xtxxts("保存成功!", 0, 4)
        Exit Function
    End With
 
Swcwcl:
    Tsxx = "存盘过程中出现错误,程序自动恢复保存前状态!"
    If Err.Number = -2147217900 Then
        Tsxx = "明细编码不能重复"
    End If
    Call Xtxxts(Tsxx, 0, 1)
    Exit Function

End Function

Private Sub Cshlrxx(lrztxx As Integer)              '初始化录入字段信息
Dim tmpRs As New ADODB.Recordset
Dim sSql As String

    If lrztxx = 1 Then
        For jsqte = 0 To Max_Text_Index
            If Len(Trim(Textstr(jsqte, 1))) <> 0 Then
                TextChangeLock = True
                LrText(jsqte).Text = ""
                LrText(jsqte).Tag = ""
                TextChangeLock = False
            End If
            TextValiJudgeLock(jsqte) = True
        Next jsqte
    Else
        
        
           
            sSql = "SELECT * FROM Xt_Grid Where FieldsName ='" & Trim(CzxsGrid.TextMatrix(CzxsGrid.Row, 0)) & "'"

            Set tmpRs = Cw_DataEnvi.DataConnect.Execute(sSql)
       
  
            If Not tmpRs.EOF Then
                LrText(0).Text = Trim(tmpRs.Fields("ColTitle1") & "")             '项目名称
                LrText(1).Text = Trim(tmpRs.Fields("Text_Length") & "")           '项目长度
                LrText(2).Text = Trim(tmpRs.Fields("Text_deci_Length"))           '小数位数
                Call LocateTypeCbo(Trim(tmpRs.Fields("Text_Data_Type")))          '数据类型
                Call LocateAlignCbo(Trim(tmpRs.Fields("ColAlignment")))           '对齐方式
            End If
            Set tmpRs = Nothing
    End If
End Sub
Private Sub Scdqjl()                 '删 除 当 前 记 录
    Dim tmpStr As String
    Dim tmpRs As New ADODB.Recordset
    Dim Yhanswer As Integer
    Dim FieldName As String


    '判断用户是否有此功能执行权限,如有则写上机日志(进入)
    If Not Security_Log(Str_RightEdit, Xtczybm, 1, True) Then
         Exit Sub
    End If

    If CzxsGrid.Row < CzxsGrid.FixedRows Then
        Exit Sub
    End If
    
  
    On Error GoTo Cwcl
    FieldName = Trim(CzxsGrid.TextMatrix(CzxsGrid.Row, 0))
    sSql = "SELECT count(" & FieldName & ") as NUM FROM Rs_ArMain WHERE " & FieldName & " IS NOT NULL AND (" & FieldName & " <> '') "
    Set tmpRs = Cw_DataEnvi.DataConnect.Execute(sSql)
    If tmpRs.Fields("num") > 0 Then
        Call Xtxxts("该类档案已经存入数据，欲删除该档案项目，请先到相关档案维护删除对应数据!", 0, 3)
        Exit Sub
    End If
    
    Tsxx = "请确认是否删除当前记录?"
    Yhanswer = Xtxxts(Tsxx, 2, 2)
    If Yhanswer = 2 Then
        Exit Sub
    End If
    
    Cw_DataEnvi.DataConnect.BeginTrans

    '[>>以下需自定义部分
    Cw_DataEnvi.DataConnect.Execute "DELETE Xt_Grid WHERE FieldsName = '" + FieldName + "'"
    Cw_DataEnvi.DataConnect.Execute "ALTER TABLE Rs_ArMain DROP COLUMN " + FieldName
    
    '以上为自定义部分<<]
    tmpRs.Close: Set tmpRs = Nothing
    Cw_DataEnvi.DataConnect.CommitTrans
    
    CzxsGrid.RemoveItem CzxsGrid.Row
    Exit Sub
Cwcl:
    If Err.Number = -2147217900 Then
        Tsxx = "该项目已经被使用,不能删除!"
        Call Xtxxts(Tsxx, 0, 1)
        Exit Sub
    Else
        Tsxx = "出现未知情况,该项目不能被删除!"
        Call Xtxxts(Tsxx, 0, 1)
        Exit Sub
        End If

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 打印
                Call bbyl(False)
            Case "I"                   'Ctrl+I 增加
                '判断用户是否有此功能执行权限,如有则写上机日志(进入)
                If Not Security_Log(Str_RightEdit, Xtczybm, 1, True) Then
                    Exit Sub
                End If
                Call Toolbjzt
                Lrzt = 1
                Call Cshlrxx(Lrzt)
                LrText(0).SetFocus
                LrText(0).Locked = False
            Case "D"                   'Ctrl+D 删除
                Call Scdqjl
        End Select
    End If

End Sub



Private Sub SzToolbar_ButtonClick(ByVal Button As MSComctlLib.Button)
    If Button.Key <> "fh" And Button.Key <> "bz" Then
        If Trim(F_Sort.Tag) = "" Then Call Xtxxts("没有选定类别!", 0, 3): Exit Sub
    End If

    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).SetFocus
            LrText(0).Locked = False
        Case "xg"                                            '修 改
            If CzxsGrid.Row < CzxsGrid.FixedRows Then Call Xtxxts("没有选定类别!", 0, 3): Exit Sub
            Call Xgdqjl
        Case "sc"                                            '删 除
            Call Scdqjl
        Case "fq"                                            '取 消
            Call Toolfbjzt
        Case "sx"                                            '刷 新
            Call Cxnrtcwg
        Case "FaceSet"                                       '界面设置
            '判断用户是否有此功能执行权限,如有则写上机日志(进入)
            If Not Security_Log(Str_RightEdit, Xtczybm, 1, True, False) Then
                Cmd_Yes.Enabled = False
            End If
            Call FaceSet
        Case "bz"                                            '帮 助
            Call F1bz
        Case "fh"                                            '退 出
            sSql = "UPDATE Xt_Grid SET explorerbar=0 WHERE System_Code='Rs_User' AND ColIndex = '000' "
            Cw_DataEnvi.DataConnect.Execute (sSql)
            Unload Me
    End Select

End Sub

Private Sub CzxsGrid_DblClick()                            '修改当前编码记录
    Call Xgdqjl
End Sub

Private Sub Xgdqjl()                                       '修改当前编码记录
    
    '判断用户是否有此功能执行权限,如有则写上机日志(进入)
    If Not Security_Log(Str_RightEdit, Xtczybm, 1, True, False) Then
        BcCommand.Enabled = False
    End If
    
    If CzxsGrid.Row < CzxsGrid.FixedRows Then
        Exit Sub
    End If
    If Not CanModify Then Exit Sub
    Call Toolbjzt
    Lrzt = 2
    Call Cshlrxx(Lrzt)
    LrText(1).SetFocus
'    LrText(0).Locked = True

End Sub

Private Sub Toolbjzt()                                     'Toolbar状态(编辑状态)
    
    '判断用户是否有此功能执行权限,如有则写上机日志(进入)
    If Not Security_Log(Str_RightEdit, Xtczybm, 1, True, False) Then
        BcCommand.Enabled = False
    End If
    
    StTab.TabEnabled(1) = True
    A_YNStop.Value = 0
    Tree_List.Enabled = False
    StTab.Tab = 1
    Frame1.Enabled = True
    StTab.TabEnabled(0) = False
    CzxsGrid.Enabled = False
    Fra_face.Enabled = False
    With SzToolbar
        .Buttons("ymsz").Enabled = False
        .Buttons("dy").Enabled = False
        .Buttons("yl").Enabled = False
        .Buttons("zj").Enabled = False
        .Buttons("xg").Enabled = False
        .Buttons("sc").Enabled = False
        .Buttons("sx").Enabled = False
        .Buttons("FaceSet").Enabled = False
    End With

End Sub

Private Sub Toolfbjzt()                                    'Toolbar状态(非编辑状态)
    
    StTab.TabEnabled(0) = True
    StTab.Tab = 0
    Tree_List.Enabled = True
    CzxsGrid.Enabled = True
    Frame1.Enabled = False
    StTab.TabEnabled(1) = False
    StTab.TabEnabled(2) = False
    Lrzt = 0
    With SzToolbar
        .Buttons("ymsz").Enabled = True
        .Buttons("dy").Enabled = True
        .Buttons("yl").Enabled = True
        .Buttons("zj").Enabled = True
        .Buttons("xg").Enabled = True
        .Buttons("sc").Enabled = True
        .Buttons("sx").Enabled = True
        .Buttons("FaceSet").Enabled = True
    End With

End Sub

Private Sub BcCommand_Click()                                           '保 存
    
    If Not Bclrsj Then
        Exit Sub
    End If
    If Lrzt = 2 Then
        Call Toolfbjzt
    End If

End Sub

Private Sub QxCommand_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
  
    For jsqte = 0 To Max_Text_Index
        TextValiJudgeLock(jsqte) = True
    Next jsqte
    Call Toolfbjzt

End Sub

Private Sub CzxsGrid_BeforeMoveColumn(ByVal Col As Long, Position As Long)           '网格列发生移动时自动交换网格索引信息
    FnBln_RefreshArray Col, Position, GridStr(), GridInf()
End Sub

Private Sub GsToolbar_ButtonClick(ByVal Button As MSComctlLib.Button)   '表格格式设置(通用)
    
    Select Case Button.Key
        Case "bcgs"                                       '保存表格格式
            Call Bcwggs(CzxsGrid, GridCode, GridStr())
        Case "hfmrgs"                                     '恢复默认格式
            Call Hfmrgs(CzxsGrid, GridCode, GridStr())
        Case "szxsxm"                                     '设置显示项目
            Call Szxsxm(CzxsGrid, GridCode)
    End Select

End Sub

Private Sub bbyl(bbylte As Boolean)                    '报表打印预览
    
    Dim Bbzbt$, Bbxbt() As String, bbxbtzzxs() As Integer, Bbxbtgs As Integer
    Dim Bbbwh() As String, Bbbwhzzxs() As Integer, Bbbwhgs As Integer
    Bbxbtgs = 1                                          '报 表 小 标 题 行 数
    Bbbwhgs = 0                                          '报 表 表 尾 行 数
    ReDim Bbxbt(1 To Bbxbtgs)
    ReDim bbxbtzzxs(1 To Bbxbtgs)
    If Bbbwhgs <> 0 Then
        ReDim Bbbwh(1 To Bbbwhgs)
        ReDim Bbbwhzzxs(1 To Bbbwhgs)
    End If
    Bbzbt = ReportTitle
    Bbxbt(1) = " "
    bbxbtzzxs(1) = 0                                     '报表行组织形式(0-居左 1-居中 2-居右)
    Call Scyxsjb(CzxsGrid)                               '生成报表数据
    Call Scdybb(Dyymctbl, Bbzbt, Bbxbt(), bbxbtzzxs(), Bbxbtgs, Bbbwh(), Bbbwhzzxs(), Bbbwhgs, bbylte)
    If Not bbylte Then
        Unload DY_Tybbyldy
    End If
    
End Sub

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

Private Sub Wbklrwbcl(Index As Integer)    '文本框录入事后处理程序

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

Private Sub LrText_Change(Index As Integer)