增强校验E-mail地址有效性

'**************************************
' 模块名: 增强校验E-mail地址有效性
' 功能描述:这个模块主要功能是检查e-mail地址、IP/DNS 主机名以及上一级的管理域的有效性，他将给予任何地方最正'确的确认。校验 域/主机名可以查找整个 IPv4地址段并给予标识，私有网络排除，lookback等，若保留范围是被排除的，则进行多点传送。
'返回值:每个函数返回对应的True,校验邮件地址返回Flase则是无效的
’******************************************
Option Explicit

Public Function IsValidEmail(Expression As String) As Boolean
    Dim objRegExp As RegExp
    Set objRegExp = New RegExp
    Expression = Trim(Expression) 'Whack any whitespace at both ends
    objRegExp.IgnoreCase = True
    objRegExp.Pattern = "^[/w/.-]+@((([a-z]([a-z0-9-]{0,61}[a-z0-9])?)/.)+[a-z]{2,}|(/d{1,3}/.){3}/d{1,3})$"
    IsValidEmail = objRegExp.Test(Expression)
    If Not IsValidEmail Then Exit Function 'Failed basic format test, so exit
    
    'separate the domain for the remainder of the tests
    IsValidEmail = IsValidIPHost(Mid$(Expression, InStr(Expression, "@") + 1),False)
End Function


Public Function IsValidIPHost(HostString As String, Optional bReservedAllowed As Boolean = True, Optional bMulticastAllowed As Boolean = False) As Boolean
    Dim sSplit() As String
    Dim objRegEx As RegExp
    Dim intOctet2 As Integer
    
    HostString = Trim(HostString) 'dump any leading/trailing whitespace


    If Len(HostString) < 256 Then
        Set objRegEx = New RegExp
        objRegEx.IgnoreCase = True
        objRegEx.Pattern = "^(([a-z]([a-z0-9-]{0,61}[a-z0-9])?)/.)+[a-z]{2,}$" '|(/d{1,3}/.){3}/d{1,3})$"


        If objRegEx.Test(HostString) Then
            IsValidIPHost = IsTopLevelDomain(Mid$(HostString, InStrRev(HostString, ".") + 1))
        Else
            objRegEx.Pattern = "^(/d{1,3}/.){3}/d{1,3}$"


            If objRegEx.Test(HostString) Then 'we have a dotted-quad
                sSplit = Split(HostString, ".")
                IsValidIPHost = ((sSplit(0) > 255) + (sSplit(1) > 255) + (sSplit(2) > 255) + (sSplit(3) > 255) = 0)
                If Not IsValidIPHost or bReservedAllowed Then Exit Function
                intOctet2 = CInt(sSplit(1))


                Select Case CInt(sSplit(0))
                    Case 10, 127, Is > 239 ' Private Network, Loopback or Reserved
                    IsValidIPHost = False
                    Case 172'Private Network
                    If intOctet2 > 15 And intOctet2 < 32 Then IsValidIPHost = False
                    Case 192'Local Network
                    If intOctet2 = 168 Then IsValidIPHost = False
                    Case 169'Autoconfiguration addresses
                    If intOctet2 = 254 Then IsValidIPHost = False
                    Case Is > 223 'Multicast addresses
                    IsValidIPHost = bMulticastAllowed
                End Select
        Else
            IsValidIPHost = False
        End If
    End If
Else
    IsValidIPHost = False
End If
End Function


Private Function IsTopLevelDomain(DomainString As String) As Boolean
    Dim sTLD As String
    Dim objRegEx As RegExp
    
    sTLD = "AC AD AE AERO AF AG AI AL AM AN AO AQ AR ARPA AS AT AU AW AX AZ" & _
    " BA BB BD BE BF BG BH BI BIZ BJ BM BN BO BR BS BT BV BW BY BZ CA" & _
    " CAT CC CD CF CG CH CI CK CL CM CN CO COM COOP CR CU CV CX CY CZ" & _
    " DE DJ DK DM Do DZ EC EDU EE EG ER ES ET EU FI FJ FK FM FO FR GA" & _
    " GB GD GE GF GG GH GI GL GM GN GOV GP GQ GR GS GT GU GW GY HK HM" & _
    " HN HR HT HU ID IE IL IM In INFO INT IO IQ IR IS IT JE JM JO JOBS" & _
    " JP KE KG KH KI KM KN KR KW KY KZ LA LB LC LI LK LR LS LT LU LV LY" & _
    " MA MC MD MG MH MIL MK ML MM MN MO MOBI MP MQ MR MS MT MU MUSEUM" & _
    " MV MW MX MY MZ NA NAME NC NE NET NF NG NI NL NO NP NR NU NZ OM orG" & _
    " PA PE PF PG PH PK PL PM PN PR PRO PS PT PW PY QA RE RO RU RW SA SB" & _
    " SC SD SE SG SH SI SJ SK SL SM SN SO SR ST SU SV SY SZ TC TD TF TG" & _
    " TH TJ TK TL TM TN To TP TR TRAVEL TT TV TW TZ UA UG UK UM US UY UZ" & _
    " VA VC VE VG VI VN VU WF WS YE YT YU ZA ZM ZW"
    
    Set objRegEx = New RegExp
    objRegEx.IgnoreCase = True
    objRegEx.Pattern = "/b" & DomainString & "/b"
    IsTopLevelDomain = objRegEx.Test(sTLD)
End Function