如何用web查询把这个网站的行情数据导入excel

florian5337

http://www.baring.cn/quo/showmarket.html?m=cb，非常喜欢这个数据源，但是貌似这个真是链接不在这个网站上，导致web查询只有标题行，请问如何能导入excel，然后再另一个sheet里面自动写库，这样就可以在excel里看完整行情了。还请各位大大打个样，做成后必回报home，造福home上的金融从业人员。

xmyjk

需要安装WINSOCK，解压缩MSWINSCK.OCX，放置system32里面，然后注册。然后再VBE界面里面，引用里面，浏览，找到MSWINSCK.OCX，然后引用。

这是个服务器推送消息的例子，即HTTP长连接的例子。这类网站比较难得。更新的数据不需再次发包，仅需和服务器保持连接即可。

1. Option Explicit
   
2. Dim WithEvents Winsock1 As Winsock
   
3. Dim m&, flag As Boolean, getpage As String
   
4. 
   
5. Sub test()    '打开连接
   
6.     Set Winsock1 = New Winsock
   
7.     [a1].CurrentRegion.Offset(1).ClearContents
   
8.     m = 1: flag = False
   
9.     Winsock1.RemoteHost = "www.baring.cn"    '服务器
   
10.     Winsock1.RemotePort = 80    'WEB服务器端口
    
11.     Winsock1.Connect
    
12. End Sub
    
13. 
    
14. Sub closeconnect()    '关闭连接
    
15.     Winsock1.Close
    
16. End Sub
    
17. 
    
18. Private Sub Winsock1_Connect()
    
19.     Dim strCommand As String
    
20. 
    
21.     strCommand = "GET /quo/bin/quotation.dll?fields=Price,LastSettle,Open,High,Low,Close,&symbols=CBCRC0,CBCRCH,CBCRCJ,CBCRCK,CBCRCN,CBCRCU,CBCRCZ,CBRRC0,CBRRCF,CBRRCH,CBRRCK,CBRRCN,CBRRCU,CBRRCX,CBSBC0,CBSBCF,CBSBCH,CBSBCK,CBSBCN,CBSBCQ,CBSBCU,CBSBCX,CBSMC0,CBSMCF,CBSMCH,CBSMCK,CBSMCN,CBSMCQ,CBSMCU,CBSMCV,CBSMCZ,CBSOC0,CBSOCF,CBSOCH,CBSOCK,CBSOCN,CBSOCQ,CBSOCU,CBSOCV,CBSOCZ,CBWHC0,CBWHCH,CBWHCK,CBWHCN,CBWHCU,CBWHCZ, HTTP/1.1" + vbCrLf
    
22.     strCommand = strCommand + "Host: www.baring.cn" + vbCrLf
    
23.     strCommand = strCommand + "User-Agent: Mozilla/5.0 (Windows NT 5.1; rv:12.0) Gecko/20100101 Firefox/12.0" + vbCrLf
    
24.     strCommand = strCommand + "Referer: http://www.baring.cn/quo/showmarket.html?m=cb" + vbCrLf
    
25.     strCommand = strCommand + vbCrLf
    
26.     Winsock1.SendData strCommand
    
27. End Sub
    
28. 
    
29. Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long)
    
30.     Dim bin() As Byte
    
31.     Dim str As String, arr(), tmp, i&, j&
    
32.     Winsock1.GetData bin, vbArray + vbByte
    
33.     getpage = getpage & byteToUf(bin)
    
34.     Erase bin
    
35.     If InStr(getpage, "CBSBCF") > 0 And InStr(getpage, "CBRRCU") > 0 Then flag = True
    
36.     If InStr(getpage, "CBSBCF") > 0 And InStr(getpage, "CBRRCU") = 0 Then Exit Sub
    
37.     If flag = False Then getpage = "": Exit Sub
    
38.     'Debug.Print getpage
    
39.     If m = 1 Then
    
40.         str = Filter(Split(getpage, vbLf), "CBCRCH")(0)
    
41.         tmp = Split(Replace(Replace(Replace(Replace(str, "],]", ""), "[", ""), """", ""), "]", ""), ",")
    
42.         ReDim arr(UBound(tmp) \ 9, 8)
    
43.         For i = 0 To UBound(tmp)
    
44.             If i Mod 9 > 2 Then arr(i \ 9, i Mod 9) = tmp(i) / 100 Else arr(i \ 9, i Mod 9) = tmp(i)
    
45.         Next
    
46.         [a2].Resize(UBound(arr) + 1, UBound(arr, 2) + 1) = arr
    
47.         Range([J2], Cells(UBound(arr) + 2, 10)) = "=D2-I2"
    
48.         Range([k2], Cells(UBound(arr) + 2, 11)) = "=J2/I2"
    
49.         Range([d2], Cells(UBound(arr) + 2, 4)).Interior.ColorIndex = 0
    
50.         Erase arr, tmp
    
51.         str = ""
    
52.     Else
    
53.         Dim mc, mcs
    
54.         With CreateObject("vbscript.regexp")
    
55.             .Global = True
    
56.             .Pattern = "\d+,(\d|,|-)+"
    
57.             Set mcs = .Execute(getpage)
    
58.             If mcs.Count > 0 Then
    
59.                 For Each mc In mcs
    
60.                     tmp = Split(mc.Value, ",")
    
61.                     arr = Range(Cells(tmp(0) + 2, 4), Cells(tmp(0) + 2, 9)).Value
    
62.                     arr(1, 2) = arr(1, 1)
    
63.                     For j = 1 To UBound(tmp)
    
64.                         If Len(tmp(j)) = 0 Then tmp(j) = 0
    
65.                         If j <> 2 Then arr(1, j) = arr(1, j) + tmp(j) / 100
    
66.                     Next
    
67.                     If tmp(1) > 0 Then Cells(tmp(0) + 2, 4).Interior.ColorIndex = 3
    
68.                     If tmp(1) < 0 Then Cells(tmp(0) + 2, 4).Interior.ColorIndex = 4
    
69.                     Cells(tmp(0) + 2, 4).Resize(1, 6) = arr
    
70.                     Erase tmp, arr
    
71.                 Next
    
72.             End If
    
73.         End With
    
74.     End If
    
75.     m = m + 1
    
76.     getpage = ""
    
77. End Sub
    
78. 
    
79. Private Function byteToUf(byuf8) As String    'gbk的二进制数组转UTF
    
80.     On Error GoTo MyErr
    
81.     Dim lngStrLen As Long     '需转换的字符串长度
    
82.     Dim byUf(1) As Byte    '字符串暂存1
    
83.     Dim strDef As String    '字符串暂存2
    
84.     Dim i As Long    '哨兵计数
    
85.     Dim strUf As String    '存放结果字符串
    
86. 
    
87.     lngStrLen = UBound(byuf8)         '获得字符串长度
    
88.     i = 0
    
89.     Do While i < lngStrLen
    
90.         If byuf8(i) < 128 Then                 '非中文..不作处理。
    
91.             strUf = strUf & Chr(byuf8(i))
    
92.             i = i + 1
    
93.         Else                                 '是中文
    
94.             byUf(1) = ((byuf8(i) And 15) * 16 + (byuf8(i + 1) And 60) / 4)
    
95.             byUf(0) = (byuf8(i + 1) And 3) * 64 + (byuf8(i + 2) And 63)
    
96.             strDef = byUf
    
97.             strUf = strUf & strDef
    
98.             i = i + 3
    
99.         End If
    
100.     Loop
     
101. MyErr:
     
102.     byteToUf = strUf
     
103. End Function
     

复制代码

liucqa

xmyjk 发表于 2012-5-14 21:59
需要安装WINSOCK，解压缩MSWINSCK.OCX，放置system32里面，然后注册。然后再VBE界面里面，引用里面，浏览， ...

留个记号，崇拜中...



捕获不到数据是什么原因，软件协议问题吗？还是这种长连接只能使用Winsock协议来获取数据？

liucqa

找了点资料，大致明白什么是服务器推送了

对于服务器推送，使用一个“multipart/mixed”类型的变种--multipart/x-mixed-replace。这里，“x-”表示属于实验类型。“replace”表示每一个新数据块都会代替前一个数据块。也就是说，新数据不是附加到旧数据之后，而是替代它。

下面是实际使用的“multipart/x-mixed-replace”类型：
Content-type:multipart/x-mixed-replace;boundary=ThisRandomString
--ThisRandomString
Content-type:text/plain
第一个对象的数据
--ThisRandomString
Content-type:text/plain
第二个（最后一个）对象的数据。
--ThisRandomString--
使用这一技术的关键是，服务器并不是推送整个“multipart/x-mixed-replace”报文，而是每次发送后数据块。
HTTP连接始终保持，因而服务器可以按自己需要的速度和频率推送新数据，两个数据块之间浏览器仅需在当前窗口等候，用户甚至可以到其他窗口做别的事情，当服务器需要发送新数据时，它只是源（ABC输入法没那个字*&^$#）传输管道发送数据块，客户端相应的窗口进行自我更新。

在服务器推送技术中，“multipart/x-mixed-replace”类型的报文由唯一的边界线组成，这些边界线分割每个数据块。每个数据块都有自己的头标，因而能够指定对象相关的内容类型和其他信息。由于“multipart/x-mixed-replace”的特性是每一新数据块取代前一数据对象，因而浏览器中总是显示最新的数据对象。
“multipart/x-mixed-replace”报文没有结尾。也就是说，服务器可以永远保持连接，并发送所需的数据。如果用户不再在浏览器窗口中显示数据流，或者浏览器到服务器间的连接中间（例如用户按“STOP”按钮），服务器的推送才会中断。这是人们使用服务器推送的典型方式。

当浏览器发现“Content-type”头标或到达头标结束处时，浏览器窗口中的前一个文档被清除，并开始显示下一个文档。发现下一个报文边界时，就认为当前数据块（文档）已经结束。
总之，服务器推送的数据由一组头标（通常包括“Content-type”）、数据本身和分割符（报文边界）三部分组成。浏览器看到分割符时，它保持状态不变，直到下一个数据块到达。

xmyjk

liucqa 发表于 2012-5-15 00:49
留个记号，崇拜中...

FIDDLER2，HTTPFOX等，是必须要下载完毕后，才可以捕获的，长连接，连接一直保持，其就误以为数据并未下载完毕，导致无法取数。其实数据一直再收包而已。

这类网站要用WSExplorer。http://www.cr173.com/soft/17693.html

蓝天630902

xmyjk 发表于 2012-5-14 21:59
需要安装WINSOCK，解压缩MSWINSCK.OCX，放置system32里面，然后注册。然后再VBE界面里面，引用里面，浏览， ...

基本上没看懂。

蓝天630902

Sub 霸灵财经网()
    On Error Resume Next
    With CreateObject("internetexplorer.application")
        .Navigate "http://www.baring.cn/quo/index.html"
        While .ReadyState <> 4 Or .Busy
            DoEvents
        Wend
        Set r = .Document.All.tags("table")(1).Rows
        For i = 0 To r.Length - 1
            For j = 0 To r(i).Cells.Length - 1
                Cells(i + 1, j + 1) = r(i).Cells(j).innerText
            Next j
        Next i
    .Quit
    End With
    Cells.Font.Size = 9
    Cells.Columns.AutoFit
    Set r = Nothing
End Sub

蓝天630902

霸灵财经网

xmyjk

蓝天630902 发表于 2012-5-16 19:23
霸灵财经网

呵呵，你这个点钟，数据是静态的。所以看不出效果。

你可以等一个有更新数据流的时间，例如晚上11点多，或者是早上，你就知道网页的页面效果了。

网页的数据是动态更新的，甚至，一秒钟都会更新一次，我模拟的就是网页的效果。

且数据更新，并不是靠刷新页面，而是和页面的加载方式一样，仅仅保持和服务器的链接没断开，继续收取后续的数据，而不是重新发包或者刷新页面。

xmyjk

蓝天630902 发表于 2012-5-16 19:23
霸灵财经网

如图，一次发包，下载三页数据，且不断开和服务器的连接，并模拟网页动态更新的效果，实时更新数据，并不重新刷新页面或者重新发包。

我红和绿模拟的是网页的那个瞬间数据涨跌的小箭头，而不是涨跌噢。呵呵。