'/*=========================================================================   
' * Intro       研究網(wǎng)頁編碼很長時(shí)間了，因?yàn)樽罱O(shè)計(jì)一個(gè)友情鏈接檢測(cè)的VBS腳本，而與你鏈接的人的頁面很可能是各種編碼，以前采取的方法是：如果用GB2312查不到再用UTF-8查，再找不到證明對(duì)方?jīng)]有給你做鏈接雖然不是100%正確，但也差不多了，這兩種編碼用的人比較多，偶然間在收藏夾里的一個(gè)地址看到的一個(gè)思路，終于可以在采集文章時(shí)自動(dòng)判斷網(wǎng)頁的編碼了。因?yàn)檠芯窟^程中這個(gè)問題困擾很久，雖然現(xiàn)在覺得簡(jiǎn)單了，想必很多人還在找，所以把這三個(gè)函數(shù)貼出來。   
' * FileName    GetWebCodePage.vbs   
' * Author      yongfa365   
' * Version     v2.0   
' * WEB         http://www.yongfa365.com   
' * Email       yongfa365[at]qq.com   
' * FirstWrite  http://www.yongfa365.com/Item/GetWebCodePage.vbs.html   
' * MadeTime    2008-01-29 20:55:46   
' * LastModify  2008-01-30 20:55:46   
' *==========================================================================*/   

  
Call getHTTPPage("http://www.baidu.com/")   
Call getHTTPPage("http://www.google.com/")   
Call getHTTPPage("http://www.yongfa365.com/")   
Call getHTTPPage("http://www.cbdcn.com/")   
Call getHTTPPage("http://www.csdn.net/")   

  
'得到匹配的內(nèi)容，返回?cái)?shù)組   
'getContents(表達(dá)式，字符串，是否返回引用值)   
'msgbox getContents("a(.+?)b", "a23234b ab a67896896b sadfasdfb" ,True)(0)   

Function getContents(patrn, strng , yinyong)   
'by www.yongfa365.com 轉(zhuǎn)載請(qǐng)保留鏈接，以便最終用戶及時(shí)得到最新更新信息   
    On Error Resume Next  
    Set re = New RegExp  
    re.Pattern = patrn   
    re.IgnoreCase = True  
    re.Global = True  
    Set Matches = re.Execute(strng)   
    If yinyong Then  
        For i = 0 To Matches.Count -1   
            If Matches(i).Value<>"" Then RetStr = RetStr & Matches(i).SubMatches(0) & "柳永法"  
        Next  
    Else  
        For Each oMatch in Matches   
            If oMatch.Value<>"" Then RetStr = RetStr & oMatch.Value & "柳永法"  
        Next  
    End If  
    getContents = Split(RetStr, "柳永法")   
End Function  

Function getHTTPPage(url)   
    On Error Resume Next  
    Set xmlhttp = CreateObject("MSXML2.XMLHTTP")   
    xmlhttp.Open "Get", url, False  
    xmlhttp.Send   
    If xmlhttp.Status<>200 Then Exit Function  
    GetBody = xmlhttp.ResponseBody   
    '柳永法(www.yongfa365.com)在此的思路是,先根據(jù)返回的字符串找，找文件頭，如果還沒有的話就用GB2312,一般都能直接匹配出編碼。   
    '在返回的字符串里看，雖然中文是亂碼，但不影響我們?nèi)∑渚幋a，   
    GetCodePage = getContents("charset=[""']*([^"",']+)", xmlhttp.ResponseText , True)(0)   
    '在頭文件里看編碼   
     If Len(GetCodePage)<3 Then GetCodePage = getContents("charset=[""']*([^"",']+)", xmlhttp.getResponseHeader("Content-Type") , True)(0)   
    If Len(GetCodePage)<3 Then GetCodePage = "gb2312"  
    Set xmlhttp = Nothing  
    '下邊這句在正式使用時(shí)要屏蔽掉   
    WScript.Echo url & "-->" & GetCodePage   
    getHTTPPage = BytesToBstr(GetBody, GetCodePage)   
End Function  

  
Function BytesToBstr(Body, Cset)   
    On Error Resume Next  
    Dim objstream   
    Set objstream = CreateObject("adodb.stream")   
    objstream.Type = 1   
    objstream.Mode = 3   
    objstream.Open  
    objstream.Write Body   
    objstream.Position = 0   
    objstream.Type = 2   
    objstream.Charset = Cset   
    BytesToBstr = objstream.ReadText   
    objstream.Close  
    Set objstream = Nothing  
End Function

最新評(píng)論