• <button id="fy02r"></button>
    <em id="fy02r"></em>

  •   虛擬主機域名注冊-常見問題虛擬主機問題 → 虛擬主機問題


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


    %>

    <% '程序功能,自動到信產部網站核對一個域名的備案情況,如果備案成功,返回備案編號。 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 %>


    來源:
    閱讀:4689
    日期:2006/12/12

    【 雙擊滾屏 】 【 推薦朋友 】 【 收藏 】 【 打印 】 【 關閉 】 【 字體: 】 
    上一篇:用PHP在線發送郵件的例子!
    下一篇:異地匯款手續費費率
      >> 相關文章
     
    天天操天天干