Note: This is not the complete source code--just the main source file.
You can download the full source (with include files) from our sample code archive by clicking on the diskette icons.
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
Persistable = 0 'NotPersistable
DataBindingBehavior = 0 'vbNone
DataSourceBehavior = 0 'vbNone
MTSTransactionMode = 0 'NotAnMTSObject
END
Attribute VB_Name = "OptValidEmail"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'// OptValidEmail class
'// version 2002-12-05
'//
'// An optimized wrapper class for HexValidEmail
'//
'// The OptValidEmail class is a drop-in-compatible wrapper
'// for the HexValidEmail.Connection class. It can dramatically
'// reduce average validation delays by
'//
'// 1. Avoiding unnecessary DNS lookups
'// 2. Avoiding fruitless SMTP checks
'// 3. Reducing the worst-case timeout for SMTP checks
'//
'// These advantages come at a cost:
'//
'// 1. You must tweak the domain name caches in the
'// Class_Initialize event and update them periodically.
'// 2. The shorter timeout means more SMTP checks will
'// be abandoned before the SMTP server gets a chance to
'// respond.
'//
'// HexGadgets (components) required:
'// - HexValidEmail
'// Info: http://www.HexGadgets.com/
'//
'// History:
'// 2002-12-05 Created, based on older OptValidEmail.inc.asp
'//
'// Copyright 2002 Hexillion Technologies. All rights reserved.
'//
'// THIS CODE AND INFORMATION IS PROVIDED "AS IS" WITHOUT WARRANTY
'// OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING BUT NOT
'// LIMITED TO THE IMPLIED WARRANTIES OF MERCHANTIBILITY AND/OR
'// FITNESS FOR A PARTICULAR PURPOSE.
Option Explicit
Private m_oVE As HexValidEmailLib.Connection
Private m_lError As Long
Private m_aGoodDoms
Private m_aNoSmtpDoms
Private Sub Class_Initialize()
Set m_oVE = New HexValidEmailLib.Connection
m_lError = m_oVE.Error
'// List of domains known to accept email
'// Roughly ordered by popularity
'// DNS check is not necessary for these
m_aGoodDoms = Array( _
"hotmail.com", _
"aol.com", _
"yahoo.com", _
"usa.net", _
"bigfoot.com", _
"earthlink.net", _
"att.net", "attglobal.net", _
"netcom.com", _
"pobox.com", "poboxes.com", _
"mindspring.com", _
"iname.com", "ibm.net", _
"msn.com", "compuserve.com", _
"world.std.com", _
"juno.com", _
"geocities.com", _
"excite.com", _
"altavista.com", _
"erols.com", _
"ibm.com", _
"microsoft.com", "email.com", _
"netscape.net", "netzero.net", _
"writeme.com" _
)
'// List of domains whose SMTP servers won't reject
'// bad usernames. Roughly ordered by popularity.
'// Don't bother with SMTP check for these.
m_aNoSmtpDoms = Array( _
"yahoo.com", _
"bigfoot.com", _
"msn.com", _
"compuserve.com", _
"altavista.com", _
"microsoft.com", _
"netscape.net", _
"netzero.net" _
)
'// Tune down SMTP timeout
'// SMTP validations will time out faster but more often
m_oVE.Timeouts(hexVeTimeoutSmtpTotal).Value = 10000
End Sub
Private Sub Class_Terminate()
Set m_oVE = Nothing
End Sub
Function Validate(EmailAddress As String, Optional Level As HexValidEmailLevel = hexVeLevelDns) As HexValidEmailLevel
Dim nRating As HexValidEmailLevel
'// Do initial syntax check
nRating = m_oVE.Validate(EmailAddress, hexVeLevelSyntax)
If hexVeErrSuccess <> m_oVE.Error Or _
hexVeLevelSyntax = Level Then
'// Exit normally
m_lError = m_oVE.Error
Validate = nRating
ElseIf hexVeLevelDns = Level Then
'// If domain is already known to be good...
If IsGoodDom(m_oVE.Domain) Then
'// Skip check and return success
m_lError = hexVeErrSuccess
Validate = hexVeLevelDns
Else
'// Do the normal check
Validate = m_oVE.Validate(EmailAddress, Level)
m_lError = m_oVE.Error
End If
ElseIf hexVeLevelSmtp = Level Then
'// If SMTP server for this domain won't reject
'// a bad username (local part)...
If IsNoSmtpDom(m_oVE.Domain) Then
'// Skip the SMTP check (and the DNS check--we
'// already know the NoSmtpDoms accept email)
'// Return codes the validation would have returned
m_lError = hexVeErrSuccess
Validate = hexVeLevelSmtp
'// Or, if you don't want to say the Validation
'// passed, you could return the following.
'// OptValidEmail won't be completely drop-in
'// compatible with HexValidEmail if you do this.
'm_lError = hexVeErrCouldNotVerifyRecipient
'Validate = hexVeLevelDns
Else
'// Do the normal check
Validate = m_oVE.Validate(EmailAddress, Level)
m_lError = m_oVE.Error
End If
End If
End Function
Function AddrToString(IpAddress As Long) As String
AddrToString = m_oVE.AddrToString(IpAddress)
End Function
Property Get Domain() As String
Domain = m_oVE.Domain
End Property
Property Get Error() As Long
Error = m_oVE.Error
End Property
Property Get Expires() As Date
Expires = m_oVE.Expires
End Property
Property Get ExtraText() As String
ExtraText = m_oVE.ExtraText
End Property
Property Get FromDomain() As String
FromDomain = m_oVE.FromDomain
End Property
Property Let FromDomain(sDomain As String)
m_oVE.FromDomain = sDomain
End Property
Property Get FromEmail() As String
FromEmail = m_oVE.FromEmail
End Property
Property Let FromEmail(sEmail As String)
m_oVE.FromEmail = sEmail
End Property
Property Get LicensedProcessors() As Long
LicensedProcessors = m_oVE.LicensedProcessors
End Property
Property Get LicensedUser() As String
LicensedUser = m_oVE.LicensedUser
End Property
Property Get LocalPart() As String
LocalPart = m_oVE.LocalPart
End Property
Property Get MxRecs() As HexValidEmailLib.MxRecs
Set MxRecs = m_oVE.MxRecs
End Property
Property Let Options(lOptions As Long)
m_oVE.Options = lOptions
End Property
Property Get Options() As Long
Options = m_oVE.Options
End Property
Property Get SmtpSession() As String
SmtpSession = m_oVE.SmtpSession
End Property
Property Get Timeouts() As HexValidEmailLib.Timeouts
Set Timeouts = m_oVE.Timeouts
End Property
Property Get Version() As String
Version = m_oVE.Version
End Property
Private Function IsGoodDom(sDomain As String) As Boolean
Dim i As Integer, iMax As Integer
i = LBound(m_aGoodDoms)
iMax = UBound(m_aGoodDoms)
IsGoodDom = False
Do While i <= iMax And Not IsGoodDom
If sDomain = m_aGoodDoms(i) Then IsGoodDom = True
i = i + 1
Loop
End Function
Private Function IsNoSmtpDom(sDomain As String) As Boolean
Dim i As Integer, iMax As Integer
i = LBound(m_aNoSmtpDoms)
iMax = UBound(m_aNoSmtpDoms)
IsNoSmtpDom = False
Do While i <= iMax And Not IsNoSmtpDom
If sDomain = m_aNoSmtpDoms(i) Then IsNoSmtpDom = True
i = i + 1
Loop
End Function