ICPCheckURL=1
Dim DataSet_ICP()

function GetsRoot(ByVal whichDomain)
 whichDomain=Lcase(whichDomain)
 Exts=".bj.cn,.sh.cn,.tj.cn,.cq.cn,.he.cn,.sx.cn,.nm.cn,.ln.cn,.jl.cn,.hl.cn,.js.cn,.zj.cn,.ah.cn,.fj.cn,.jx.cn,.sd.cn,.ha.cn,.hb.cn,.hn.cn,.gd.cn,.gx.cn,.hi.cn,."
Exts=Exts&"sc.cn,.gz.cn,.yn.cn,.xz.cn,.sn.cn,.gs.cn,.qh.cn,.nx.cn,.xj.cn,.tw.cn,.hk.cn,.mo.cn,"
 Exts= Exts & ".ac.cn,.com.cn,.net.cn,.org.cn,.gov.cn,.edu.cn,.com,.net,.org,.biz,.cn,.info,.tv,.cc,.tw,.name,.ws,.in,.hk,.tw,.us,.au,.ac,.ca"
 AllTop=split(Exts,",")
 if len(whichDomain)>3 then
  for z=0 to Ubound(AllTop)
   extLen=len(AllTop(z))
   if right(whichDomain,extLen)=AllTop(z) then
    prefix=left(whichDomain,len(whichDomain)-extLen)
    dotPos=inStrRev(prefix,".")
    if dotPos>0 then
     whichDomain=mid(prefix,dotPos+1) & AllTop(z)
    end if
    exit for
   end if
  next
 end if
 GetsRoot=whichDomain
end function

function getCmd(strM)
 strM=lcase(strM)
 if inStr(strM," ")>0 then
  getCmd=left(strM,inStr(strM," ")-1)
 else
  getCmd=strM
 end if
end function

Function bstr(vIn)

 Dim strReturn,iii,ThisCharCode,innerCode,Hight8,Low8,NextCharCode
 strReturn = ""
 
 For iii = 1 To LenB(vIn)
  ThisCharCode = AscB(MidB(vIn,iii,1))
  If ThisCharCode < &H80 Then
   strReturn = strReturn & Chr(ThisCharCode)
  Else
   NextCharCode = AscB(MidB(vIn,iii+1,1))
   strReturn = strReturn & Chr(CLng(ThisCharCode) * &H100 + CInt(NextCharCode))
   iii = iii + 1
  End If
 Next
 bstr = strReturn  
End Function

Sub tinyFitler(someMes)
 ReDim Preserve DataSet_ICP(0)
 blDrop=true
 blN=false
 PreChar=""
 PreCmd=""
 blInTd=false
 intTB=0
 intTR=0
 intTD=0
 blInTd=false
 infos=""

 for iii=1 to len(someMes)
  Schar=mid(someMes,iii,1)
  if Schar="<" then
  blDrop=true
  lastCmd=""
  blN=false
  elseif Schar=">" then
  blDrop=false '某個(gè)命令完成
  lastCmd=getCmd(lastCmd)
  if blN then
    if lastCmd="a" then
     if blInTd then infos=infos & ","
    end if
    if lastCmd="td" then
     blInTD=false
     DataSet_ICP(intTR)=DataSet_ICP(intTR) & infos & "`"
     infos=""
    end if
  else
    if lastCmd="table" then
     intTB=intTB+1
      if intTB>1 then
       Exit Sub '不用處理余下的表格
      end if
    end if
    if lastCmd="tr" then
     intTR=intTR+1
     intTD=0
     blInTD=false
     ReDim Preserve DataSet_ICP(intTR)
    end if
 
    if lastCmd="td" then
     blInTD=true
     intTD=intTD+1
    end if
    
  end if

  elseif Schar="/" and PreChar="<" then
  blN=true
  else
   if not blDrop then
    if blInTD then infos=infos & Schar
   else
    lastCmd=lastCmd & Schar
   end if
  end if
  PreChar=Schar
 next

end Sub
'程序設(shè)計(jì)：西部數(shù)碼（http://www.west263.com )專業(yè)提供虛擬主機(jī)、域名注冊(cè)

Function GetICP(ByType,textvalue)
 on error resume next

 if ByType="No" then
  Gtype=8
 else
  Gtype=2
 end if
'---type=6根據(jù)url查詢(URL)；type=2,根據(jù)域名查詢(DO),type=8,根據(jù)icp編號(hào)來查(No)

 if ByType="URL" then
  Gtype=6
 end if

 Referer="http://www.miibeian.gov.cn/Search/WW_ICP_WhetherRecord_Select.jsp";
 if ICPCheckURL="1" then
  url="http://211.94.161.10/Search/WW_ICP_WhetherRecord_Search.jsp?selectid="; & Gtype & "&textfield=" & textvalue
 elseif ICPCheckURL="2" then
  url="http://www.miibeian.gov.cn/Search/WW_ICP_WhetherRecord_Search.jsp?selectid="; & Gtype & "&textfield=" & textvalue
 end if

Set Retrieval = Server.CreateObject("Microsoft.XMLHTTP")
With Retrieval
.Open "Post", url, false
   .setRequestHeader "Referer",Referer
.Send
   GetICP =.ResponseBody
   End With
Set Retrieval = Nothing
 GetICP=bstr(GetICP)
End Function

'如果要檢查，必須先LoadICP
Function LoadICP(BYWHICH,GIVE)
 RetCode=GetICP(BYWHICH,GIVE)
 if isNull(RetCode) then
  LoadICP=false
 else
  Call tinyFitler(RetCode)
  LoadICP=true
 end if
end Function

Function GetNo()
 RRsets=Ubound(DataSet_ICP)
 if RRsets=0 then
  GetNo="ERROR"
 end if
 if RRsets=1 then
  GetNo="NONE"
 end if
 if RRsets>1 then
  GetNo=split(DataSet_ICP(2),"`")(3)
 end if 
end Function

ckbind="要檢查的域名.com"
 If LoadICP("DO",ckbind) Then
   IcpNO=GetNo()
   If IcpNo="NONE" Or IcpNo="ERROR" Then
    if LoadICP("URL",ckbind) then
     IcpNO=GetNo() 
    end if
   End If 'GetsRoot

   If IcpNo="NONE" Or IcpNo="ERROR" Then
    if LoadICP("DO",GetsRoot(ckbind)) then
     IcpNO=GetNo() 
    end if
   End If

   If IcpNo="NONE" Or IcpNo="ERROR" Then
    if LoadICP("URL",GetsRoot(ckbind)) then
     IcpNO=GetNo() 
    end if
   End If
  
   if IcpNo="NONE" or IcpNo="ERROR" then
   respnose.write  "該域名還未備案成功！"
   else
   respnose.write  "該域名已經(jīng)備案成功！備案編號(hào)是："&IcpNO
   end if

 End If

%>