VB开发的ERP系统

            KeyAscii = 0
   End Select
   
End Sub

Private Sub Form_Load()                              '窗 体 装 入

    Dim count As Integer

    '以下为文本框处理程序
    TextGroupCode = "Chhs_MakeVoucherFind"
    
    Call Drwbkxx(TextGroupCode, Textvar(), Textboolean(), Textint(), Textstr())  '读入文本框录入信息
    Call Wbkcsh
     
    '添加仓库  汇总方式
    Call Add_BillType
      
    '初始定义
    ReDim SaveLst(Lst_BillCode.ListCount - 1)
    ReDim SaveTxt(LrText.count - 1)
    ReDim SaveOption(2)
    
    For count = 0 To Lst_BillCode.ListCount - 1
        SaveLst(count) = False
    Next count
    For count = 0 To LrText.count - 1
       SaveTxt(count) = ""
    Next count
    
    SaveOption(0) = True
    SaveOption(1) = False
    SaveOption(2) = False
 
  
  
End Sub

Private Sub Add_BillType()           '添加内容
    
    Dim Rectemp As Recordset
        
    With Lst_BillCode
        .AddItem "材料入库单"
        BillCode(0) = "1212"
        .AddItem "产品入库单"
        BillCode(1) = "1202"
        .AddItem "其他入库单"
        BillCode(2) = "1203"
        .AddItem "材料出库单"
        BillCode(3) = "1204"
        .AddItem "销售出库单"
        BillCode(4) = "1205"
        .AddItem "其他出库单"
        BillCode(5) = "1206"
        .AddItem "入库单调整"
        BillCode(6) = "1301"
        .AddItem "出库单调整"
        BillCode(7) = "1302"
        .AddItem "计划价调整单"
        BillCode(8) = "1303"
        .AddItem "蓝字暂估单"
        BillCode(9) = "1304"
        .AddItem "红字回冲单"
        BillCode(10) = "1305"
        .AddItem "差异结转单"
        BillCode(11) = "1307"
        
    End With
    
End Sub

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

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

  '以下为依据实际情况自定义部分[
   
  ']以上为依据实际情况自定义部分
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)

    If UnloadCheck.Value <> 1 Then
       Cancel = 1
       Call QxCommand_Click
    End If
    
End Sub

Private Sub LrText_Change(Index As Integer)

    '屏蔽程序改变控制
    If TextChangeLock Then
        Exit Sub
    End If
   
    TextValiJudgeLock(Index) = False    '打开有效性判断锁
    
    '限制字段录入长度
          
    TextChangeLock = True  '加锁(防止执行Txt_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)
    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 QdCommand_Click()      '确认

    Dim count As Integer
    Dim BillTypeFlag As Boolean
     '录入条件有效性判断
    If Not Lrtjyxxpd Then
        Exit Sub
    End If
    
    '判断是否选中单据
    For count = 0 To Lst_BillCode.ListCount - 1
        If Lst_BillCode.Selected(count) Then
            BillTypeFlag = True
            Exit For
        End If
        BillTypeFlag = False
    Next
    
    If Not BillTypeFlag Then
        Tsxx = "请选择至少一种单据"
        Call Xtxxts(Tsxx, 0, 4)
        Exit Sub
    End If
    
    '选择单据
    MSQLStr = ""
    For count = 0 To Lst_BillCode.ListCount - 1
        If Lst_BillCode.Selected(count) And MSQLStr = "" Then
            MSQLStr = "AND (BillCode='" & BillCode(count) & "'"
        Else
            If Lst_BillCode.Selected(count) Then
                MSQLStr = MSQLStr + " OR " & " BillCode='" & BillCode(count) & "'"
            End If
        End If
    Next
    MSQLStr = MSQLStr + ")"
    
    '激活查询过程
    CL_MakeVoucher.Timer1.Enabled = True
    
    '保存查询条件设置
    For count = 0 To Lst_BillCode.ListCount - 1
        SaveLst(count) = Lst_BillCode.Selected(count)
    Next count
    For count = 0 To LrText.count - 1
       SaveTxt(count) = LrText(count)
    Next count
    
    SaveOption(0) = Opti_bill1.Value
    SaveOption(1) = Opti_bill2.Value
    SaveOption(2) = Opti_pz.Value
    
    Me.Hide
    
    
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
    
    TextValiLock = True
    
    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
     
    TextValiLock = False
    LrText(Index).SetFocus
    
End Sub

Private Sub TextShow(Index As Integer)        '文本框得到焦点,显示相应信息
   '填写文本框得到焦点,进行相应信息处理程序
End Sub

Private Sub Wbkcsh()                          '录入文本框初始化
    
    '最大录入文本框索引值
    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 TextValiLock Then
        TextValiLock = False
        TextYxxpd = True
        Exit Function
    End If
    
    '文本框内容未曾改变不进行有效性判断
  
    If TextValiJudgeLock(Index) Then
        TextYxxpd = True
        Exit Function
    End If
    
    Call Wbklrwbcl(Index)
  
    If Trim(LrText(Index)) = "" Then
        LrText(Index).Tag = ""
        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) + "'")
            SqlStr = Replace(SqlStr, "$$", "'" + Trim(Xtczybm) + "'")
            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

Private Sub QxCommand_Click()
    
    '恢复查询设置
    For Jsqte = 0 To Lst_BillCode.ListCount - 1
        Lst_BillCode.Selected(Jsqte) = SaveLst(Jsqte)
    Next Jsqte
    For Jsqte = 0 To LrText.count - 1
        LrText(Jsqte) = SaveTxt(Jsqte)
    Next Jsqte
    
    Opti_bill1 = SaveOption(0)
    Opti_bill2 = SaveOption(1)
    Opti_pz = SaveOption(2)
    
    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
   
    '[>>以下为依据实际情况自定义部分
  
    If LrText(3).Text > LrText(4).Text And LrText(4).Text <> "" Then
        Tsxx = "日期范围应由小到大!"
        Call Xtxxts(Tsxx, 0, 4)
        LrText(3).SetFocus
        Exit Function
    End If

    '<<]以上为依据实际情况自定义部分
 
    Lrtjyxxpd = True
    
End Function

Public Property Get SqlStr() As Variant
    SqlStr = MSQLStr
End Property