call Main()

Sub Main()
        Dim url, txt, arr, i
        url = "http://data.eastmoney.com/soft/zlsj/jgcg.aspx?typename=Intrust&year=2014&month=12"
        txt = getText(url)
        arr = getOrgID(txt)
        For i = 0 to UBound(arr, 2)
                url = "http://data.eastmoney.com" & arr(0, i)
                arr(0, i) = getTDNum(getText(url)) & " " & url
                WScript.Sleep 1000
        Next
        call SaveToFile(arr)
End Sub

MsgBox "OK"

Function getText(ByVal url)
        Dim http
        Set http = CreateObject ("Microsoft.XMLHTTP")
        http.Open "GET", url, false
        http.Send
        with CreateObject("ADODB.Stream")
                .Mode = 3
                .Type = 1
                .Open
                .Write http.responseBody
                .Position = 0
                .Type = 2
                .Charset = "GB2312"
                getText = .ReadText()
        End with
End Function

Function getOrgID(ByVal txt)
        Dim ar, re, e, i
        ReDim ar(1, 0)
        txt = Split(txt, "信托机构总览")(1)
        Set re = New RegExp
        re.Pattern = "href=""(.+?)"".+?>(.+?)<"
        re.Global = true
        re.IgnoreCase = true
        Set e = re.Execute(txt)
        For i = 0 to e.Count - 1
                ReDim PreServe ar(1, i)
                ar(0, i) = e(i).Submatches(0)
                ar(1, i) = e(i).Submatches(1)
        Next
        getOrgID = ar
End Function

Function getTDNum(s)
        Dim re, m, n
        Set re = New RegExp
        re.Pattern = "tdnumber col.+?tdnumber.+?([\d\.]+)"
        re.Global = true
        re.IgnoreCase = true
        If Not re.Test(s) Then getTDNum = "-" : Exit Function
        For Each m in re.Execute(s)
                n = n + 0 + m.SubMatches(0)
        Next
        getTDNum = n
End Function

Sub SaveToFile(ByVal arr)
        Dim p, oExcel, i, lnk
        p = Left(WScript.ScriptFullName,InStrRev(WScript.ScriptFullName,"\"))
        Set oExcel = CreateObject("Excel.Application")
        oExcel.Visible = false
        oExcel.WorkBooks.Add
        oExcel.WorkSheets(1).Activate
        For i = 0 to UBound(arr, 2)
                lnk = Split(arr(0, i), " ")(1)
                oExcel.Cells(i+2, 1) = arr(1, i)
                oExcel.Cells(i+2, 2) = Split(arr(0, i), " ")(0)
                oExcel.WorkSheets(1).HyperLinks.Add oExcel.Cells(i+2,1), lnk
        Next
        oExcel.Cells(1, 1) = "信托机构名称"
        oExcel.Cells(1, 2) = "持股市值"
        oExcel.ActiveWorkBook.SaveAs p & "a.xlsx"
        oExcel.WorkBooks.Close
        oExcel.Quit
End Sub
复制代码