VB开发的ERP系统

    Dim s As String
    Dim rs As New ADODB.Recordset
    Dim i As Integer
    With frm
        Set .collTableName = coll
        .QueryTableSql = " TableName='Rs_BasicInfo' or TableName='Rs_ExtendInfo' "
        .Show 1
        If .bChecked = True Then
            Me.sSqlWhereMore = .sSqlWhere
        End If
    End With
    Set rs = Nothing
    Set frm = Nothing
End Sub

Private Sub Form_KeyPress(KeyAscii As Integer)   '控 制 焦 点 转 移
   Dim jdzygs As Integer                         '控件焦点转移个数
   jdzygs = 30
   Select Case KeyAscii
      Case vbKeyReturn
           If Kjjdzy(jdzygs) Then
              KeyAscii = 0
           End If
      Case 39           '屏蔽"'"
        KeyAscii = 0
   End Select
End Sub
Private Sub Form_Load()
    On Error GoTo ErrCtrl
   '以下为文本框处理程序
    TextGroupCode = "Rs_QrRsBscCon"
    Call Drwbkxx(TextGroupCode, Textvar(), Textboolean(), Textint(), Textstr())  '读入文本框录入信息
    Call Wbkcsh
    Me.sSqlFrom = " From Rs_BasicInfo left outer join Rs_ExtendInfo on  Rs_Basicinfo.EmpID=Rs_ExtendInfo.EmpID "
    '判断是否显示帮助按钮
    Me.Lab_Note(0).Tag = "EmpNo"
    Me.Lab_Note(1).Tag = "EmpName"
    Me.Lab_Note(2).Tag = "Gender"
    Me.Lab_Note(3).Tag = "EmpSort"
    Me.Lab_Note(4).Tag = "DeptCode"
    Me.Lab_Note(5).Tag = "Position"
    Me.Lab_Note(6).Tag = "Business"
    Me.Lab_Note(7).Tag = "HireProp"
    Dim s As String
    Dim i As Integer
    Dim st As String
    Dim rs As New ADODB.Recordset
    For i = 0 To Me.Lab_Note.count - 1
        st = st & ",'" & Me.Lab_Note(i).Tag & "'"
    Next i
    '判断是否显示帮助按钮
    st = Mid(st, 2, Len(st) - 1)
    s = "select FieldName,CorTable from Rs_Items where FieldName in (" & st & ")"
    Set rs = Cw_DataEnvi.DataConnect.Execute(s)
    With rs
        If .EOF() Then
            MsgBox "初始化错误!", vbOKOnly + vbCritical
            GoTo ErrCtrl
        End If
        For i = 0 To Me.Lab_Note.count - 1
            .MoveFirst
            .Find "FieldName='" & Me.Lab_Note(i).Tag & "'"
            If .EOF() Then
                Me.Ydcommand1(i).Visible = False
            Else
                If Trim(.Fields("CorTable")) = "" Then
                    Me.Ydcommand1(i).Visible = False
                Else
                    Me.Ydcommand1(i).Visible = True
                End If
            End If
        Next i
        .Close
    End With
    Set rs = Nothing
    Exit Sub
    
ErrCtrl:
    If rs.State = 1 Then
        rs.Close
    End If
    Set rs = Nothing
    Unload Me
End Sub

Private Sub Cmd_OK_Click()                                   '确 定
    '录入条件有效性判断
    If Not Lrtjyxxpd Then
       Exit Sub
    End If
    Dim s As String
    '人员范围
    If Me.Opt_SelectNow = True Then
        s = " where Rs_BasicInfo.YNStop=0  " & Chr(10)
    ElseIf Me.Opt_SelectOld = True Then
        s = " where Rs_BasicInfo.YNStop=1  " & Chr(10)
    Else
        s = " where 1=1 " & Chr(10)
    End If
    
    If Me.LrText(0).Text <> "" Then
        s = s & " and Rs_BasicInfo.EmpNo='" & Me.LrText(0).Text & "'"
    End If
    If Me.LrText(1).Text <> "" Then
        s = s & " and Rs_BasicInfo.EmpName='" & Me.LrText(1).Text & "'"
    End If
    
    '性别
    If Me.LrText(2).Text <> "" Then
        s = s & " and Rs_BasicInfo.Gender='" & Me.LrText(2).Tag & "'"
    End If
    '职工类别
    If Me.LrText(3).Text <> "" Then
        s = s & " and Rs_BasicInfo.EmpSort='" & Me.LrText(3).Tag & "'"
    End If
    '部门
    If Me.LrText(4).Text <> "" Then
        s = s & "  and Rs_BasicInfo.DeptCode like '" & Me.LrText(4).Tag & "%'"
    End If
    '岗位
    If Me.LrText(5).Text <> "" Then
        s = s & "  and Rs_BasicInfo.Position='" & Me.LrText(5).Tag & "'"
    End If
    '职务
    If Me.LrText(6).Text <> "" Then
        s = s & " and  Rs_BasicInfo.Business='" & Me.LrText(6).Tag & "'"
    End If
    '用功性质
    If Me.LrText(7).Text <> "" Then
        s = s & " and  Rs_BasicInfo.HireProp='" & Me.LrText(7).Tag & "'"
    End If
    'where语句
    
    s = s + "AND Rs_BasicInfo.EmpId <> -1"
    Me.sSqlWhereMe = s
    If Me.sSqlWhereMore <> "" Then
        Me.sSqlWhere = Me.sSqlWhereMe & " and ( " & Me.sSqlWhereMore & " )"
    Else
        Me.sSqlWhere = Me.sSqlWhereMe
    End If
      
    Me.Hide
    '刷新数据
    With Qr_RsBasicFrm
        .sSqlFrom = Me.sSqlFrom
        .sSqlWhere = Me.sSqlWhere
        .ShowRecord .sSqlWhere
    End With

End Sub

Private Sub QxCommand_Click()                                    '取消
    Me.Hide
End Sub
Private Function Lrtjyxxpd() As Boolean                          '用户录入条件有效性判断
 Dim jsqte As Integer
 Lrtjyxxpd = False
 
'对需要进行事后判断的文本框录入内容进行有效性判断 (固定不变)
  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
   
 '[>>以下为依据实际情况自定义部分
 
  '查询日期范围应由小到大
  
  
 '<<]以上为依据实际情况自定义部分
 
 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)                                                '文本框失去焦点进行有效性判断及相应处理
  If Textint(Index, 9) = 0 Or Textint(Index, 9) = 1 Then '事中判断
     Call TextYxxpd(Index)
  End If
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
    'mp 2001-12-27
    If Me.Ydcommand1(Index).Visible = False Or Me.Ydcommand1(Index).Enabled = False Then
        Exit Sub
    End If
    TextValiJudgeLock(Index) = True
    
     '先进行有效性判断
    If Not TextYxxpd(CurTextIndex) Then
       Exit Sub
    End If
    
     '[>>调入参照窗体
    
    
     sParam = Me.Lab_Note(Index).Tag
    
        
    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 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
  If Trim(LrText(Index)) = "" Then
     LrText(Index).Tag = ""
     Call Wbklrwbcl(Index)
     TextValiJudgeLock(Index) = True
     TextYxxpd = True
     Exit Function
     
  End If
    '没有相关帮助则正确
    If Me.Ydcommand1(Index).Visible = False Or Me.Ydcommand1(Index).Enabled = False Then
        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) + "'")
            Sqlstr = Replace(Sqlstr, "#", "'" + Trim(Me.Lab_Note(Index).Tag) + "'")
            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
   TextYxxpd = True
End Function