+

VB开发的ERP系统

    '屏蔽程序改变控制
    If TextChangeLock Then
        Exit Sub
    End If
   
    TextValiJudgeLock(Index) = False    '打开有效性判断锁
    
    '限制字段录入长度
          
    TextChangeLock = True  '加锁(防止执行Lrtext_Change)
    Select Case Textint(Index, 1)
        Case 8           '金额型
            Call Sjgskz(LrText(Index), Xtjezws - Xtjexsws - 1, Xtjexsws)
        Case 9           '数量型
            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

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)                                                '文本框失去焦点进行有效性判断及相应处理
    
    If Not Textboolean(Index, 2) Then      '事中判断
        Call TextYxxpd(Index)
    End If

End Sub

Private Sub Tree_List_Click()
    
    If Mid(Trim(Tree_List.SelectedItem.Key), 2, Len(Trim(Tree_List.SelectedItem.Key)) - 1) <> "" Then
        F_Sort.Caption = Tree_List.SelectedItem.Text
        F_Sort1.Caption = F_Sort.Caption
        ReportTitle = "" & F_Sort.Caption
        F_Sort.Tag = Trim(Mid(Trim(Tree_List.SelectedItem.Key), 2, Len(Trim(Tree_List.SelectedItem.Key)) - 1))
        Cxnrtcwg
    End If

End Sub

Private Sub Txt_TitleH_KeyPress(KeyAscii As Integer)
    If (KeyAscii < Asc("0") Or KeyAscii > Asc("9")) And KeyAscii <> vbKeyBack Then KeyAscii = 0
    If Len(Txt_TitleH.Text) >= 3 And KeyAscii <> vbKeyBack Then KeyAscii = 0
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 Ydcommand1(Index).Visible Then
        Exit Sub
    End If
    TextValiJudgeLock(Index) = True
   
    '先进行有效性判断
    If Not TextYxxpd(CurTextIndex) 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
    TextValiJudgeLock(Index) = False
    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 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
    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")
            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
    TextYxxpd = True

End Function

Sub Add_Tree()
    
    Dim R_List As New Recordset
    Dim R_Sort As New Recordset
    Tree_List.Nodes.Add , 4, "T", "项目类别", "xttb"
    R_Sort.Open "select * from Rs_ArSort", Cw_DataEnvi.DataConnect, adOpenStatic, adLockOptimistic
    
    With R_Sort
        Do While Not .EOF
            'If .Fields("mjbz") Then
            Set nodX = Tree_List.Nodes.Add("T", 4, "T" & Trim(.Fields("ArSort")), "" & Trim(.Fields("ArName")), "gnqx")
            nodX.EnsureVisible
            'End If
            .MoveNext
        Loop
    End With
 
End Sub

'*************************  自定义函数部分*******************

Private Function TxtDataPass(tt As TextBox) As Boolean
    
    TxtDataPass = False
    On Error GoTo Cwcl
    With tt
        If Trim(.Text) = "" Then Call Xtxxts("行高度不能为空!", 0, 1): Exit Function
        If Trim(.Text) = "-" Then Call Xtxxts("非法字符!", 0, 1): Exit Function
    
        If Val(Trim(.Text)) > 500 Then Call Xtxxts("行高度不能大于500!", 0, 1): Exit Function
        If Val(Trim(.Text)) <= 0 Then Call Xtxxts("行高度不能为0!", 0, 1): Exit Function
    End With
    TxtDataPass = True
    Exit Function
Cwcl:
    Call Xtxxts("行高度设置不合理,请查看相关帮助!", 0, 1)
    
End Function

Private Function CanModify() As Boolean
'判断选中的档案项目是否可以修改
Dim sSql As String
Dim FieldName As String
Dim tmpRs As New ADODB.Recordset
    
    CanModify = False
    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 Function
    End If
    CanModify = True
    
End Function


Private Sub FaceSet()
'界面设置，用于调整用户档案在录入时的界面
Dim tmpRs As New ADODB.Recordset
Dim sSql As String

    Tree_List.Enabled = False
    StTab.Tab = 2
    Frame1.Enabled = False
    Fra_face.Enabled = True
'   设置标签页的状态
    StTab.TabEnabled(0) = False
    StTab.TabEnabled(1) = False
    StTab.TabEnabled(2) = True
    CzxsGrid.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
    With GsToolbar
        .Buttons("bcgs").Enabled = False
        .Buttons("hfmrgs").Enabled = False
        .Buttons("szxsxm").Enabled = False
    End With
    
    '首先更新数据库，使得网格列可以移动
    sSql = "UPDATE Xt_Grid SET explorerbar=2 WHERE System_Code='Rs_User' AND ColIndex = '000' "
    Cw_DataEnvi.DataConnect.Execute (sSql)
'    刷新网格
    GridCode = Trim(F_Sort.Tag)
    Call BzWgcsh(vsFlexGrid1, GridCode, GridInf(), GridBoolean(), GridInt(), GridStr())
    
'    针对当前网格进行特殊设置
    Qslz = GridInf(1)
    Sjhgd = GridInf(2)
    Szzls = CzxsGrid.Cols - 1
    vsFlexGrid1.ColHidden(Sydz("001", GridStr(), Szzls)) = True
    vsFlexGrid1.ColHidden(Sydz("002", GridStr(), Szzls)) = True
    
'    改写网格的标题列可以移动
    sSql = "SELECT * FROM Xt_Grid WHERE Grid_code= '" & F_Sort.Tag & "' AND ColIndex = '000'"
    Set tmpRs = Cw_DataEnvi.DataConnect.Execute(sSql)
    If Not tmpRs.EOF Then
        Txt_TitleH.Text = tmpRs.Fields("FixRowHeight")
'        Txt_DataLineH.Text = tmpRs.Fields("DataRowHeight")
    End If
    vsFlexGrid1.AddItem ""
    Txt_TitleH.SetFocus
End Sub

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

Private Sub Bcwggs_U(Bcgsgrid As vsFlexGrid, Wggsdm As String, GridStr() As String)            '保存网格格式(包括网格列宽,网格列顺序)
'自定义网格格式保存函数，在系统统一的网格格式保存函数基础上增加了数据行高度的设置保存
'过程参数:Bcgsgrid 保存格式网格对象,Wggsdm 网格格式代码(网格参数),GridStr() 从中取网格列索引信息
  
    Dim RecTemp As New ADODB.Recordset               '临时使用动态集
    Dim Qslzte As Integer                            '起始列值
    Dim Tsxx As String                               '系统信息提示
    Dim sSql As String
  
    Cw_DataEnvi.DataConnect.BeginTrans
    On Error GoTo Swcwcl
    If RecTemp.State = 1 Then RecTemp.Close
    RecTemp.Open "select * from xt_grid where Grid_Code='" + Trim(Wggsdm) + "' order by ColId", Cw_DataEnvi.DataConnect, adOpenDynamic, adLockOptimistic
    With RecTemp
        If Not .EOF Then
            Qslzte = .Fields("BeginCol")
            .MoveNext
        End If
    
        Do While Not .EOF
            For jsqte = Qslzte To Bcgsgrid.Cols - 1
                If Trim(.Fields("ColIndex")) = Trim(GridStr(jsqte, 1)) Then
                    Exit For
                End If
            Next jsqte
            If jsqte <= Bcgsgrid.Cols - 1 Then
                .Fields("ColId") = jsqte - Qslzte + 1
                .Fields("ColWidth") = Bcgsgri