Sorry, this Website isn't available in english.
können.
Sie können sich die BAS-Datei inkl. eines Demo-Projekts
'Prüft eine EMail-Adresse auf Gültigkeit
Public Function Check_Email_Adress(sEMailAdr As String) _
As Boolean
Dim bGoodAdress As Boolean
Dim sTopLevelDomainsArray() As String
Dim sTopLevelDomains As String
Dim eMailSplices() As String
Dim i As Long
bGoodAdress = False
sEMailAdr = LCase(sEMailAdr)
sTopLevelDomains = "com,net,edu,arpa,org,gov,museum," + _
"biz,info,pro,name,aero,coop,ac,ad,ae,af,ag,ai,al," + _
"am,an,ao,aq,ar,as,at,au,aw,az,ba,bb,bd,be,bf,bg," + _
"bh,bi,bj,bm,bn,bo,br,bs,bt,bv,bw,by,bz,ca,cc,cd," + _
"cf,cg,ch,ci,ck,cl,cm,cn,co,cr,cu,cv,cx,cy,cz,de," + _
"dj,dk,dm,do,dz,ec,ee,eg,eh,er,es,et,fi,fj,fk,fm," + _
"fo,fr,ga,gd,ge,gf,gg,gh,gi,gl,gm,gn,gp,gq,gr,gs," + _
"gt,gu,gw,gy,hk,hm,hn,hr,ht,hu,id,ie,il,im,in,io," + _
"iq,ir,is,it,je,jm,jo,jp,ke,kg,kh,ki,km,kn,kp,kr," + _
"kw,ky,kz,la,lb,lc,li,lk,lr,ls,lt,lu,lv,ly,ma,mc," + _
"md,mg,mh,mk,ml,mm,mn,mo,mp,mq,mr,ms,mt,mu,mv,mw," + _
"mx,my,mz,na,nc,ne,nf,ng,ni,nl,no,np,nr,nu,nz,om," + _
"pa,pe,pf,pg,ph,pk,pl,pm,pn,pr,ps,pt,pw,py,qa,re," + _
"ro,ru,rw,sa,sb,sc,sd,se,sg,sh,si,sj,sk,sl,sm,sn," + _
"so,sr,st,sv,sy,sz,tc,td,tf,tg,th,tj,tk,tm,tn,to," + _
"tp,tr,tt,tv,tw,tz,ua,ug,uk,um,us,uy,uz,va,vc,ve," + _
"vg,vi,vn,vu,wf,ws,ye,yt,yu,za,zm,zr,zw"
sTopLevelDomainsArray = Split(sTopLevelDomains, ",")
'@-Zeichen prüfen
eMailSplices = Split(sEMailAdr, "@")
If UBound(eMailSplices) <> 1 Then
Check_Email_Adress = False
Exit Function
End If
'. prüfen
eMailSplices = Split(eMailSplices(1), ".")
If UBound(eMailSplices) < 1 Then
Check_Email_Adress = False
Exit Function
End If
'TopLevel-Domain prüfen
For i = 0 To UBound(sTopLevelDomainsArray)
If eMailSplices(UBound(eMailSplices)) = _
sTopLevelDomainsArray(i) Then
bGoodAdress = True
Exit For
End If
Next
Check_EMail_Adress = bGoodAdress
End Function
'Prüft eine Web-Adresse auf Gültigkeit
Public Function Check_Web_Adress(sWebAdress As String, _
Optional bCheckForProtocol As Boolean = False) As Boolean
Dim bGoodAdress As Boolean
Dim sTopLevelDomainsArray() As String
Dim sTopLevelDomains As String
Dim sProtocolsArray() As String
Dim sProtocols As String
Dim i As Long
Dim myProtocol As String
Dim Splices() As String
Dim Splices2() As String
Dim Splices3() As String
Dim Splices4() As String
Dim myServer As String
Dim isIPAdress As Boolean
sWebAdress = LCase(sWebAdress)
bGoodAdress = False
sTopLevelDomains = "com,net,edu,arpa,org,gov,museum," + _
"biz,info,pro,name,aero,coop,ac,ad,ae,af,ag,ai,al," + _
"am,an,ao,aq,ar,as,at,au,aw,az,ba,bb,bd,be,bf,bg," + _
"bh,bi,bj,bm,bn,bo,br,bs,bt,bv,bw,by,bz,ca,cc,cd," + _
"cf,cg,ch,ci,ck,cl,cm,cn,co,cr,cu,cv,cx,cy,cz,de," + _
"dj,dk,dm,do,dz,ec,ee,eg,eh,er,es,et,fi,fj,fk,fm," + _
"fo,fr,ga,gd,ge,gf,gg,gh,gi,gl,gm,gn,gp,gq,gr,gs," + _
"gt,gu,gw,gy,hk,hm,hn,hr,ht,hu,id,ie,il,im,in,io," + _
"iq,ir,is,it,je,jm,jo,jp,ke,kg,kh,ki,km,kn,kp,kr," + _
"kw,ky,kz,la,lb,lc,li,lk,lr,ls,lt,lu,lv,ly,ma,mc," + _
"md,mg,mh,mk,ml,mm,mn,mo,mp,mq,mr,ms,mt,mu,mv,mw," + _
"mx,my,mz,na,nc,ne,nf,ng,ni,nl,no,np,nr,nu,nz,om," + _
"pa,pe,pf,pg,ph,pk,pl,pm,pn,pr,ps,pt,pw,py,qa,re," + _
"ro,ru,rw,sa,sb,sc,sd,se,sg,sh,si,sj,sk,sl,sm,sn," + _
"so,sr,st,sv,sy,sz,tc,td,tf,tg,th,tj,tk,tm,tn,to," + _
"tp,tr,tt,tv,tw,tz,ua,ug,uk,um,us,uy,uz,va,vc,ve," + _
"vg,vi,vn,vu,wf,ws,ye,yt,yu,za,zm,zr,zw"
sTopLevelDomainsArray = Split(sTopLevelDomains, ",")
sProtocols = "http,ftp,news,gopher,telnet"
sProtocolsArray = Split(sProtocols, ",")
Splices = Split(sWebAdress, "://")
If UBound(Splices) > 0 Then
myProtocol = Splices(0)
End If
'Protkokoll prüfen
If bCheckForProtocol = True Then
For i = 0 To UBound(sProtocolsArray)
If myProtocol = sProtocolsArray(i) Then
bGoodAdress = True
Exit For
End If
Next
If bGoodAdress = False Then
Check_Web_Adress = False
Exit Function
End If
End If
If UBound(Splices) > 0 Then
myProtocol = myProtocol + " "
End If
sWebAdress = Mid(sWebAdress, Len(myProtocol) + 1, _
Len(sWebAdress))
Splices2 = Split(sWebAdress, "/")
Splices3 = Split(Splices2(0), ":")
myServer = Splices3(0)
Splices4 = Split(myServer, ".")
If UBound(Splices4) = 3 Then
'Prüfen, ob IP-Adresse
isIPAdress = True
For i = 0 To 3
If IsNumeric(Splices4(i)) Then
If Splices4(i) > 255 Then
isIPAdress = False
End If
Else
isIPAdress = False
End If
Next
If isIPAdress = True Then
Check_Web_Adress = True
Exit Function
End If
End If
'TopLevel-Domain prüfen
For i = 0 To UBound(sTopLevelDomainsArray)
If Splices4(UBound(Splices4)) = _
sTopLevelDomainsArray(i) Then
bGoodAdress = True
Exit For
End If
Next
Check_Web_Adress = bGoodAdress
End Function