Public Function ChineseExist(sText) As Boolean ‘有无汉字
Dim oRegExp As Object
Set oRegExp = CreateObject(“VBScript.RegExp”)
oRegExp.Pattern = “[\u4e00-\u9fa5]”
oRegExp.Global = True
ChineseExist = oRegExp.Test(sText)
Set oRegExp = Nothing
End Function
Public Function NumberSeries(ByVal sText As String) As Variant ‘提取文字中的纯数字,以数组的形式返回
Dim oRegExp As Object
Dim oMatches As Object ‘匹配字符串集合对象
Dim oMatch As Object ‘匹配字符串
Set oRegExp = CreateObject(“Vbscript.RegExp”)
Dim iCount As Integer
Dim TempArray() As Double
With oRegExp
.Global = True ‘True表示匹配所有, False表示仅匹配第一个符合项
.IgnoreCase = True ‘True表示不区分大小写, False表示区分大小写
.Pattern = “([0-9])?.+|([0-9])+” ‘匹配字符模式(不识 + – % 号)
Set oMatches = .Execute(sText) ‘执行正则查找，返回所有匹配结果的集合，若未找到，则为空
For Each oMatch In oMatches
ReDim Preserve TempArray(0 To iCount)
TempArray(iCount) = oMatch.Value
iCount = iCount + 1
Next
End With
NumberSeries = TempArray
Set oRegExp = Nothing
Set oMatches = Nothing
End Function
Public Function PureLetter(sText) As Boolean ‘纯字母
Dim oRegExp As Object
Set oRegExp = CreateObject(“VBScript.RegExp”)
oRegExp.Pattern = “^[A-Za-z]+$”
oRegExp.Global = True
PureLetter = oRegExp.Test(sText)
Set oRegExp = Nothing
End Function
Public Function PureNumber(sText) As Boolean ‘纯数字
Dim oRegExp As Object
Set oRegExp = CreateObject(“VBScript.RegExp”)
oRegExp.Pattern = “^[0-9]+$”
oRegExp.Global = True
PureNumber = oRegExp.Test(sText)
Set oRegExp = Nothing
End Function
Public Function ReplaceExp(ByVal sText As String, ByVal sPattern As String, ByVal sNew As String) As String ‘文字替换
Dim oRegExp As Object
Set oRegExp = CreateObject(“VBScript.RegExp”)
oRegExp.Pattern = sPattern ‘设置模板属性
oRegExp.IgnoreCase = True ‘忽略大小写
oRegExp.Global = True ‘匹配所有搜索项还是只匹配第一项
oRegExp.MultiLine = True ‘是否在多行中搜索
ReplaceExp = oRegExp.Replace(sText, sNew)
Set oRegExp = Nothing
End Function
Public Function IsUrl(ByVal sText As String) As Boolean ‘合法 Url
On Error GoTo ERR_Url
Dim oRegExp As Object
IsUrl = False
Set oRegExp = CreateObject(“VBScript.RegExp”)
oRegExp.Pattern = “(((ht|f)tps?://)|(www.))([\w-]+.)+[\w-:]+(/[\w- ./?%#;&=]*)?”
oRegExp.Global = True
IsUrl = oRegExp.Test(sText)
Set oRegExp = Nothing
ERR_Url:
End Function
Public Function IsMail(ByVal sText As String) ‘合法 eMail
On Error GoTo ERR_Mail
Dim oRegExp As Object
IsMail = False
Set oRegExp = CreateObject(“VBScript.RegExp”)
oRegExp.Pattern = “\w+([-+.]\w+)@\w+([-.]\w+).\w+([-.]\w+)*”
oRegExp.Global = True
IsMail = oRegExp.Test(sText)
Set oRegExp = Nothing
ERR_Mail:
End Function
Public Function ChineseCount(ByVal sText As String) As Long ‘汉字数量
Dim oRegExp As Object
Dim oMatchs As Object
Set oRegExp = CreateObject(“VBScript.RegExp”)
oRegExp.Global = True
oRegExp.Pattern = “[\u4e00-\u9fa5]”
Set oMatchs = oRegExp.Execute(sText) ‘成功匹配的 Match 对象集合
ChineseCount = oMatchs.Count
Set oRegExp = Nothing
End Function
Public Function CheckID(ByVal sText As String, ByVal iFunction As Integer) As String ‘核查 ID, 判断证件号码是否正确, 或提取出生日期,或返回性别, 或返回年龄
Dim oItem As Object
Dim iSum As Integer
Dim FactorArray As Variant, CRCArray As Variant
Dim I As Integer
Dim sBirthDate As String
FactorArray = Array(7, 9, 10, 5, 8, 4, 2, 1, 6, 3, 7, 9, 10, 5, 8, 4, 2) ‘身份证号加权因子
CRCArray = Array(“1”, “0”, “X”, “9”, “8”, “7”, “6”, “5”, “4”, “3”, “2”) ‘最后一位有效校验位
If Len(sText) = 18 Then ‘判断是否为18位
Set oRegExp = CreateObject(“Vbscript.RegExp”)
oRegExp.Pattern = “[A-Za-z0-9]{1}” ‘应用正则表达式分拆成18个1位数，此步可以应用mid函数，但正则表达式会效率会更高
oRegExp.Global = True
Set oItem = oRegExp.Execute(sText)
For I = 0 To 16
iSum = oItem(I) * FactorArray(I) + iSum
Next I
If CRCArray(iSum Mod 11) = UCase(oItem(17)) Then
Select Case iFunction
Case 1 ‘判断证件号码是否正确
CheckID = “True”
Case 2 ‘提取出生日期
CheckID = Format(Mid(sText, 7, 8), “0-00-00”)
Case 3 ‘返回性别
If oItem(16) Mod 2 = 0 Then CheckID = “Female” Else CheckID = “Male”
Case 4 ‘返回周岁年龄
sBirthDate = Format(Mid(sText, 7, 8), “0-00-00”)
If Month(sBirthDate) < Month(Date) Then CheckID = DateDiff(“yyyy”, sBirthDate, Date) ElseIf Month(sBirthDate) > Month(Date) Then
CheckID = DateDiff(“yyyy”, sBirthDate, Date) – 1
ElseIf Day(sBirthDate) > Day(Date) Then
CheckID = DateDiff(“yyyy”, sBirthDate, Date) – 1
Else
CheckID = DateDiff(“yyyy”, sBirthDate, Date)
End If
End Select
Else
CheckID = “False” ‘错误
End If
Else
CheckID = “Invalid” ‘非中国居民身份证
End If
End Function