<%
'程序功能，自动到信产部网站核对一个域名的备案情况，如果备案成功，返回备案编号。
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 '某个命令完成
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
'程序设计：西部数码（
http://www.west263.com )专业提供虚拟主机、域名注册
Function GetICP(ByType,textvalue)
on error resume next
if ByType="No" then
Gtype=8
else
Gtype=2
end if
'---type=6根据url查询(URL)；type=2,根据域名查询(DO),type=8,根据icp编号来查(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 "该域名已经备案成功！备案编号是："&IcpNO
end if
End If
%>
442956988