People think computers will keep them from making mistakes. They're wrong. With computers you make mistakes faster. - Adam Osborne

Top Ten Tags

Who's Online

Here's some code I adapted from two seperate threads at MrExcel's forum to check whether an email address is valid email pattern, i.e. This email address is being protected from spambots. You need JavaScript enabled to view it., AND also if the domain is valid.

IsEmailAddress("This email address is being protected from spambots. You need JavaScript enabled to view it.") = TRUE
IsEmailAddress("me@test@com") = FALSE
IsEmailAddress("This email address is being protected from spambots. You need JavaScript enabled to view it.") = FALSE

IsURL("http://test.com") = TRUE
IsURL("http://test.xom") = FALSE

VBA Code

Public Function IsEmailAddress(strEmail As String, Optional blnCheckDomain As Boolean = False) As Boolean

    '*********************************************************************************************************
    'Adapted by Azli Hassan (http://azlihassan.com/apps)
    'Original code from https://www.mrexcel.com/forum/excel-questions/268673-vba-textbox-email-validation.html
    'Function:  Determine if an email address fits an email pattern, e.g. This email address is being protected from spambots. You need JavaScript enabled to view it.
    'Arguments:
    '   strEmail (String):  Email address to Check
    '   blnCheckDomain (Boolean): Optional, check if email domain is valid.
    '*********************************************************************************************************

    On Error GoTo Err:


    Dim strURL As String

    'Assume is not valid
    IsEmailAddress = False

    'Test if valid or not
    With CreateObject("vbscript.regexp")
        .Pattern = "^[\w-\.]+@([\w-]+\.)+[A-Za-z]{2,4}$"
        IsEmailAddress = .test(strEmail)
    End With

    If IsEmailAddress And blnCheckDomain Then
        strURL = Right(strEmail, Len(strEmail) - InStr(1, strEmail, "@", vbTextCompare))
        IsEmailAddress = IsURL(strURL)
    End If

ExitHere:
    Exit Function

Err:
    'If error occured, assume no valid
    IsEmailAddress = False
    GoTo ExitHere
End Function


Function IsURL(strURL As String) As Boolean

    '********************************************************************************************************
    'Adapted by Azli Hassan (http://azlihassan.com/apps)
    'Original code from
    '     https://www.mrexcel.com/forum/excel-questions/567315-check-if-url-exists-so-then-return-true.html
    'Function:  Determine if an URL address is valid
    'Arguments:
    '   strURL (String):  URL/domain to check
    '********************************************************************************************************

    Dim Request As Object
    Dim ff As Integer
    Dim rc As Variant

    On Error GoTo EndNow

    IsURL = False

    Set Request = CreateObject("WinHttp.WinHttpRequest.5.1")

    'Add http if not in strURL string
    If Left(strURL, 4) <> "http" Then
        strURL = "http://" & strURL
    End If

    With Request
      .Open "GET", strURL, False
      .Send
      rc = .StatusText
    End With

    Set Request = Nothing

    If rc = "OK" Then IsURL = True

EndNow:
    Exit Function

End Function

Links