2022-01-21 16:12 根据新浪接口更新了代码,再修复一次
打开VBA编辑器WinHttp.XMLHTTP 替换 成 WinHttp.WinHttpRequest.5.1
在 .send 前面加 .setRequestHeader "Referer", "http://finance.sina.com.cn/"
例如我这个用的这个函数原先是:
With CreateObject("WinHttp.XMLHTTP")
.Open "GET", url, False
.Send
sTemp = .responseText
End With
改成下面的就正常了
With CreateObject("WinHttp.WinHttpRequest.5.1")
.Open "GET", url, False
.setRequestHeader "Referer", "http://finance.sina.com.cn/"
.Send
sTemp = .responseText
End With
==============
获取新浪行情的完整函数
Sub GetNetValueDetail(ByVal sheet As Worksheet, beginCol As String) '基金查询
Dim rowCount As Integer
Dim url As String
Dim sTemp As String
rowCount = sheet.Range("A65535").End(xlUp).Row '获取行数
url = "http://hq.sinajs.cn/list=" '新浪行情数据接口
For i = 2 To rowCount '从第二行开始,第一列为股票代码
code = sheet.Range("A" & i).Text
If Len(code) < 6 Then
code = "unknow"
Else
code = "of" & Right(code, 6) '基金代码前of(open fund)
End If
If i = 2 Then
url = url & code
Else
url = url & "," & code
End If
Next i
'获取新浪股票行情数据,放入sTemp变量
With CreateObject("WinHttp.WinHttpRequest.5.1")
.Open "GET", url, False
.setRequestHeader "Referer", "http://finance.sina.com.cn/"
.Send
sTemp = .responseText
End With
splits = Split(sTemp, ";")
For i = 0 To rowCount - 1
mystr = splits(i)
ss = InStr(mystr, ",")
If ss > 1 Then
startindex = InStr(1, mystr, """")
endindex = InStrRev(mystr, """")
substr = Mid(mystr, startindex + 1, endindex - startindex - 1) '引号中的有效数据
valuearray = Split(substr, ",")
begin = Asc(beginCol)
J = 0
sheet.Range(Chr(begin + J) & i + 2).Value = valuearray(0) '名称
J = J + 1
sheet.Range(Chr(begin + J) & i + 2).Value = valuearray(1) '净值
J = J + 1
sheet.Range(Chr(begin + J) & i + 2).Value = valuearray(2) '累计净值
J = J + 1
sheet.Range(Chr(begin + J) & i + 2).Value = valuearray(3) '上日净值
J = J + 1
sheet.Range(Chr(begin + J) & i + 2).Value = Format(valuearray(4) / 100, "0.00%") '净值涨跌幅
sheet.Range(Chr(begin + J) & i + 2).Font.Color = GetFontColor(valuearray(1) - valuearray(3))
J = J + 1
sheet.Range(Chr(begin + J) & i + 2).Value = valuearray(5) '日期
End If
Next i
End Sub
1
赞同来自: 慎之又胜
@玲音
strHeaders = _T("Referer:http://finance.sina.com.cn/";);抱歉,对C++语言不熟悉
CHttpFile* pFile = (CHttpFile*)session.OpenURL((LPCTSTR)strUrl, 1, INTERNET_FLAG_TRANSFER_ASCII | INTERNET_FLAG_RELOAD | INTERNET_FLAG_DONT_CAC...
2
@beron1688
改成 With CreateObject("WinHttp.WinHttpRequest.5.1")
请问楼主,我的改了后还是不行。请假解决办法。谢谢楼主!With CreateObject("Microsoft.XMLHTTP")
Sub 获取价格_Click()
Dim rowCount As Integer
Dim url As String
Dim sTemp As String
With Application
.Calculation = xlManual
.MaxChange = 0.001
End W...
改成 With CreateObject("WinHttp.WinHttpRequest.5.1")
1
赞同来自: 路履薄冰
请问楼主,我的改了后还是不行。请假解决办法。谢谢楼主!
Sub 获取价格_Click()
Dim rowCount As Integer
Dim url As String
Dim sTemp As String
With Application
.Calculation = xlManual
.MaxChange = 0.001
End With
rowCount = Range("A65535").End(xlUp).Row '获取行数
url = "http://hq.sinajs.cn/list="
For i = 2 To rowCount
If i = 2 Then
url = url & Range("A" & i).Text
Else
url = url & "," & Range("A" & i).Text
End If
Next i
'获取新浪股票行情数据,放入sTemp变量
With CreateObject("Microsoft.XMLHTTP")
.Open "GET", url, False
.setRequestHeader "Referer", "http://finance.sina.com.cn/"
.send
sTemp = .responseText
End With
splits = Split(sTemp, ";")
For i = 0 To rowCount
mystr = splits(i)
ss = InStr(mystr, ",")
If ss < 1 Then '代码解析不了,退出
Exit For
End If
startIndex = InStr(1, mystr, """")
endIndex = InStrRev(mystr, """")
subStr = Mid(mystr, startIndex + 1, endIndex - 1)
valueArray = Split(subStr, ",") '共有32个数据 ,包括了股票名称,价格等信息
'以下取数据,省略了买1至买5,卖1至卖5
Range("B" & i + 2).Value = valueArray(0) '名称
Range("C" & i + 2).Value = valueArray(3) '当前价
Range("D" & i + 2).Value = valueArray(6) '买一
Range("E" & i + 2).Value = valueArray(7) '卖一
Range("f" & i + 2).Value = valueArray(2) '昨收盘
Next i
With Application
.Calculation = xlAutomatic
.MaxChange = 0.001
End With
Call Sheet1.time
End Sub
Sub 获取价格_Click()
Dim rowCount As Integer
Dim url As String
Dim sTemp As String
With Application
.Calculation = xlManual
.MaxChange = 0.001
End With
rowCount = Range("A65535").End(xlUp).Row '获取行数
url = "http://hq.sinajs.cn/list="
For i = 2 To rowCount
If i = 2 Then
url = url & Range("A" & i).Text
Else
url = url & "," & Range("A" & i).Text
End If
Next i
'获取新浪股票行情数据,放入sTemp变量
With CreateObject("Microsoft.XMLHTTP")
.Open "GET", url, False
.setRequestHeader "Referer", "http://finance.sina.com.cn/"
.send
sTemp = .responseText
End With
splits = Split(sTemp, ";")
For i = 0 To rowCount
mystr = splits(i)
ss = InStr(mystr, ",")
If ss < 1 Then '代码解析不了,退出
Exit For
End If
startIndex = InStr(1, mystr, """")
endIndex = InStrRev(mystr, """")
subStr = Mid(mystr, startIndex + 1, endIndex - 1)
valueArray = Split(subStr, ",") '共有32个数据 ,包括了股票名称,价格等信息
'以下取数据,省略了买1至买5,卖1至卖5
Range("B" & i + 2).Value = valueArray(0) '名称
Range("C" & i + 2).Value = valueArray(3) '当前价
Range("D" & i + 2).Value = valueArray(6) '买一
Range("E" & i + 2).Value = valueArray(7) '卖一
Range("f" & i + 2).Value = valueArray(2) '昨收盘
Next i
With Application
.Calculation = xlAutomatic
.MaxChange = 0.001
End With
Call Sheet1.time
End Sub
0
strHeaders = _T("Referer:http://finance.sina.com.cn/");
CHttpFile* pFile = (CHttpFile*)session.OpenURL((LPCTSTR)strUrl, 1, INTERNET_FLAG_TRANSFER_ASCII | INTERNET_FLAG_RELOAD | INTERNET_FLAG_DONT_CACHE,strHeaders, 0);
C++版本的增加这个header后依然不行,请教楼主可有解决方法?
CHttpFile* pFile = (CHttpFile*)session.OpenURL((LPCTSTR)strUrl, 1, INTERNET_FLAG_TRANSFER_ASCII | INTERNET_FLAG_RELOAD | INTERNET_FLAG_DONT_CACHE,strHeaders, 0);
C++版本的增加这个header后依然不行,请教楼主可有解决方法?
0
@Lee158
这个改成
不同懂语言,这个认证语句是要放在什么位置
strUrl = "http://hq.sinajs.cn/list=" & Code(i) & Cells(1 + i, 1) '起始代码单元格
xmlobject.Open "GET", strUrl, False
xmlobject.setRequestHeader " Referer", "https://finance.sina....
Set objXML = CreateObject("Microsoft.XMLHTTP")
With objXML
.Open "Get", Url, False, "", ""
.Send
这个改成
Set objXML = CreateObject("WinHttp.WinHttpRequest.5.1")
With objXML
.Open "Get", Url, False, "", ""
.setRequestHeader "Referer", "finance.sina.com.cn"
.Send
0
不同懂语言,这个认证语句是要放在什么位置
strUrl = "http://hq.sinajs.cn/list=" & Code(i) & Cells(1 + i, 1) '起始代码单元格
xmlobject.Open "GET", strUrl, False
xmlobject.setRequestHeader " Referer", "https://finance.sina.com.cn"
xmlobject.send
If xmlobject.readystate = 4 Then
strReturn = xmlobject.responsetext
intLen = Len(strReturn) - 25 '剔除无关数据
strReturn = Mid(strReturn, 22, intLen)
arry = Split(strReturn, ",") '按逗号分隔数据,放入数组arry
intLenA = UBound(arry) - LBound(arry) + 1 '数组长度,此处未使用,可结合For遍历arry
'获取目标数据
Cells(1 + i, 3) = arry(3) '现值
Cells(1 + i, 4) = arry(3) - arry(2) '幅度差
Cells(1 + i, 5) = Round((arry(3) - arry(2)) / arry(2), 4) '幅度百分比
Cells(1 + i, 6) = arry(8) / 100 '量
Cells(1 + i, 2) = arry(0)
End If
Next i
strUrl = "http://hq.sinajs.cn/list=" & Code(i) & Cells(1 + i, 1) '起始代码单元格
xmlobject.Open "GET", strUrl, False
xmlobject.setRequestHeader " Referer", "https://finance.sina.com.cn"
xmlobject.send
If xmlobject.readystate = 4 Then
strReturn = xmlobject.responsetext
intLen = Len(strReturn) - 25 '剔除无关数据
strReturn = Mid(strReturn, 22, intLen)
arry = Split(strReturn, ",") '按逗号分隔数据,放入数组arry
intLenA = UBound(arry) - LBound(arry) + 1 '数组长度,此处未使用,可结合For遍历arry
'获取目标数据
Cells(1 + i, 3) = arry(3) '现值
Cells(1 + i, 4) = arry(3) - arry(2) '幅度差
Cells(1 + i, 5) = Round((arry(3) - arry(2)) / arry(2), 4) '幅度百分比
Cells(1 + i, 6) = arry(8) / 100 '量
Cells(1 + i, 2) = arry(0)
End If
Next i
0
Function FormatDate(ByRef strDate As String)
iYear = Mid(strDate, 1, 4)
iMonth = Mid(strDate, 5, 2)
iDay = Mid(strDate, 7, 2)
FormatDate = iYear + "-" + iMonth + "-" + iDay
End Function
Function gp3(ByRef StockCode As String)
Application.Volatile '定义为易失性函数(每次需要重新计算)
Url = "http://hq.sinajs.cn/list=" + StockCode
strData = GetHttp(Url)
strData = Replace(strData, Chr(13), "") '替换换行符
strData = Replace(strData, Chr(10), "") '替换回车符
Set objREGEXP = CreateObject("VBSCRIPT.REGEXP") 'note定义了一个正则表达式,去除http返回的前面一堆乱七八糟的头
With objREGEXP
.Global = True
.Pattern = "var hq_str_.*=\"""
strData = .Replace(strData, "")
.Pattern = "\"";"
strData = .Replace(strData, "")
End With
Set objREGEXP = Nothing
StockData = Split(strData, ",") '将strData通过Split函数分开,split函数返回一个包含各种数据的数组
gp3 = Val(StockData(3))
End Function
Function GetHttp(Url)
Dim objXML
On Error Resume Next
Set objXML = CreateObject("Microsoft.XMLHTTP")
With objXML
.Open "Get", Url, False, "", ""
.Send
GetHttp = .ResponseBody
End With
GetHttp = BytesToBstr(GetHttp, "GB2312")
Set objXML = Nothing
On Error GoTo 0
End Function
Function BytesToBstr(strBody, CodeBase)
Dim objStream
Set objStream = CreateObject("Adodb.Stream")
With objStream
.Type = 1
.Mode = 3
.Open
.Write strBody
.Position = 0
.Type = 2
.Charset = CodeBase
BytesToBstr = .ReadText
End With
objStream.Close
Set objStream = Nothing
End Function
请教下这个要怎么修复?
iYear = Mid(strDate, 1, 4)
iMonth = Mid(strDate, 5, 2)
iDay = Mid(strDate, 7, 2)
FormatDate = iYear + "-" + iMonth + "-" + iDay
End Function
Function gp3(ByRef StockCode As String)
Application.Volatile '定义为易失性函数(每次需要重新计算)
Url = "http://hq.sinajs.cn/list=" + StockCode
strData = GetHttp(Url)
strData = Replace(strData, Chr(13), "") '替换换行符
strData = Replace(strData, Chr(10), "") '替换回车符
Set objREGEXP = CreateObject("VBSCRIPT.REGEXP") 'note定义了一个正则表达式,去除http返回的前面一堆乱七八糟的头
With objREGEXP
.Global = True
.Pattern = "var hq_str_.*=\"""
strData = .Replace(strData, "")
.Pattern = "\"";"
strData = .Replace(strData, "")
End With
Set objREGEXP = Nothing
StockData = Split(strData, ",") '将strData通过Split函数分开,split函数返回一个包含各种数据的数组
gp3 = Val(StockData(3))
End Function
Function GetHttp(Url)
Dim objXML
On Error Resume Next
Set objXML = CreateObject("Microsoft.XMLHTTP")
With objXML
.Open "Get", Url, False, "", ""
.Send
GetHttp = .ResponseBody
End With
GetHttp = BytesToBstr(GetHttp, "GB2312")
Set objXML = Nothing
On Error GoTo 0
End Function
Function BytesToBstr(strBody, CodeBase)
Dim objStream
Set objStream = CreateObject("Adodb.Stream")
With objStream
.Type = 1
.Mode = 3
.Open
.Write strBody
.Position = 0
.Type = 2
.Charset = CodeBase
BytesToBstr = .ReadText
End With
objStream.Close
Set objStream = Nothing
End Function
请教下这个要怎么修复?
0
我的版本错行,水平差没办法搞定,只好改成大点数据,我改成700了,空一行暂时可以了,等高手改bug
Sub GetPriceDetail(ByVal sheet As Worksheet) '详细版,(名称,价格,涨幅,振幅,最高价,最低价,成交额,更新时间)
Dim rowCount As Integer
Dim URL As String
Dim sTemp As String
rowCount = sheet.Range("A65535").End(xlUp).Row '获取行数
maxCountPer = 700 ' 每30行一读取
num = Int((rowCount - 1) / maxCountPer)
For kk = 0 To num
URL = "http://hq.sinajs.cn/list="
For jj = 2 To maxCountPer
ii = kk * maxCountPer + jj + 1
If ii <= rowCount Then
code = sheet.Range("A" & ii).Text
If Len(code) < 6 Then
code = "unknow"
End If
If ii = 2 Then '从第二行开始
URL = URL & code
Else
URL = URL & "," & code
End If
End If
Next jj
'获取新浪股票行情数据,放入sTemp变量
With CreateObject("WinHttp.WinHttpRequest.5.1")
.Open "GET", URL, False
.setRequestHeader "Referer", "http://finance.sina.com.cn"
.Send
sTemp = .responseText
End With
Sub GetPriceDetail(ByVal sheet As Worksheet) '详细版,(名称,价格,涨幅,振幅,最高价,最低价,成交额,更新时间)
Dim rowCount As Integer
Dim URL As String
Dim sTemp As String
rowCount = sheet.Range("A65535").End(xlUp).Row '获取行数
maxCountPer = 700 ' 每30行一读取
num = Int((rowCount - 1) / maxCountPer)
For kk = 0 To num
URL = "http://hq.sinajs.cn/list="
For jj = 2 To maxCountPer
ii = kk * maxCountPer + jj + 1
If ii <= rowCount Then
code = sheet.Range("A" & ii).Text
If Len(code) < 6 Then
code = "unknow"
End If
If ii = 2 Then '从第二行开始
URL = URL & code
Else
URL = URL & "," & code
End If
End If
Next jj
'获取新浪股票行情数据,放入sTemp变量
With CreateObject("WinHttp.WinHttpRequest.5.1")
.Open "GET", URL, False
.setRequestHeader "Referer", "http://finance.sina.com.cn"
.Send
sTemp = .responseText
End With