1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172
|
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 |
Partager