用asp检查一个域名的备案状态的例子！ - 行业新闻 - 新闻中心 - 深圳做网站,深圳做网站的公司,深圳专业做网站,企业网站建设专家,深圳专业做网站的公司


’程序功能，自动到信产部网站核对一个域名的备案情况，如果备案成功，返回备案编号。  
 
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.chinaweber.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/";
 if ICPCheckURL="1" then 
  url=""; & Gtype & "&textfield=" & textvalue
 elseif ICPCheckURL="2" then
  url="; & 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 

%>
 
<% 
’程序功能，自动到信产部网站核对一个域名的备案情况，如果备案成功，返回备案编号。 

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.chinaweber.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