Tester la synthaxe d'une adresse email ainsi que l'existance du nom de domain

[superviny]

Même sujet: http://www.developpez.net/forums/sho...d.php?t=251794

 
Private Const NORMAL_PRIORITY_CLASS = &H20&
Private Const STARTF_USESTDHANDLES = &H100&
Private Const STARTF_USESHOWWINDOW = &H1
Private Const SW_HIDE = 0
      
Private Type SECURITY_ATTRIBUTES
    nLength                 As Long
    lpSecurityDescriptor    As Long
    bInheritHandle          As Long
End Type
 
Private Type STARTUPINFO
    cb                  As Long
    lpReserved          As Long
    lpDesktop           As Long
    lpTitle             As Long
    dwX                 As Long
    dwY                 As Long
    dwXSize             As Long
    dwYSize             As Long
    dwXCountChars       As Long
    dwYCountChars       As Long
    dwFillAttribute     As Long
    dwFlags             As Long
    wShowWindow         As Integer
    cbReserved2         As Integer
    lpReserved2         As Long
    hStdInput           As Long
    hStdOutput          As Long
    hStdError           As Long
End Type
      
Private Type PROCESS_INFORMATION
    hProcess            As Long
    hThread             As Long
    dwProcessId         As Long
    dwThreadID          As Long
End Type
 
Private Declare Function ReadFile Lib "kernel32" (ByVal hFile As Long, ByVal lpBuffer As String, ByVal nNumberOfBytesToRead As Long, lpNumberOfBytesRead As Long, ByVal lpOverlapped As Any) As Long
Private Declare Function CreatePipe Lib "kernel32" (phReadPipe As Long, phWritePipe As Long, lpPipeAttributes As Any, ByVal nSize As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function CreateProcessA Lib "kernel32" (ByVal lpApplicationName As Long, ByVal lpCommandLine As String, lpProcessAttributes As Any, lpThreadAttributes As Any, ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, ByVal lpEnvironment As Long, ByVal lpCurrentDirectory As Long, lpStartupInfo As Any, lpProcessInformation As Any) As Long
 
Public Function ShellEx(ByVal PathName As String, Optional ByVal WinStyle As VbAppWinStyle = vbHide) As String
Dim proc            As PROCESS_INFORMATION
Dim sa              As SECURITY_ATTRIBUTES
Dim start           As STARTUPINFO
Dim sBuffer         As String * 256
Dim hReadPipe       As Long
Dim hWritePipe      As Long
Dim ret             As Long
Dim lngBytesRead    As Long
    
    sa.nLength = Len(sa)
    sa.bInheritHandle = True
    ret = CreatePipe(hReadPipe, hWritePipe, sa, 0)
    If (ret = 0) Then
        ShellEx = "##ERROR##"
        Exit Function
    End If
    
    start.cb = Len(start)
    start.wShowWindow = WinStyle
    start.hStdError = hWritePipe
    start.hStdOutput = hWritePipe
    start.dwFlags = STARTF_USESTDHANDLES Or STARTF_USESHOWWINDOW
    ret = CreateProcessA(0, PathName, sa, sa, True, NORMAL_PRIORITY_CLASS, 0&, 0&, start, proc)
    If (ret = 0) Then
        ShellEx = "##ERROR##"
        Exit Function
    End If
    CloseHandle hWritePipe
    
    Do
        ret = ReadFile(hReadPipe, sBuffer, Len(sBuffer), lngBytesRead, 0&)
        ShellEx = ShellEx & Left$(sBuffer, lngBytesRead)
    Loop While ret
    
    CloseHandle proc.hProcess
    CloseHandle proc.hThread
    CloseHandle hReadPipe
End Function
 
Public Function isEmailValid(emailAddress) As Integer
'RENVOIT -1 si email valide
'        0 si domaine inconnu
'        1 synthaxe incorrecte
'        2 si erreur du processus
 
Const carAccepted As String = "abcdefghijklmnopqrstuvwxyz1234567890éè.@-_"
Dim domainName As String
Dim resultDns As String
Dim retry As Byte
Dim dotInDomainName As Byte
Dim arobaseInDomainName As Byte
Dim lenEmailAddress As Byte
Dim lenDomainName As Byte
 
    If Trim(Nz(emailAddress, vbNullString)) <> vbNullString Then
        arobaseInDomainName = InStr(1, emailAddress, "@")
        If arobaseInDomainName <= 1 Then
            isEmailValid = 1
        Else
            If InStr(1, emailAddress, "..") > 0 Or _
               InStr(1, emailAddress, "@@") > 0 _
            Then
                isEmailValid = 1
                Exit Function
            End If
            
            lenEmailAddress = Len(emailAddress)
            
            If arobaseInDomainName = lenEmailAddress Then
                isEmailValid = 1
                Exit Function
            End If
        
            domainName = Mid(emailAddress, arobaseInDomainName + 1)
            
            dotInDomainName = InStrRev(domainName, ".")
            
            lenDomainName = Len(domainName)
            
            If dotInDomainName > 1 And _
               (dotInDomainName = (lenDomainName - 2) Or dotInDomainName = (lenDomainName - 3) Or dotInDomainName = (lenDomainName - 4)) _
            Then
                For i = 1 To lenEmailAddress
                    If InStr(1, carAccepted, Mid(emailAddress, i, 1)) = 0 Then
                        isEmailValid = 1
                        Exit Function
                    End If
                Next
                
                Select Case domainName
                    Case "skynet.be", "hotmail.com", "telenet.be", _
                         "pandora.be", "scarlet.be", "belgacom.net", _
                         "gmail.com", "yahoo.com", "yahoo.fr", _
                         "swing.be", "tiscali.be", "msn.com", _
                         "versateladsl.be", "advalvas.be", "planetinternet.be", _
                         "brutele.be", "tele2allin.be", "chello.be", _
                         "wanadoo.fr", "tele2.be", "euphonynet.be":
                     
                            isEmailValid = -1
                        
                    Case Else:
                        retry = 0
                        Do
                            retry = retry + 1
                            resultDns = ShellEx("nslookup -type=MX -retry=3 -timeout=5 " & domainName)
                        Loop While resultDns = "##ERROR##" And retry <= 3
        
                        If resultDns = "##ERROR##" Then
                            isEmailValid = 2
                        Else
                            If InStr(1, Nz(resultDns, vbNullString), "MX preference") = 0 Then
                                isEmailValid = 0
                            Else
                                isEmailValid = -1
                            End If
                        End If
                End Select
            Else
                isEmailValid = 1
            End If
        End If
    Else
        isEmailValid = 1
    End If
 
End Function