柳永法:北京公交车2008年最新数据库终于获取了

'/*=========================================================================
' * Intro       一直想弄呢,可是不知从何下手,还好,学习了数据获取技术,现在容易了.只提供程序,数据库自己弄,呵呵
' * FileName    yongfa365.机器人.获取北京最新公交路线.vbs
' * Author      yongfa365
' * Version     v1.0
' * WEB         http://www.yongfa365.com
' * Email       yongfa365[at]qq.com
' * FirstWrite  http://www.yongfa365.com/Item/Get.www.bjbus.com.vbs.html
' * CreateTime  2008-01-28 18:13:08
' * LastModify  2008-01-28 18:13:08
' *==========================================================================*/

'On Error Resume Next
dbpath = "bjbus.mdb"
connstr = "provider=microsoft.jet.oledb.4.0;data source=" & dbpath
Set conn = CreateObject("adodb.connection")
conn.Open connstr
WScript.Echo "开始获取数据"
Start_Time = Timer
For bj001 = 26719008 To 26720279
    '得到内容
    body = getHTTPPage("http://lspengine.go2map.com/WebSite/Engine?hidden_MapTool=busex.BusInfo&hidden_Variant=APPID==1411!!FeatureDescType==UID,,!!FeatureDesc==10000"&Right("0000000"&bj001, 8)&"!!ResultOrder==1,10!!IdType==Line&hidden_APPID=1411&hidden_DISABLEQDS=true&rnd=1201446763399926")
    '处理下
    body = getContents("Wmsxml==(.+)!!debugIN==", body , True)(0)
    'CreateFile bj001& ".xml" ,body
    '如果匹配到值就是当前这条线路存在,再处理它.
    If body<>"" Then
        Set Doc = CreateObject("Microsoft.XMLDOM")
        Doc.async = False
        Doc.loadxml(body)
        Set root = Doc.documentElement
        Set BusLine = root.childNodes(0).childNodes(0)
        Set DetailInfo = BusLine.childNodes(0)
        Set Feature = BusLine.childNodes(1)
        
        lines = ""
        For nodei = 1 To Feature.childNodes.Length -1
            Set NowNode = Feature.childNodes(nodei)
            lines = lines & "-->" & NowNode.Attributes.getNamedItem("caption").text
            
            LineName = NowNode.Attributes.getNamedItem("caption").text
            LineOldName = NowNode.Attributes.getNamedItem("oldname").text
            LineDataID = NowNode.Attributes.getNamedItem("dataid").text
            LineID = NowNode.Attributes.getNamedItem("id").text
            Call InToLine(LineName, LineOldName, LineDataID, LineID)
        Next
        
        Set rs = CreateObject("Adodb.Recordset")
        sql = "select * from Lines"
        rs.Open sql, conn, 1, 3
        rs.addnew
        
        rs("LineName") = BusLine.Attributes.getNamedItem("name").text
        rs("LineID") = BusLine.Attributes.getNamedItem("id").text
        
        rs("starttime") = DetailInfo.childNodes(0).Attributes.getNamedItem("value").text
        rs("endtime") = DetailInfo.childNodes(1).Attributes.getNamedItem("value").text
        rs("iscommutationvalid") = DetailInfo.childNodes(2).Attributes.getNamedItem("value").text
        rs("isunitarycarfare") = DetailInfo.childNodes(3).Attributes.getNamedItem("value").text
        rs("carfare") = DetailInfo.childNodes(4).Attributes.getNamedItem("value").text
        rs("linelength") = DetailInfo.childNodes(5).Attributes.getNamedItem("value").text
        rs("filiale") = DetailInfo.childNodes(6).Attributes.getNamedItem("value").text
        rs("Lines") = Mid(Lines, 4, 1000)
        rs.update
        rs.Close
        
    End If
    
Next
WScript.Echo "哈哈哈哈,用了" & (Timer - Start_Time) & "秒,就成我地啦"

Function InToLine(LineName, LineOldName, DataID, LineID)
    Set rs2 = CreateObject("Adodb.Recordset")
    sql2 = "select * from Stations where LineID='"&LineID&"'"
    rs2.Open sql2, conn, 1, 3
    If rs2.EOF Then conn.Execute("insert into Stations (LineName,LineOldName,LineDataID,LineID) values ('" & LineName & "','" & LineOldName & "','" & LineDataID & "','" & LineID & "')")
End Function

'----------------------------------------函数区-----------------------------------------------------

Function CreateFile(FileName, Content)
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set fd = FSO.CreateTextFile(FileName, True)
    fd.WriteLine Content
End Function

'得到匹配的内容，并以数据形式显示
'表达式，字符串，是否返回引用值
'msgbox getContents("a(.+?)b", "a23234b ab a67896896b sadfasdfb" ,True)(0)

Function getContents(patrn, strng , yinyong)
    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
    '在头文件里看编码
    GetCodePage = getContents("charset=[""']*([^""']+)", xmlhttp.getResponseHeader("Content-Type") , True)(0)
    '在返回的字符串里看，虽然中文是乱码，但不影响我们取其编码
    If Len(GetCodePage)<3 Then GetCodePage = getContents("charset=[""']*([^""']+)", xmlhttp.ResponseText , True)(0)
    If Len(GetCodePage)<3 Then GetCodePage = "gb2312"
    Set xmlhttp = Nothing
    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