Access更好用的实时表单验证架构开发
hi，大家好！ 为什么还不春节，最近又不知道在忙些啥，又半个月过去了，答应大家的框架，又又又跳票了！既然这样的话，今天那就再给大家分享点干货！今天的代码量比较大，大家给个一键三连吧，谢谢大家啦啦啦！ 现代 Web 开发（如 Bootstrap、Vue 等框架）通过 DOM 操作实现了“所见即所得”的验证反馈（红框、图标、气泡提示）。本文旨在通过 VBA 模拟这一机制。 首先，我们先创建一个类模块：ClsFieldValidator，你没有看错，我们上来就要创建一个类模块，这里写了几个常用的验证，必填、邮箱、手机号、身份证号、纯数字、长度限制、数值范围、自定义正则、日期格式。 接着，我们要再创建一个通用模块。模块名：M_ValidationUI 类与通用的模块都有了，接下来就教大家来调用了，创建一个窗体，具体的如下图，一个文本框（txtEmail），2个标签（lblEmailStatus，lblMobileError），一个按钮。 控件有了，就可以来添加相应的调用代码了，具体的代码里注释都添加好了，大家自己查看添加。 最后，就是运行测试了，我们来看一下效果。 这里的样式觉得不满意的，也可以自行调整。 设计思路 喜欢这篇文章？点个“在看”，分享给更多 Access 开发者！
平时，我们在开发的过程中，遇到需要验证的文本框，是不是还在用IF ……Then MsgBox…… 这样的方式输出？那也太Low了，那今天就给大家分享一个完整的验证方案！来吧，让我们Hi起来！1。创建类模块
' 类模块: ClsFieldValidator
Option Compare Database
Option Explicit
' 验证结果枚举
Public Enum ValidationResult
vrValid = 0
vrInvalid = 1
vrEmpty = 2
End Enum
' 验证类型枚举
Public Enum validationType
vtRequired = 1 ' 必填
vtEmail = 2 ' 邮箱
vtMobile = 3 ' 手机号
vtIDCard = 4 ' 身份证号
vtNumeric = 5 ' 纯数字
vtLength = 6 ' 长度限制
vtRange = 7 ' 数值范围
vtCustomRegex = 8 ' 自定义正则
vtDate = 9 ' 日期格式
End Enum
Private m_MinLength As Long
Private m_MaxLength As Long
Private m_MinValue As Double
Private m_MaxValue As Double
Private m_CustomPattern As String
Private m_ErrorMessage As String
' ========== 属性 ==========
Public Property Get errorMessage() As String
errorMessage = m_ErrorMessage
End Property
Public Property Let MinLength(value As Long)
m_MinLength = value
End Property
Public Property Let MaxLength(value As Long)
m_MaxLength = value
End Property
Public Property Let MinValue(value As Double)
m_MinValue = value
End Property
Public Property Let MaxValue(value As Double)
m_MaxValue = value
End Property
Public Property Let CustomPattern(value As String)
m_CustomPattern = value
End Property
' ========== 核心验证方法 ==========
Public Function Validate(ByVal inputValue As Variant, ByVal validationType As validationType) As ValidationResult
Dim strValue As String
strValue = Nz(inputValue, "")
' 清空上次错误信息
m_ErrorMessage = ""
Select Case validationType
Case vtRequired
Validate = ValidateRequired(strValue)
Case vtEmail
Validate = ValidateEmail(strValue)
Case vtMobile
Validate = ValidateMobile(strValue)
Case vtIDCard
Validate = ValidateIDCard(strValue)
Case vtNumeric
Validate = ValidateNumeric(strValue)
Case vtLength
Validate = ValidateLength(strValue)
Case vtRange
Validate = ValidateRange(strValue)
Case vtCustomRegex
Validate = ValidateRegex(strValue)
Case vtDate
Validate = ValidateDate(strValue)
Case Else
Validate = vrValid
End Select
End Function
' ========== 具体验证规则 ==========
' 必填验证
Private Function ValidateRequired(strValue As String) As ValidationResult
If Len(Trim(strValue)) = 0 Then
m_ErrorMessage = "此字段为必填项"
ValidateRequired = vrEmpty
Else
ValidateRequired = vrValid
End If
End Function
' 邮箱验证
Private Function ValidateEmail(strValue As String) As ValidationResult
If Len(Trim(strValue)) = 0 Then
ValidateEmail = vrEmpty
Exit Function
End If
' 使用 VBScript.RegExp 进行正则验证
Dim regex As Object
Set regex = CreateObject("VBScript.RegExp")
With regex
.Global = True
.IgnoreCase = True
.Pattern = "^[a-zA-Z0-9._%+-]+@[a-zA-Z0-9.-]+\.[a-zA-Z]{2,}$"
End With
If regex.test(strValue) Then
ValidateEmail = vrValid
Else
m_ErrorMessage = "请输入有效的邮箱地址"
ValidateEmail = vrInvalid
End If
Set regex = Nothing
End Function
' 手机号验证 (中国大陆11位手机号)
Private Function ValidateMobile(strValue As String) As ValidationResult
If Len(Trim(strValue)) = 0 Then
ValidateMobile = vrEmpty
Exit Function
End If
Dim regex As Object
Set regex = CreateObject("VBScript.RegExp")
With regex
.Global = True
.Pattern = "^1[3-9]\d{9}$"
End With
If regex.test(strValue) Then
ValidateMobile = vrValid
Else
m_ErrorMessage = "请输入有效的11位手机号"
ValidateMobile = vrInvalid
End If
Set regex = Nothing
End Function
' 身份证号验证 (18位)
Private Function ValidateIDCard(strValue As String) As ValidationResult
If Len(Trim(strValue)) = 0 Then
ValidateIDCard = vrEmpty
Exit Function
End If
Dim regex As Object
Set regex = CreateObject("VBScript.RegExp")
With regex
.Global = True
.IgnoreCase = True
' 18位身份证：6位地区码 + 8位生日 + 3位顺序码 + 1位校验码
.Pattern = "^\d{6}(19|20)\d{2}(0[1-9]|1[0-2])(0[1-9]|[12]\d|3[01])\d{3}[\dXx]$"
End With
If regex.test(strValue) Then
' 进一步验证校验码
If ValidateIDCardChecksum(strValue) Then
ValidateIDCard = vrValid
Else
m_ErrorMessage = "身份证号校验码错误"
ValidateIDCard = vrInvalid
End If
Else
m_ErrorMessage = "请输入有效的18位身份证号"
ValidateIDCard = vrInvalid
End If
Set regex = Nothing
End Function
' 身份证校验码算法
Private Function ValidateIDCardChecksum(strValue As String) As Boolean
Dim weights As Variant
Dim checkCodes As String
Dim total As Long
Dim i As Long
weights = Array(7, 9, 10, 5, 8, 4, 2, 1, 6, 3, 7, 9, 10, 5, 8, 4, 2)
checkCodes = "10X98765432"
total = 0
For i = 1 To 17
total = total + CInt(Mid(strValue, i, 1)) * weights(i - 1)
Next i
Dim checkChar As String
checkChar = Mid(checkCodes, (total Mod 11) + 1, 1)
ValidateIDCardChecksum = (UCase(Mid(strValue, 18, 1)) = checkChar)
End Function
' 纯数字验证
Private Function ValidateNumeric(strValue As String) As ValidationResult
If Len(Trim(strValue)) = 0 Then
ValidateNumeric = vrEmpty
Exit Function
End If
If IsNumeric(strValue) Then
ValidateNumeric = vrValid
Else
m_ErrorMessage = "请输入有效的数字"
ValidateNumeric = vrInvalid
End If
End Function
' 长度验证
Private Function ValidateLength(strValue As String) As ValidationResult
Dim strLen As Long
strLen = Len(strValue)
If strLen = 0 Then
ValidateLength = vrEmpty
Exit Function
End If
If m_MinLength > 0 And strLen < m_MinLength Then
m_ErrorMessage = "长度不能少于 " & m_MinLength & " 个字符"
ValidateLength = vrInvalid
ElseIf m_MaxLength > 0 And strLen > m_MaxLength Then
m_ErrorMessage = "长度不能超过 " & m_MaxLength & " 个字符"
ValidateLength = vrInvalid
Else
ValidateLength = vrValid
End If
End Function
' 数值范围验证
Private Function ValidateRange(strValue As String) As ValidationResult
If Len(Trim(strValue)) = 0 Then
ValidateRange = vrEmpty
Exit Function
End If
If Not IsNumeric(strValue) Then
m_ErrorMessage = "请输入有效的数字"
ValidateRange = vrInvalid
Exit Function
End If
Dim numValue As Double
numValue = CDbl(strValue)
If numValue < m_MinValue Then
m_ErrorMessage = "数值不能小于 " & m_MinValue
ValidateRange = vrInvalid
ElseIf numValue > m_MaxValue Then
m_ErrorMessage = "数值不能大于 " & m_MaxValue
ValidateRange = vrInvalid
Else
ValidateRange = vrValid
End If
End Function
' 自定义正则验证
Private Function ValidateRegex(strValue As String) As ValidationResult
If Len(Trim(strValue)) = 0 Then
ValidateRegex = vrEmpty
Exit Function
End If
If Len(m_CustomPattern) = 0 Then
ValidateRegex = vrValid
Exit Function
End If
Dim regex As Object
Set regex = CreateObject("VBScript.RegExp")
With regex
.Global = True
.IgnoreCase = True
.Pattern = m_CustomPattern
End With
If regex.test(strValue) Then
ValidateRegex = vrValid
Else
m_ErrorMessage = "输入格式不正确"
ValidateRegex = vrInvalid
End If
Set regex = Nothing
End Function
' 日期格式验证
Private Function ValidateDate(strValue As String) As ValidationResult
If Len(Trim(strValue)) = 0 Then
ValidateDate = vrEmpty
Exit Function
End If
If IsDate(strValue) Then
ValidateDate = vrValid
Else
m_ErrorMessage = "请输入有效的日期"
ValidateDate = vrInvalid
End If
End Function
2。添加一个通用模块
' 标准模块: M_ValidationUI
Option Compare Database
Option Explicit
' 验证状态图标 (使用 Unicode 字符)
Public Const ICON_VALID As String = "验证正确"
Public Const ICON_INVALID As String = "验证错误"
Public Const ICON_EMPTY As String = ""
' 颜色常量
Public Const COLOR_VALID As Long = 32768 ' 绿色 RGB(0, 128, 0)
Public Const COLOR_INVALID As Long = 255 ' 红色 RGB(255, 0, 0)
Public Const COLOR_WARNING As Long = 33023 ' 橙色 RGB(255, 128, 0)
Public Const COLOR_DEFAULT As Long = 0 ' 黑色
' 更新验证状态显示
Public Sub UpdateValidationStatus( _
ByVal lblStatus As Access.Label, _
ByVal result As ValidationResult, _
Optional ByVal errorMessage As String = "")
Select Case result
Case vrValid
With lblStatus
.Caption = ICON_VALID
.ForeColor = COLOR_VALID
.ControlTipText = "验证通过"
End With
Case vrInvalid
With lblStatus
.Caption = ICON_INVALID
.ForeColor = COLOR_INVALID
.ControlTipText = IIf(Len(errorMessage) > 0, errorMessage, "验证失败")
End With
Case vrEmpty
With lblStatus
.Caption = ICON_EMPTY
.ForeColor = COLOR_DEFAULT
.ControlTipText = ""
End With
End Select
End Sub
' 高亮文本框边框 (模拟 Web 效果)
Public Sub HighlightTextBox( _
ByVal txtControl As Access.TextBox, _
ByVal result As ValidationResult)
Select Case result
Case vrValid
txtControl.BorderColor = COLOR_VALID
Case vrInvalid
txtControl.BorderColor = COLOR_INVALID
Case vrEmpty
txtControl.BorderColor = COLOR_DEFAULT
End Select
End Sub
' 显示错误提示气泡 (使用标签模拟 Tooltip)
Public Sub ShowErrorTooltip( _
ByVal lblTooltip As Access.Label, _
ByVal message As String, _
ByVal show As Boolean)
If show And Len(message) > 0 Then
With lblTooltip
.Caption = message
.Visible = True
.BackColor = RGB(255, 240, 240) ' 浅红色背景
.ForeColor = COLOR_INVALID
.BorderColor = COLOR_INVALID
.BorderStyle = 1 ' 实线边框
End With
Else
lblTooltip.Visible = False
End If
End Sub
' 验证整个表单，返回是否全部通过
Public Function ValidateForm(frm As Access.Form, ParamArray validations() As Variant) As Boolean
Dim i As Long
Dim allValid As Boolean
Dim result As ValidationResult
Dim validator As ClsFieldValidator
allValid = True
Set validator = New ClsFieldValidator
' validations 参数格式: txtControl, lblStatus, ValidationType, [可选参数...]
' 示例调用: ValidateForm(Me, Me.txtEmail, Me.lblEmailStatus, vtEmail, ...)
For i = LBound(validations) To UBound(validations) Step 3
Dim txtCtrl As Access.TextBox
Dim lblCtrl As Access.Label
Dim vType As validationType
Set txtCtrl = validations(i)
Set lblCtrl = validations(i + 1)
vType = validations(i + 2)
result = validator.Validate(txtCtrl.value, vType)
UpdateValidationStatus lblCtrl, result, validator.errorMessage
HighlightTextBox txtCtrl, result
If result = vrInvalid Then allValid = False
' 必填字段为空也算失败
If vType = vtRequired And result = vrEmpty Then allValid = False
Next i
ValidateForm = allValid
Set validator = Nothing
End Function
3。创建窗体
这里我们只用一个邮件验证来举例！
4。窗体代码
Option Compare Database
Private m_Validator As ClsFieldValidator
' ========== 提交按钮验证 ==========
Private Sub Command4_Click()
Dim r3 As ValidationResult
r3 = m_Validator.Validate(Me.txtEmail, vtEmail)
UpdateValidationStatus Me.lblEmailStatus, r3, m_Validator.errorMessage
HighlightTextBox Me.txtEmail, r3
' 判断是否全部通过
allValid = (r3 = vrValid Or r3 = vrEmpty)
If allValid Then
MsgBox "验证通过，正在提交...", vbInformation, "成功"
Else
MsgBox "请检查输入内容，修正标红的字段。", vbExclamation, "验证失败"
End If
End Sub
Private Sub Form_Load()
Set m_Validator = New ClsFieldValidator
InitStatusLabels
End Sub
' 初始化状态标签
Private Sub InitStatusLabels()
Dim lbls As Variant
Dim i As Long
lbls = Array(Me.lblEmailStatus)
For i = LBound(lbls) To UBound(lbls)
With lbls(i)
.Caption = ""
.FontSize = 14
.FontBold = True
.TextAlign = 2 ' 居中
End With
Next i
' 隐藏错误提示标签
Me.lblMobileError.Visible = False
End Sub
' 通用验证方法
Private Function ValidateField( _
txtCtrl As Access.TextBox, _
lblStatus As Access.Label, _
vType As validationType) As ValidationResult
Dim result As ValidationResult
result = m_Validator.Validate(txtCtrl.value, vType)
' 更新 UI
UpdateValidationStatus lblStatus, result, m_Validator.errorMessage
HighlightTextBox txtCtrl, result
ValidateField = result
End Function
' ========== 可选：失去焦点时验证 ==========
Private Sub txtEmail_LostFocus()
Dim result As ValidationResult
If Len(Nz(Me.txtEmail, "")) > 0 Then
result = ValidateField(Me.txtEmail, Me.lblEmailStatus, vtEmail)
ShowErrorTooltip Me.lblMobileError, m_Validator.errorMessage, (result = vrInvalid)
End If
End Sub
5。运行测试
