Here you go:
Dim V_ValiderEmail, V_Snabler, V_UgyldigeDomaener, V_Domaene, V_GyldigeEndelser, V_GyldigEndelse, V_Endelse, V_Ekskluder, V_i, V_Status
Function Valider(V_ValiderEmail)
Valider = True
V_ValiderEmail = LCase(V_ValiderEmail)
' (1) Check laengde '-----------------------------------------------------------------------
If Len(V_ValiderEmail) < 5 Then
Valider = False
V_Status = "E-mail adressen er for kort."
Exit Function
End If
' (2) Skal indeholde @ '--------------------------------------------------------------------
If InStr(V_ValiderEmail,"@") = 0 Then
Valider = False
V_Status = "Der mangler et ""@"" i e-mail adressen."
Exit Function
End If
' (3) Undgaa "@." og ".@" '-----------------------------------------------------------------
If ((InStr(V_ValiderEmail,"@.") <> 0) OR (InStr(V_ValiderEmail,".@") <> 0)) Then
Valider = False
V_Status = "Der må ikke være et punktum lige op af et ""@"" i e-mail adressen."
Exit Function
End If
' (4) Check om der er noget foran @ '-------------------------------------------------------
If Len(Left(V_ValiderEmail,InStr(V_ValiderEmail,"@") - 1)) = 0 Then
Valider = False
V_Status = "Der mangler noget foran ""@"" i e-mail adressen."
Exit Function
End If
' (5) Minimum 1 "." '-----------------------------------------------------------------------
If InStr(V_ValiderEmail,".") = 0 Then
Valider = False
V_Status = "En e-mail adresse indeholder mindst eet punktum."
Exit Function
End If
' (6) Max 3 tegn efter sidste "." '---------------------------------------------------------
If (Len(V_ValiderEmail) - InStrRev(V_ValiderEmail,".") > 3) Then
Valider = False
V_Status = "Der er for mange tegn efter sidste punktum i e-mail adressen."
Exit Function
End If
' (7) Undgaa ".." '-------------------------------------------------------------------------
If InStr(V_ValiderEmail,"..") <> 0 Then
Valider = False
V_Status = "Der mŒ ikke være to punktummer lige op af hinanden i e-mail adressen."
Exit Function
End If
' (8) Min 2 tegn efter sidste "." '---------------------------------------------------------
If (Len(V_ValiderEmail) - InStrRev(V_ValiderEmail,".") < 2) Then
Valider = False
V_Status = "Der skal være mindst to tegn efter sidste punktum i e-mail adressen."
Exit Function
End If
' (9) Ingen "_" efter "@" '-----------------------------------------------------------------
If ((InStr(V_ValiderEmail,"_") <> 0) AND (InStrRev(V_ValiderEmail,"_") > InStrRev(V_ValiderEmail,"@"))) Then
Valider = False
V_Status = "Der må ikke være en underscore (_) efter ""@""."
Exit Function
End If
' (10) Tjek for flere "@" '-----------------------------------------------------------------
V_Snabler = 0
For V_i = 1 TO Len(V_ValiderEmail)
If Mid(V_ValiderEmail,V_i,1) = "@" Then
V_Snabler = V_Snabler + 1
End If
Next
If V_Snabler > 1 Then
Valider = False
V_Status = "E-mail adressen indeholder for mange ""@""."
Exit Function
End If
' (11) Check V_Domaene ud fra array '-------------------------------------------------------
V_UgyldigeDomaener = Array("hotmai.com","yahho.dk","hotmaile.com","mail1stofanet.dk","ofri.dk","post1.dk","post2.dk","post3.dk","post4.dk","post5.dk","post6.dk","post7.dk","post8.dk","fc.skolekom.dk","post9.dk","hommail.com","jupiipost.dk","forom.dk","furom.dk","frorum.dk","mail.forum.dk","mailforum.dk","forum.mail.dk","sol.ak","guld.dk","hormail.com","wanacoo.dk","sol.mail.dk","mail.tel.dk")
V_Domaene = Right(V_ValiderEmail,(Len(V_ValiderEmail) - InStrRev(V_ValiderEmail,"@")))
For V_i = 0 TO UBound(V_UgyldigeDomaener)
If V_Domaene = V_UgyldigeDomaener(V_i) Then
Valider = False
V_Status = "E-mail adressens domæne er ugyldigt."
Exit Function
End If
Next
' (12) Tjek om TLD'en er korrekt '----------------------------------------------------------
V_GyldigEndelse = False
V_GyldigeEndelser = Array("dk","com","edu","gov","int","mil","net","org","af","al","dz","as","ad","ao","ai","aq","ag","ar","am","aw","ac","au","at","az","bs","bh","bd","bb","by","be","bz","bj","bm","bt","bo","ba","bw","bv","br","io","bn","bg","bf","bi","kh","cm","ca","cv","ky","cf","td","cs","cl","cn","cx","cc","co","km","cg","ck","cr","ci","hr","cu","cy","cz","dj","dm","do","tp","ec","eg","sv","gq","er","ee","et","fk","fo","fj","fi","fr","gf","pf","tf","ga","gm","ge","de","gh","gi","gr","gl","gd","gp","gu","gt","gg","gn","gw","gy","ht","hm","va","hn","hk","hu","is","in","id","ir","iq","ie","im","il","it","jm","jp","je","jo","kz","ke","ki","kp","kr","kw","kg","la","lv","lb","ls","lr","ly","li","lt","lu","mo","mk","mg","mw","my","mv","ml","mt","mh","mq","mr","mu","yt","mx","fm","md","mc","mn","ms","ma","mz","mm","na","nr","np","nl","an","nc","nz","ni","ne","ng","nu","nf","mp","no","om","pk","pw","ps","pa","pg","py","pe","ph","pn","pl","pt","pr","qa","re","ro","ru","rw","kn","lc","vc","ws","sm","st","sa","sn","sc","sl","sg","sk","si","sb","so","za","gs","es","lk","sh","pm","sd","sr","sj","sz","se","ch","sy","tw","tj","tz","th","tg","tk","to","tt","tn","tr","tm","tc","tv","ug","ua","ae","gb","uk","us","um","uy","su","uz","vu","ve","vn","vg","vi","wf","eh","ye","yu","cd","zm","zr","zw")
V_Endelse = Right(V_ValiderEmail,(Len(V_ValiderEmail) - InStrRev(V_ValiderEmail,".")))
For V_i = 0 TO UBound(V_GyldigeEndelser)
If V_Endelse = V_GyldigeEndelser(V_i) Then
V_GyldigEndelse = True
Exit For
End If
Next
If NOT V_GyldigEndelse Then
Valider = False
V_Status = "Domæne endelsen (f.eks. "".dk"" el. "".com"") er ikke korrekt."
Exit Function
End If
' (13) Check hver enkelt tegn '-------------------------------------------------------------
For V_i = 1 TO Len(V_ValiderEmail)
If NOT IsNumeric(Mid(V_ValiderEmail,V_i,1)) AND (LCase(Mid(V_ValiderEmail,V_i,1)) < "a" OR LCase(Mid(V_ValiderEmail,V_i,1)) > "z") AND Mid(V_ValiderEmail,V_i,1) <> "_" AND Mid(V_ValiderEmail,V_i,1) <> "." AND Mid(V_ValiderEmail,V_i,1) <> "@" AND Mid(V_ValiderEmail,V_i,1) <> "-" Then
Valider = False
V_Status = "E-mail adressen indeholder et eller flere ugyldige tegn."
Exit Function
End If
Next
' (14) Adresser der skal ekskluderes (grundet SPAM el. lign.) '-----------------------------
V_Ekskluder = Array("rune@medions.dk", "daniel@server02.dk", "anders@and.dk", "test@test.dk", "test@test.com")
For V_i = 0 TO UBound(V_Ekskluder)
If V_ValiderEmail = V_Ekskluder(V_i) Then
Valider = False
V_Status = "Der kan ikke sendes til den valgte adresse da den er ekskluderet pga. misbrug."
Exit Function
End If
Next
End Function
//>Rune
