📄
字号:
'对需要进行事后判断的文本框录入内容进行有效性判断 (固定不变)
For jsqte = 0 To Max_Text_Index
If Textint(Index, 9) = 0 Or Textint(Index, 9) = 2 Then
If Not TextYxxpd(jsqte) Then
Exit Function
End If
End If
Next jsqte
For jsqte = 0 To Max_Text_Index
If Textint(jsqte, 8) = 1 Then '字段不能为空
If Len(Trim(LrText(jsqte).Text)) = 0 Then
Tsxx = Textstr(jsqte, 7) & "不能为空!"
Call Xtxxts(Tsxx, 0, 1)
If LrText(jsqte).Enabled Then
LrText(jsqte).SetFocus
End If
Sub_SaveBill = False
Exit Function
End If
Else
If Textint(jsqte, 8) = 2 Then '字段不能为零
If Val(Trim(LrText(jsqte).Text)) = 0 Then
Tsxx = Textstr(jsqte, 7) & "不能为零!"
Call Xtxxts(Tsxx, 0, 1)
If LrText(jsqte).Enabled Then
LrText(jsqte).SetFocus
End If
Sub_SaveBill = False
Exit Function
End If
End If
End If
Next jsqte
'[>>以下为依据实际情况自定义部分
'查询单据日期范围应由小到大
If LrText(1).Text > LrText(2).Text And Trim(LrText(2).Text) <> "" Then
Tsxx = "查询单据日期范围应由小到大!"
Call Xtxxts(Tsxx, 0, 4)
LrText(1).SetFocus
Exit Function
End If
'如果核销类型为应付冲应收则客户项不能为空
If LrText(3).Enabled And Trim(LrText(3).Text) = "" Then
Tsxx = "应付冲应收则客户项不能为空!"
Call Xtxxts(Tsxx, 0, 4)
LrText(3).SetFocus
Exit Function
End If
'<<]以上为依据实际情况自定义部分
Lrtjyxxpd = True
End Function
Private Sub Combo_Jshxlx_Click() '如果为应收款冲应付款则供应商不能为空
If Combo_Jshxlx.ListIndex = 2 Then
Call Textyx(LrText(3))
Ydcommand1(3).Enabled = True
Else
TextChangeLock = True
LrText(3).Tag = ""
LrText(3).Text = ""
TextChangeLock = False
Call Textwx(LrText(3))
Ydcommand1(3).Enabled = False
End If
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)
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) '文本框失去焦点
'显示相应信息但不能进行有效性判断
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
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -