'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