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. name@domain.com '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
Preview:
downloadDownload PNG
downloadDownload JPEG
downloadDownload SVG
Tip: You can change the style, width & colours of the snippet with the inspect tool before clicking Download!
Click to optimize width for Twitter