Access更好用的实时表单验证架构开发-开发者社区

hi，大家好！

为什么还不春节，最近又不知道在忙些啥，又半个月过去了，答应大家的框架，又又又跳票了！既然这样的话，今天那就再给大家分享点干货！今天的代码量比较大，大家给个一键三连吧，谢谢大家啦啦啦！

平时，我们在开发的过程中，遇到需要验证的文本框，是不是还在用IF ……Then MsgBox…… 这样的方式输出？那也太Low了，那今天就给大家分享一个完整的验证方案！来吧，让我们Hi起来！

现代 Web 开发（如 Bootstrap、Vue 等框架）通过 DOM 操作实现了“所见即所得”的验证反馈（红框、图标、气泡提示）。本文旨在通过 VBA 模拟这一机制。

1。创建类模块

首先，我们先创建一个类模块：ClsFieldValidator，你没有看错，我们上来就要创建一个类模块，这里写了几个常用的验证，必填、邮箱、手机号、身份证号、纯数字、长度限制、数值范围、自定义正则、日期格式。

' 类模块: 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

' 标准模块: 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。创建窗体

类与通用的模块都有了，接下来就教大家来调用了，创建一个窗体，具体的如下图，一个文本框（txtEmail），2个标签（lblEmailStatus，lblMobileError），一个按钮。

这里我们只用一个邮件验证来举例！

4。窗体代码

控件有了，就可以来添加相应的调用代码了，具体的代码里注释都添加好了，大家自己查看添加。

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。运行测试

最后，就是运行测试了，我们来看一下效果。

这里的样式觉得不满意的，也可以自行调整。

设计思路

采用面向对象（OOP）的设计思路，将验证规则与 UI 渲染分离。