不懂html也来学网抓（xmlhttp/winhttp+fiddler）

VBA万岁

wcymiss 发表于 2015-3-9 17:06
嗯，确实有错，而且错得离谱，不知道第一个写这段代码是根据什么写的。
错误1：压缩前数据长度获取错误。 ...

公司电脑网络限制，登录不了本论坛了，也下载不了附件，所以帖上老师的代码，回公司后再慢慢研究：
方法一gzip_dll(Module)
Option Explicit

Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)

'======================解压API==========================
Private Declare Function InitDecompression Lib "D:\gzip.dll" () As Long
Private Declare Function CreateDecompression Lib "D:\gzip.dll" (ByRef context As Long, ByVal flags As Long) As Long
Private Declare Function DestroyDecompression Lib "D:\gzip.dll" (ByVal context As Long) As Long
Private Declare Function Decompress Lib "D:\gzip.dll" ( _
    ByVal context As Long, _
    ByRef input_buffer As Any, ByVal input_buffer_size As Long, _
    ByRef output_buffer As Any, ByVal Output_buffer_size As Long, _
    ByRef input_used As Long, ByRef output_used As Long) As Long

Public Function UnCompressByGzipDLL(arrByte() As Byte, Optional Flag As Long = 1) As Boolean
    Dim contextHandle As Long
    Dim InputBufferSize As Long
    Dim OutputBuffer() As Byte
    Dim OutputBufferSize As Long
    Dim outUsed As Long
    Dim inUsed As Long
    Dim ReturnValue As Long
   
    UnCompressByGzipDLL = False
    ReDim Result(0)
   
    InputBufferSize = UBound(arrByte) + 1
    CopyMemory OutputBufferSize, arrByte(UBound(arrByte) - 3), 4
    ReDim OutputBuffer(OutputBufferSize - 1) As Byte
   
    InitDecompression
    CreateDecompression contextHandle, Flag
   
    ReturnValue = Decompress( _
        contextHandle, _
        arrByte(0), InputBufferSize, _
        OutputBuffer(0), OutputBufferSize + 1, _
        inUsed, outUsed)
        
    DestroyDecompression contextHandle
   
    If ReturnValue = 0 Then
        UnCompressByGzipDLL = True
        arrByte = OutputBuffer
    End If
End Function
方法二winrar(Module)
Option Explicit

Public Function UnCompressByWinrar(arrByte() As Byte) As Boolean
    Const WinrarFullName As String = "C:\Program Files\WinRAR\WinRAR.exe"
    Const TempPath  As String = "D:\"
    Const TempGzipFile  As String = "GzipTest"
    Dim GzFile As String
    Dim UnGzFile As String
   
    If Dir(WinrarFullName) = "" Then MsgBox "请写入winrar.exe文件的正确路径": Exit Function
   
    GzFile = TempPath & TempGzipFile & ".gz"
    UnGzFile = TempPath & TempGzipFile
   
    If Dir(GzFile) <> "" Then Kill GzFile
   
    Open GzFile For Binary As #1
    Put #1, , arrByte
    Close #1
   
    CreateObject("wscript.shell").Run """" & WinrarFullName & """ x " & GzFile & " " & TempGzipFile & " " & TempPath & " -y -ibck", 0, 1
   
    Open UnGzFile For Binary As #1
    ReDim arrByte(LOF(1) - 1)
    Get #1, , arrByte
    Close #1
   
    Kill TempPath & TempGzipFile & ".gz"
    Kill TempPath & TempGzipFile
    UnCompressByWinrar = True
End Function
网站测试(Module)
Option Explicit

Sub URLTest1() '用方法1
    Dim arrByte() As Byte
    Dim arrByteGzip() As Byte
    Dim strText As String
    Dim strTextGzip As String
    Dim ISize As Long
    Dim CanCompare As Boolean
    Dim i As Long
   
    i = 4
    CanCompare = True
   
    With CreateObject("WinHttp.WinHttpRequest.5.1")
        .Open "GET", Cells(i, 1).Value, False
        .Send
        If .getallresponseheaders Like "*Content-Encoding: gzip*" Then
            CanCompare = False
            Cells(i, 6).Value = "无非GZIP数据"
        Else
            arrByte = .responseBody
            Cells(i, 2).Value = UBound(arrByte) + 1
            strText = byteToStr(arrByte, "utf-8")
        End If
    End With
   
    With CreateObject("WinHttp.WinHttpRequest.5.1")
        .Open "GET", Cells(i, 1).Value, False
        .setRequestHeader "Accept-Encoding", "gzip, deflate"
        .Send
        If .getallresponseheaders Like "*Content-Encoding: gzip*" Then
            arrByteGzip = .responseBody
            Cells(i, 3).Value = UBound(arrByteGzip) + 1
            CopyMemory ISize, arrByteGzip(UBound(arrByteGzip) - 3), 4
            Cells(i, 4).Value = ISize
            Call UnCompressByGzipDLL(arrByteGzip)
            Cells(i, 5).Value = UBound(arrByteGzip) + 1
            strTextGzip = byteToStr(arrByteGzip, "utf-8")
        Else
            CanCompare = False
            Cells(i, 6).Value = "无GZIP数据"
        End If
    End With

    If CanCompare Then
        Cells(i, 6).Value = (strTextGzip = strText)
    End If
End Sub

Sub URLTest2() '用方法2
    Dim arrByte() As Byte
    Dim arrByteGzip() As Byte
    Dim strText As String
    Dim strTextGzip As String
    Dim ISize As Long
    Dim CanCompare As Boolean
    Dim i As Long
   
    i = 4
    CanCompare = True
    Range(Cells(i, 2), Cells(i, 8)).ClearContents
   
    With CreateObject("WinHttp.WinHttpRequest.5.1")
        .Open "GET", Cells(i, 1).Value, False
        .Send
        If .getallresponseheaders Like "*Content-Encoding: gzip*" Then
            CanCompare = False
            Cells(i, 6).Value = "无非GZIP数据"
        Else
            arrByte = .responseBody
            Cells(i, 2).Value = UBound(arrByte) + 1
            strText = byteToStr(arrByte, "utf-8")
        End If
    End With
   
    With CreateObject("WinHttp.WinHttpRequest.5.1")
        .Open "GET", Cells(i, 1).Value, False
        .setRequestHeader "Accept-Encoding", "gzip, deflate"
        .Send
        If .getallresponseheaders Like "*Content-Encoding: gzip*" Then
            arrByteGzip = .responseBody
            Cells(i, 3).Value = UBound(arrByteGzip) + 1
            CopyMemory ISize, arrByteGzip(UBound(arrByteGzip) - 3), 4
            Cells(i, 4).Value = ISize
            Call UnCompressByWinrar(arrByteGzip)
            Cells(i, 5).Value = UBound(arrByteGzip) + 1
            strTextGzip = byteToStr(arrByteGzip, "utf-8")
        Else
            CanCompare = False
            Cells(i, 6).Value = "无GZIP数据"
        End If
    End With

    If CanCompare Then
        Cells(i, 6).Value = (strTextGzip = strText)
    End If
End Sub

Private Function byteToStr(arrByte, strCharset As String) As String
    With CreateObject("Adodb.Stream")
        .Type = 1 'adTypeBinary
        .Open
        .Write arrByte
        .Position = 0
        .Type = 2 'adTypeText
        .Charset = strCharset
        byteToStr = .Readtext
        .Close
    End With
End Function
压缩(Module)
Option Explicit

======================压缩API==========================
Private Declare Function InitCompression Lib "D:\gzip.dll" () As Long
Private Declare Function CreateCompression Lib "D:\gzip.dll" (ByRef context As Long, ByVal flags As Long) As Long
Private Declare Function DestroyCompression Lib "gD:\zip.dll" (ByVal context As Long) As Long
Private Declare Function Compress Lib "D:\gzip.dll" ( _
    ByVal context As Long, _
    ByRef input_buffer As Any, ByVal input_buffer_size As Long, _
    ByRef output_buffer As Any, ByVal Output_buffer_size As Long, _
    ByRef input_used As Long, ByRef output_used As Long, _
    ByVal compression_level As Long) As Long


Public Function CompressByGzipDLL(arrByte() As Byte, Optional Flag As Long = 1) As Boolean
    Dim contextHandle As Long
    Dim InputBufferSize As Long
    Dim OutputBuffer() As Byte
    Dim outUsed As Long
    Dim inUsed As Long
    Dim ReturnValue As Long
    Dim Result() As Byte
    Dim TempLength As Long
    Const MaxBufferSize As Long = 1000
   
    CompressByGzipDLL = False
    ReDim Result(0)
   
    InputBufferSize = UBound(arrByte) + 1
    ReDim OutputBuffer(MaxBufferSize - 1) As Byte
   
    InitCompression
    CreateCompression contextHandle, Flag
   
    Do
        ReturnValue = Compress( _
            contextHandle, _
            arrByte(0), InputBufferSize, _
            OutputBuffer(0), MaxBufferSize, _
            inUsed, outUsed, 1)
        If outUsed <> 0 Then
            TempLength = UBound(Result)
            ReDim Preserve Result(TempLength + outUsed)
            CopyMemory Result(TempLength), OutputBuffer(0), outUsed
            InputBufferSize = InputBufferSize - inUsed
        End If
    Loop While ReturnValue = 0
   
    DestroyCompression contextHandle
   
    If UBound(Result) > 0 Then
        CompressByGzipDLL = True
        ReDim arrByte(UBound(Result) - 1)
        CopyMemory arrByte(0), Result(0), UBound(Result)
    End If
End Function
字符串测试(Module)
Option Explicit

Sub StringTest1() '用方法1
    Dim strText As String
    Dim arrByte() As Byte
    Dim arrByte0() As Byte
    Dim i As Long
   
    strText = String(1000, "a")
    arrByte0 = StrConv(strText, vbFromUnicode)
    arrByte = arrByte0
    Debug.Print "长度：" & UBound(arrByte) + 1
   
    Debug.Print "压缩执行：" & CompressByGzipDLL(arrByte, 1)
    Debug.Print "解压执行：" & UnCompressByGzipDLL(arrByte, 1)
   
    If UBound(arrByte) = UBound(arrByte0) Then
        Debug.Print "解压正确"
    Else
        Debug.Print "解压错误"
    End If
   
    For i = 0 To UBound(arrByte)
        If arrByte(i) <> arrByte0(i) Then Stop
    Next
End Sub

Sub StringTest2() '用方法2
    Dim strText As String
    Dim arrByte() As Byte
    Dim arrByte0() As Byte
    Dim i As Long
   
    strText = String(1000, "a")
    arrByte0 = strText
    arrByte = arrByte0
    Debug.Print "长度：" & UBound(arrByte) + 1
   
    Debug.Print "压缩执行：" & CompressByGzipDLL(arrByte, 1)
    Debug.Print "解压执行：" & UnCompressByWinrar(arrByte)
   
    If UBound(arrByte) = UBound(arrByte0) Then
        Debug.Print "解压正确"
    Else
        Debug.Print "解压错误"
    End If
   
    For i = 0 To UBound(arrByte)
        If arrByte(i) <> arrByte0(i) Then Stop
    Next
End Sub

VBA万岁

VBA万岁 发表于 2015-5-1 13:47
公司电脑网络限制，登录不了本论坛了，也下载不了附件，所以帖上老师的代码，回公司后再慢慢研究：
方法 ...

测试数据：
测试URL        非压缩长度        压缩长度        后四字节        解压长度        比对
http://www.pss-system.gov.cn/sipopublicsearch/portal/index.shtml                                       
http://www.telerik.com/UpdateCheck.aspx?isBeta=False                                        
http://www.sina.com                                       

LangFan123

谢谢分享，学习了!

VBA万岁

zongyj 发表于 2014-12-11 12:27
吴姐回复的帖子
主题；回帖；看帖

测试通过——退出登录后运行楼上的代码可取到回贴数据。
正好公司网络限制，无法登录本论坛，等回公司后再测试看看。
另，上传多页回帖数据代码如下:

1. Sub wcymiss2()
   
2. Dim WinHttp As New WinHttpRequest, html, a, p%, n%
   
3. ActiveSheet.UsedRange.Offset(1).Clear
   
4. Range("a1:c1") = Array("主题", "回复", "查看")
   
5. 
   
6. Set html = CreateObject("htmlfile")
   
7. With WinHttp
   
8.     Do
   
9.         p = p + 1
   
10.         .Open "GET", "http://club.excelhome.net/home.php?mod=space&uid=218917&do=thread&view=me&type=reply&from=space&page=" & p & "&mobile=yes", False
    
11.         .setRequestHeader "User-Agent", "Mozilla/4.0 (compatible: MSIE 7.0; Windows Phone OS 7.0; Trident/3.1; IEMobile/7.0; SAMSUNG; SGH-i917)"
    
12.         .send
    
13.         'If InStr(.responseText, "下一页") = 0 Then Exit Do
    
14.         If p = 6 Then Exit Do
    
15.         html.body.innerHTML = .responseText
    
16.         For Each a In html.all.tags("a")
    
17.             If Left(a.href, 5) = "about" And a.innerText <> "" And a.innerText <> "论坛" And a.innerText <> "首页" And a.innerText <> "主题" And a.innerText <> "回复" Then
    
18.                 n = n + 1
    
19.                 ActiveSheet.Hyperlinks.Add Anchor:=Cells(n + 1, 1), Address:=Replace(a.href, "about:", "http://club.excelhome.net/"), TextToDisplay:=a.innerText
    
20.             End If
    
21.         Next
    
22.     Loop
    
23. End With
    
24. End Sub
    

复制代码

VBA万岁

wcymiss 发表于 2014-10-22 15:30
获取数据-防盗链的处理-模拟User-Agent

很少遇到需要模拟User-Agent的网页。

这个太好了——正好公司网络限制登录本论坛，无法查看所关注的会员的回贴信息（主要是链接以方便打开）。回去后立马测试......

VBA万岁

wcymiss 发表于 2014-10-23 12:13
说到skey和bkn，索性再唠叨一下用IE获取Cookie的例子。

QQ的skey用winhttp比较难以获取，当中包含了一些 ...

我这里测试第一段代码不成功——无法获取Skey值，立即窗口中也未见到skey字样。
第二段代码测试成功。

wcymiss

VBA万岁 发表于 2015-5-2 08:17
我这里测试第一段代码不成功——无法获取Skey值，立即窗口中也未见到skey字样。
第二段代码测试成功。

IE法是需要IE加载一个控件的。
先登录软件QQ，然后用IE打开腾讯微博网页，然后登录腾讯微博，IE应该会让你加载一个登录控件。你试试。

VBA万岁

wcymiss 发表于 2015-5-2 09:10
IE法是需要IE加载一个控件的。
先登录软件QQ，然后用IE打开腾讯微博网页，然后登录腾讯微博，IE应该会让 ...

照做之后可以运行代码获得一个skey值，再用这个skey值去提取（用老师之前的代码提取——该代码用抓包获得的skey值是可以成功取数的）QQ数据，却不成功。而且在IE中登录腾讯微博（直接单击本贴中的“腾讯微博”按钮后登录）时，也没被要求“加载一个登录控件”。不知为何？

VBA万岁

VBA万岁 发表于 2015-5-1 16:54
测试通过——退出登录后运行楼上的代码可取到回贴数据。
正好公司网络限制，无法登录本论坛，等回公司后 ...

在公司测试失败......

hkzc

各位大神 请教一下用winhttp POST登陆HTTPS论坛时总是重定向失败 到底要怎样解决啊