网抓：VBA获取通达信龙虎榜单页面文字内容到EXCEL

zbs112

通达信游资龙虎榜单网址:
http://page.tdx.com.cn:7615/site/kggx/tk_yzlhb_yz.html


截图如下：



我用如下VBA代码网抓，没有数据。
也不知道是缺少什么，求帮忙修正代码，谢谢！

Private Sub CommandButton1_Click()

    Dim Url As String
    Url = "http://page.tdx.com.cn:7615/site/kggx/tk_yzlhb_yz.html"
    'Url = "http://page.tdx.com.cn:7615/TQLEX?Entry=CWServ.cfg_fx_yzlhb"
  
    Dim strText As String
    With CreateObject("MSXML2.XMLHTTP")
        .Open "POST", Url, False
        .send
        strText = .responseText
    End With

    MsgBox strText

End Sub

zbs112

我用fiddler软件查看是有数据，截图如下：

zbs112

参照fildder列示的标头，添加以下代码，也不能运行，求助

Private Sub CommandButton1_Click()

    Dim strText As String
   
    With CreateObject("MSXML2.XMLHTTP")
   
        .Open "POST", "http://page.tdx.com.cn:7615/TQLEX?Entry=CWServ.cfg_fx_yzlhb", False
        
        .setRequestHeader "Host", "page.tdx.com.cn:7615"
        .setRequestHeader "Connection", "keep-alive"
        .setRequestHeader "Content-length", 47
        
        .setRequestHeader "Accept", "text/plain,*/*;q=0.01"
        .setRequestHeader "X-Requested-With", "XMLHttpRequest"
        .setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 6.1; WOW64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/86.0.4240.198 Safari/537.36"
        .setRequestHeader "Content-Type", "application/x-www-form-urlencoded;charset=UTF-8"
        .setRequestHeader "Origin", "http://page.tdx.com.cn:7615"
        .setRequestHeader "Referer", "http://page.tdx.com.cn:7615/site/kggx/tk_yzlhb_yz.html"
        .setRequestHeader "Accept-Encoding", "gzip,deflate"
        .setRequestHeader "Accept-Language", "zh-CN,zh;q=0.9"
        .setRequestHeader "Cookie", "ASPSessionID="

        .send

        strText = .responseText
        
    End With
   
    MsgBox strText
   
End Sub

Yalishanda30

zbs112 发表于 2023-2-24 22:27
参照fildder列示的标头，添加以下代码，也不能运行，求助

Private Sub CommandButton1_Click()

需要POST传参进去{"Params":["pt","2023-02-24","jmr",1]}才能获取

smiletwo

Yalishanda30 发表于 2023-2-25 20:47
需要POST传参进去{"Params":["pt","2023-02-24","jmr",1]}才能获取

          学习下 怎么传

zbs112

比如：我们来简化抓取右部的数据，铭科精技001319。


网址：http://page.tdx.com.cn:7615/site ... bxq&code=001319

应该如何添加POST参数呢？求助中。。。

Yalishanda30

zbs112 发表于 2023-2-25 21:39
比如：我们来简化抓取右部的数据，铭科精技001319。

数据能获取到，字符乱码需处理一下

chenjy267

入门级别的难度，好好学get post方法就行了

zbs112

感谢楼上各位提示，以下代码可以了。

Private Sub CommandButton1_Click()
    GetstrSource1 "001319"
End Sub

Private Function GetstrSource1(sCode As String) As String
    Dim Url As String
    Url = "http://page.tdx.com.cn:7615/TQLEX?Entry=CWServ.cfg_fx_yzlhb"
    'http://page.tdx.com.cn:7615/site/kggx/tk_yzlhb_yz_yz.html?flag=yybxq&code=001319"
    Dim strSend As String
    strSend = "{""Params"":["
    strSend = strSend & """yybxq"","
    strSend = strSend & """""," & """"","
    strSend = strSend & """" & sCode & ""","
    strSend = strSend & """""," & "0,20]}"
    '{"Params":["yybxq","","","001319","",0,20]}
    With CreateObject("MSXML2.XMLHTTP")
        .Open "POST", Url, False
        .send CStr(strSend)
        GetstrSource1 = StrConv(.responseText, vbNarrow)
    End With
    Open ThisWorkbook.Path & "\" & sCode & ".txt" For Output As #1
    Print #1, GetstrSource1: Close #1   '关闭文件
End Function

zbs112

获取文本内容，结合正则表达式，分析数据到表格。



Option Explicit

Private Sub CommandButton1_Click()

    Dim N As Long
    Dim str As String
    Dim mStr As String

    Dim regEx As Object
    Dim Match As Object
    Dim Matchs As Object

    str = GetstrSource1("001319")   '获取文本
   
    Set regEx = CreateObject("vbscript.regexp")

    regEx.Global = True  '全局有效
    regEx.MultiLine = True   '多行有效
    regEx.IgnoreCase = True  '忽略大小写

    regEx.Pattern = "\[\[[\s\S]*?\]]"
    str = regEx.Execute(str).Item(0)
    regEx.Pattern = "\[[\s\S]*?\]"
    Set Match = regEx.Execute(str)

    Dim zDate As String
    For N = 1 To Match.Count
        mStr = Match.Item(N - 1)   '内容
        mStr = Replace(mStr, "null", Chr(34) & Chr(34))
        mStr = Replace(Replace(mStr, "B", "买入"), "S", "卖出")
        mStr = Replace(Replace(mStr, "dr", "当日"), "3r", "3日")
        regEx.Pattern = """[\s\S]*?"""
        Set Matchs = regEx.Execute(mStr)
        Cells(N + 3, 1) = NewStock(Replace(Matchs.Item(1), Chr(34), ""))
        Cells(N + 3, 2) = Replace(Matchs.Item(0), Chr(34), "")
        Cells(N + 3, 3) = Replace(Matchs.Item(2), Chr(34), "")
        Cells(N + 3, 4) = Replace(Matchs.Item(3), Chr(34), "")
        Cells(N + 3, 5) = Replace(Matchs.Item(4), Chr(34), "")
        Cells(N + 3, 6) = Replace(Matchs.Item(5), Chr(34), "")
        Cells(N + 3, 7) = Replace(Matchs.Item(6), Chr(34), "")
        Cells(N + 3, 8) = Replace(Matchs.Item(7), Chr(34), "")
        Cells(N + 3, 9) = Replace(Matchs.Item(8), Chr(34), "")
        zDate = Replace(Matchs.Item(9), Chr(34), "")
        Cells(N + 3, 10) = Format(CDate(zDate), " yyyy-mm-dd")
    Next N
End Sub

Private Function GetstrSource1(sCode As String) As String
    Dim Url As String
    Url = "http://page.tdx.com.cn:7615/TQLEX?Entry=CWServ.cfg_fx_yzlhb"
    Dim strSend As String
    strSend = "{""Params"":["
    strSend = strSend & """yybxq"","
    strSend = strSend & """""," & """"","
    strSend = strSend & """" & sCode & ""","
    strSend = strSend & """""," & "0,20]}"
    '{"Params":["yybxq","","","001319","",0,20]}
    With CreateObject("MSXML2.XMLHTTP")
        .Open "POST", Url, False
        .send CStr(strSend)
        GetstrSource1 = StrConv(.responseText, vbNarrow)
    End With
End Function

Private Function NewStock(strStock As String) As String
    Select Case Left(strStock, 2)
        Case "60", "68", "11"
            NewStock = "sh" & Replace(strStock, Chr(34), "")
        Case "00", "30", "12"
            NewStock = "sz" & Replace(strStock, Chr(34), "")
        Case Else
            NewStock = "bj" & Replace(strStock, Chr(34), "")
    End Select
End Function