VB开发的ERP系统

 
    '对需要进行事后判断的文本框录入内容进行有效性判断 (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
    Next Jsqte
   
    '[>>以下为依据实际情况自定义部分
 
    '查询日期范围应由小到大
    If LrText(0).Text > LrText(1).Text And Trim(LrText(1).Text) <> "" Then
        Tsxx = "查询取样日期范围应由小到大!"
        Call Xtxxts(Tsxx, 0, 4)
        LrText(0).SetFocus
        Exit Function
    End If
  
    '<<]以上为依据实际情况自定义部分
 
    Lrtjyxxpd = True

End Function

'[以下为自定义部分
Private Sub Cmd_Clear_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)    '将用户输入条件全部清除(可选)

    '清除文本框(Fixed)
    For Jsqte = 0 To Max_Text_Index
        LrText(Jsqte).Tag = ""
        LrText(Jsqte).Text = ""
    Next Jsqte
  
    '[>>
    Cmb_LineName.Text = Cmb_LineName.List(0)    '生产线名称
    Cmb_LineCode.Text = Cmb_LineCode.List(0)    '生产线代码
    Cmb_SiteName.Clear
    Cmb_SiteCode.Clear
    Cmb_MName.Clear
    Cmb_MNumber.Clear
    Opt_Check(0).Value = True
    '此处可以写入其他清除条件程序
    '<<]
  
End Sub

Private Sub Cmb_LineName_Click()
    If Cmb_LineCode.ListIndex <> Cmb_LineName.ListIndex Then
        
        Cmb_LineCode.Text = Cmb_LineCode.List(Cmb_LineName.ListIndex)
        Cmb_MName_DropDown
        Cmb_SiteName_DropDown
    End If
End Sub

Private Sub Cmb_MName_Click()
    If Cmb_MNumber.ListIndex <> Cmb_MName.ListIndex Then
        
        Cmb_MNumber.Text = Cmb_MNumber.List(Cmb_MName.ListIndex)
        Cmb_SiteName_DropDown
    End If
End Sub

Private Sub Cmb_MName_DropDown()
    Cmb_MName.Clear
    Cmb_MNumber.Clear
    Dim Rs_MName As ADODB.Recordset
    Dim Str_MName As String
    Str_MName = "SELECT distinct MNumber,MName FROM Qc_v_MidStandMain WHERE LineCode='" & Trim(Cmb_LineCode.Text & "") & "'"
    Set Rs_MName = Cw_DataEnvi.DataConnect.Execute(Str_MName)
    If Rs_MName.RecordCount < 1 Then
        Rs_MName.Close
        Exit Sub
    End If
    
    Do While Not Rs_MName.EOF
        Cmb_MName.AddItem Trim(Rs_MName!MName & "")     '物料编码
        Cmb_MNumber.AddItem Trim(Rs_MName!MNumber & "") '物料名称
        Rs_MName.MoveNext
    Loop
    
    Rs_MName.Close
    Set Rs_MName = Nothing
End Sub

Private Sub Cmb_SiteName_Click()
    If Cmb_SiteName.ListIndex <> -1 Then
       
        Cmb_SiteCode.Text = Cmb_SiteCode.List(Cmb_SiteName.ListIndex)
        
    End If
End Sub

Private Sub Cmb_SiteName_DropDown()
    Cmb_SiteName.Clear
    Cmb_SiteCode.Clear
    Dim Rec_Site As ADODB.Recordset
    Set Rec_Site = Cw_DataEnvi.DataConnect.Execute("SELECT distinct SiteCode,SiteName FROM Qc_v_MidStandMain WHERE LineCode='" & Trim(Cmb_LineCode.Text & "") & "' and MNumber='" & Trim(Cmb_MNumber.Text & "") & "'")
    If Rec_Site.RecordCount < 1 Then
        Rec_Site.Close
        Exit Sub
    End If
    
    Do While Not Rec_Site.EOF
        Cmb_SiteName.AddItem Trim(Rec_Site!SiteName & "")  '取样点名称
        Cmb_SiteCode.AddItem Trim(Rec_Site!SiteCode & "")  '取样点代码
        Rec_Site.MoveNext
    Loop
    
    Rec_Site.Close
    Set Rec_Site = Nothing
End Sub

Private Sub InitCmb()       '初始化下拉列表框
    Dim Rec_Line As New ADODB.Recordset
    Cmb_LineCode.AddItem " "
    Cmb_LineName.AddItem " "
    Set Rec_Line = Cw_DataEnvi.DataConnect.Execute("Select distinct LineCode,LineName From Qc_v_MidStandMain Order By LineCode ")
    If Rec_Line.RecordCount < 1 Then
        Rec_Line.Close
        Exit Sub
    End If
    Do While Not Rec_Line.EOF
        Cmb_LineCode.AddItem Trim(Rec_Line.Fields("LineCode") & "")  '生产线代码
        Cmb_LineName.AddItem Trim(Rec_Line.Fields("LineName") & "")  '生产线名称
        Rec_Line.MoveNext
    Loop
    Cmb_LineCode.ListIndex = 0
    Cmb_LineName.ListIndex = 0
    
End Sub
']以上为自定义部分

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

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)
        
    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