ASP,VB获取URL顶级域名信息(get base domain)

Response.write(getBaseDomain("http://www.sman.cn/")) 'sman.cn
Response.write(getBaseDomain("http://www.net.cn/")) 'www.net.cn

'取得当前域名，可能包括N级域名
'sman 2009-06-29
Function getDomain(url)
    url = LCase("" & url)
    Dim posTemp
    posTemp = InStr(url, "://") '协议
    If (posTemp) Then url = Mid(url, posTemp + 3)
    posTemp = InStr(url, "/") '域名结束
    If (posTemp) Then url = Mid(url, 1, posTemp - 1)
    getDomain = url
End Function
'取得顶级域名（base domain)
'sman 2009-06-29
Function getBaseDomain(url)
    url = getDomain(url)
    Dim arrTemp, intU
    arrTemp = Split(url, ".")
    intU = UBound(arrTemp)
    
    '顶级域名 或 不是域名
    If intU <= 1 Then
        getBaseDomain = url
        Exit Function
    End If
    'IP
    If intU = 3 Then
        If IsNumeric(arrTemp(0)) And IsNumeric(arrTemp(3)) Then
            getBaseDomain = url
            Exit Function
        End If
    End If
    
    
    Dim G_TLD, C_TLD
    
    G_TLD = ",biz,com,edu,gov,info,int,mil,name,net,org," & _
    "aero,asia,cat,coop,jobs,mobi,museum,pro,tel,travel," & _
    "arpa,root," & _
    "berlin,bzh,cym,gal,geo,kid,kids,lat,mail,nyc,post,sco,web,xxx," & _
    "nato," & _
    "example,invalid,localhost,test," & _
    "bitnet,csnet,ip,local,onion,uucp," & _
    "co," ' note: not technically, but used in things like co.uk
    
    C_TLD = ",ac,ad,ae,af,ag,ai,al,am,an,ao,aq,ar,as,at,au,aw,ax,az," & _
    "ba,bb,bd,be,bf,bg,bh,bi,bj,bm,bn,bo,br,bs,bt,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,er,es,et,eu,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,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,pn,pr,ps,pt,pw,py,qa," & _
    "re,ro,ru,rw,sa,sb,sc,sd,se,sg,sh,si,sk,sl,sm,sn,sr,st," & _
    "sv,sy,sz,tc,td,tf,tg,th,tj,tk,tl,tm,tn,to,tr,tt,tv,tw," & _
    "tz,ua,ug,uk,us,uy,uz,va,vc,ve,vg,vi,vn,vu,wf,ws,ye,yu," & _
    "za,zm,zw," & _
    "eh,kp,me,rs,um,bv,gb,pm,sj,so,yt,su,tp,bu,cs,dd,zr," ' inactive
    
    If InStr(C_TLD, "," & arrTemp(intU) & ",") And InStr(G_TLD, "," & arrTemp(intU - 1) & ",") Then
        getBaseDomain = arrTemp(intU - 2) & "." & arrTemp(intU - 1) & "." & arrTemp(intU)
    Else
        getBaseDomain = arrTemp(intU - 1) & "." & arrTemp(intU)
    End If
End Function