網站友情連結檢查程式的基礎實現代碼

來源:互聯網
上載者:User

查詢網頁的友情連結數量和具體的連結網址,本例沒有排除二級(及以上)的網域名稱,沒有判斷重複的外鏈,需要的可以自己加強一下.

以下是ASP原始碼:
<form action="">URL:<input name="url_" /><input type="submit" name="submit" value="查詢" /></form>
<%
    If Request("url_")<>"" Then
        SenFe_GetUrl Request("url_")
    End If
    Sub SenFe_GetUrl(sUrl)
        Dim sContent, sDomian, oTempReg, I, oMatches, cMatch, sUrl_
        sUrl = LCase(sUrl)
        If Left(sUrl, 7)="http://" Then
            sDomian = Mid(sUrl, 8)
        Else
            sDomian = sUrl
            sUrl = "http://" & Url
        End If
        If InStr(sDomian, "/") Then sDomian = Split(sDomian, "/")(0)
        sContent = SenFe_GetData(sUrl)
        Set oTempReg = New RegExp
        With oTempReg
            .IgnoreCase = True
            .Global = True
            .Pattern = "(http:(\/\/|\\\\)(([\w\/\\\+\-~`@:%])+\.)+([\w\/\\\.\=\?\+\-~`@\’:!%#]|(&)|&)+)"
                Set oMatches = .Execute(sContent)
                For Each cMatch In oMatches
                sUrl_ = LCase(cMatch.Value)
                If InStr(sUrl_, sDomian)=0 Then
                    Response.Write(sUrl_ & "<br />" & VbCrLf)
                End If
                Next
        End With
        Set oTempReg = Nothing
    End Sub
    Function SenFe_GetData(sUrl)
        Dim oXmlHttp : Set oXmlHttp = Server.CreateObject("Msxml2.ServerXMLHTTP")
        With oXmlHttp
            .Open "GET",sUrl,False
            .SetRequestHeader "Referer",sUrl
            .Send
            SenFe_GetData = SenFe_BytesToBstr(.ResponseBody,"GB2312")
        End With
        Set oXmlHttp = Nothing
    End Function
    Function SenFe_BytesToBstr(sBody, sCset)
        Dim oAdos : Set oAdos = Server.CreateObject("Adodb.Stream")
        With oAdos
            .Type = 1
            .Mode = 3
            .Open
            .Write sBody
            .Position = 0
            .Type = 2
            .Charset = sCset
            SenFe_BytesToBstr = .ReadText
            .Close
        End With
        Set oAdos = Nothing
    End Function
%>



相關文章

Beyond APAC's No.1 Cloud

19.6% IaaS Market Share in Asia Pacific - Gartner IT Service report, 2018

Learn more >

Apsara Conference 2019

The Rise of Data Intelligence, September 25th - 27th, Hangzhou, China

Learn more >

Alibaba Cloud Free Trial

Learn and experience the power of Alibaba Cloud with a free trial worth $300-1200 USD

Learn more >

聯繫我們

該頁面正文內容均來源於網絡整理,並不代表阿里雲官方的觀點,該頁面所提到的產品和服務也與阿里云無關,如果該頁面內容對您造成了困擾,歡迎寫郵件給我們,收到郵件我們將在5個工作日內處理。

如果您發現本社區中有涉嫌抄襲的內容,歡迎發送郵件至: info-contact@alibabacloud.com 進行舉報並提供相關證據,工作人員會在 5 個工作天內聯絡您,一經查實,本站將立刻刪除涉嫌侵權內容。