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 |
Tester la synthaxe d'une adresse email ainsi que l'existance du nom de domain
Répondre avec citation
Partager