|
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件 ★ 免费下载 ★ ★ 使用帮助★
本帖最后由 xmyjk 于 2012-5-15 11:51 编辑
需要安装WINSOCK,解压缩MSWINSCK.OCX,放置system32里面,然后注册。然后再VBE界面里面,引用里面,浏览,找到MSWINSCK.OCX,然后引用。
这是个服务器推送消息的例子,即HTTP长连接的例子。这类网站比较难得。更新的数据不需再次发包,仅需和服务器保持连接即可。
- Option Explicit
- Dim WithEvents Winsock1 As Winsock
- Dim m&, flag As Boolean, getpage As String
- Sub test() '打开连接
- Set Winsock1 = New Winsock
- [a1].CurrentRegion.Offset(1).ClearContents
- m = 1: flag = False
- Winsock1.RemoteHost = "www.baring.cn" '服务器
- Winsock1.RemotePort = 80 'WEB服务器端口
- Winsock1.Connect
- End Sub
- Sub closeconnect() '关闭连接
- Winsock1.Close
- End Sub
- Private Sub Winsock1_Connect()
- Dim strCommand As String
- 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
- strCommand = strCommand + "Host: www.baring.cn" + vbCrLf
- strCommand = strCommand + "User-Agent: Mozilla/5.0 (Windows NT 5.1; rv:12.0) Gecko/20100101 Firefox/12.0" + vbCrLf
- strCommand = strCommand + "Referer: http://www.baring.cn/quo/showmarket.html?m=cb" + vbCrLf
- strCommand = strCommand + vbCrLf
- Winsock1.SendData strCommand
- End Sub
- Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long)
- Dim bin() As Byte
- Dim str As String, arr(), tmp, i&, j&
- Winsock1.GetData bin, vbArray + vbByte
- getpage = getpage & byteToUf(bin)
- Erase bin
- If InStr(getpage, "CBSBCF") > 0 And InStr(getpage, "CBRRCU") > 0 Then flag = True
- If InStr(getpage, "CBSBCF") > 0 And InStr(getpage, "CBRRCU") = 0 Then Exit Sub
- If flag = False Then getpage = "": Exit Sub
- 'Debug.Print getpage
- If m = 1 Then
- str = Filter(Split(getpage, vbLf), "CBCRCH")(0)
- tmp = Split(Replace(Replace(Replace(Replace(str, "],]", ""), "[", ""), """", ""), "]", ""), ",")
- ReDim arr(UBound(tmp) \ 9, 8)
- For i = 0 To UBound(tmp)
- If i Mod 9 > 2 Then arr(i \ 9, i Mod 9) = tmp(i) / 100 Else arr(i \ 9, i Mod 9) = tmp(i)
- Next
- [a2].Resize(UBound(arr) + 1, UBound(arr, 2) + 1) = arr
- Range([J2], Cells(UBound(arr) + 2, 10)) = "=D2-I2"
- Range([k2], Cells(UBound(arr) + 2, 11)) = "=J2/I2"
- Range([d2], Cells(UBound(arr) + 2, 4)).Interior.ColorIndex = 0
- Erase arr, tmp
- str = ""
- Else
- Dim mc, mcs
- With CreateObject("vbscript.regexp")
- .Global = True
- .Pattern = "\d+,(\d|,|-)+"
- Set mcs = .Execute(getpage)
- If mcs.Count > 0 Then
- For Each mc In mcs
- tmp = Split(mc.Value, ",")
- arr = Range(Cells(tmp(0) + 2, 4), Cells(tmp(0) + 2, 9)).Value
- arr(1, 2) = arr(1, 1)
- For j = 1 To UBound(tmp)
- If Len(tmp(j)) = 0 Then tmp(j) = 0
- If j <> 2 Then arr(1, j) = arr(1, j) + tmp(j) / 100
- Next
- If tmp(1) > 0 Then Cells(tmp(0) + 2, 4).Interior.ColorIndex = 3
- If tmp(1) < 0 Then Cells(tmp(0) + 2, 4).Interior.ColorIndex = 4
- Cells(tmp(0) + 2, 4).Resize(1, 6) = arr
- Erase tmp, arr
- Next
- End If
- End With
- End If
- m = m + 1
- getpage = ""
- End Sub
- Private Function byteToUf(byuf8) As String 'gbk的二进制数组转UTF
- On Error GoTo MyErr
- Dim lngStrLen As Long '需转换的字符串长度
- Dim byUf(1) As Byte '字符串暂存1
- Dim strDef As String '字符串暂存2
- Dim i As Long '哨兵计数
- Dim strUf As String '存放结果字符串
- lngStrLen = UBound(byuf8) '获得字符串长度
- i = 0
- Do While i < lngStrLen
- If byuf8(i) < 128 Then '非中文..不作处理。
- strUf = strUf & Chr(byuf8(i))
- i = i + 1
- Else '是中文
- byUf(1) = ((byuf8(i) And 15) * 16 + (byuf8(i + 1) And 60) / 4)
- byUf(0) = (byuf8(i + 1) And 3) * 64 + (byuf8(i + 2) And 63)
- strDef = byUf
- strUf = strUf & strDef
- i = i + 3
- End If
- Loop
- MyErr:
- byteToUf = strUf
- End Function
复制代码 |
评分
-
2
查看全部评分
-
|