如何使用VBA進行復雜的POST

Question

我在使用VBA進行POST httprequest時遇到問題。我有一些參數和JSON東西的提琴手日誌。參數是兩個，JSON（也是那個參數？）是一個。它看起來像：

這裏是我的問題 - 如何將這些參數發送所有在一起嗎？理想情況下在VBA中，但即使是一般的答案也會很好。

我想說我有點兒新東西。

問候， 盧克。

Answer 1

嘗試將請求中提供適當的餅乾和Content-Type頭，看看下面的例子，它採用MSXML2.ServerXMLHTTP與cookies來管理：

Option Explicit 

Sub scrape_kody_poczta_polska_pl() 

    Dim sRespHeaders As String 
    Dim aSetHeaders 
    Dim sPayload As String 
    Dim sRespText As String 
    Dim aRows 
    Dim aCells 
    Dim i As Long 
    Dim j As Long 
    Dim aData 

    ' Get search page to retrieve cookies 
    XmlHttpRequest _ 
     "GET", _ 
     "http://kody.poczta-polska.pl/", _ 
     Array(), _ 
     "", _ 
     sRespHeaders, _ 
     "" 
    ' Extract cookies 
    ParseResponse "^Set-(Cookie): (\S*?=\S*?);[\s\S]*?$", sRespHeaders, aSetHeaders 
    ' Setup request 
    sPayload = "kod=20-610&page=kod" 
    PushItem aSetHeaders, Array("Content-Type", "application/x-www-form-urlencoded") 
    ' Retrieve results 
    XmlHttpRequest _ 
     "POST", _ 
     "http://kody.poczta-polska.pl/index.php", _ 
     aSetHeaders, _ 
     sPayload, _ 
     "", _ 
     sRespText 
    ' Parse table rows 
    ParseResponse _ 
     "(<tr>(?:[\s\S]*?<t[dh]>[\s\S]*?</t[dh]>)+?[\s\S]*?</tr>)", _ 
     sRespText, _ 
     aRows 
    ' Parse table cells 
    For i = 0 To UBound(aRows) 
     ParseResponse _ 
      "<t[dh]>([\s\S]*?)</t[dh]>", _ 
      aRows(i), _ 
      aCells, _ 
      False 
     For j = 0 To UBound(aCells) 
      aCells(j) = DecodeHTMLEntities((aCells(j))) 
     Next 
     aRows(i) = aCells 
    Next 
    ' Output 
    With ThisWorkbook.Sheets(1) 
     .Cells.Delete 
     .Cells.HorizontalAlignment = xlCenter 
     .Cells.VerticalAlignment = xlTop 
     aData = Denestify(aRows) 
     If IsArray(aData) Then Output2DArray .Cells(1, 1), aData 
    End With 

End Sub 

Sub XmlHttpRequest(sMethod, sUrl, aSetHeaders, sPayload, sRespHeaders, sRespText) 

    Dim aHeader 

    With CreateObject("MSXML2.ServerXMLHTTP") 
     .SetOption 2, 13056 ' SXH_SERVER_CERT_IGNORE_ALL_SERVER_ERRORS 
     .Open sMethod, sUrl, False 
     For Each aHeader In aSetHeaders 
      .SetRequestHeader aHeader(0), aHeader(1) 
     Next 
     .Send sPayload 
     sRespHeaders = .GetAllResponseHeaders 
     sRespText = .ResponseText 
    End With 

End Sub 

Sub ParseResponse(sPattern, sResponse, aData, Optional bAppend As Boolean = True) 

    Dim oMatch 
    Dim aTmp() 
    Dim sSubMatch 

    If Not (IsArray(aData) And bAppend) Then aData = Array() 
    With CreateObject("VBScript.RegExp") 
     .Global = True 
     .MultiLine = True 
     .Pattern = sPattern 
     For Each oMatch In .Execute(sResponse) 
      If oMatch.SubMatches.Count = 1 Then 
       PushItem aData, oMatch.SubMatches(0) 
      Else 
       aTmp = Array() 
       For Each sSubMatch In oMatch.SubMatches 
        PushItem aTmp, sSubMatch 
       Next 
       PushItem aData, aTmp 
      End If 
     Next 
    End With 

End Sub 

Sub PushItem(aData, vItem, Optional bAppend As Boolean = True) 

    If Not (IsArray(aData) And bAppend) Then aData = Array() 
    ReDim Preserve aData(UBound(aData) + 1) 
    aData(UBound(aData)) = vItem 

End Sub 

Function DecodeHTMLEntities(sText As String) As String 

    Static oHtmlfile As Object 
    Static oDiv As Object 

    If oHtmlfile Is Nothing Then 
     Set oHtmlfile = CreateObject("htmlfile") 
     oHtmlfile.Open 
     Set oDiv = oHtmlfile.createElement("div") 
    End If 
    oDiv.innerHTML = sText 
    DecodeHTMLEntities = oDiv.innerText 

End Function 

Function Denestify(aRows) 

    Dim aData() 
    Dim aItems() 
    Dim i As Long 
    Dim j As Long 

    If UBound(aRows) = -1 Then Exit Function 
    ReDim aData(1 To UBound(aRows) + 1, 1 To 1) 
    For j = 0 To UBound(aRows) 
     aItems = aRows(j) 
     For i = 0 To UBound(aItems) 
      If i + 1 > UBound(aData, 2) Then ReDim Preserve aData(1 To UBound(aRows) + 1, 1 To i + 1) 
      aData(j + 1, i + 1) = aItems(i) 
     Next 
    Next 
    Denestify = aData 

End Function 

Sub Output2DArray(oDstRng As Range, aCells As Variant) 

    With oDstRng 
     .Parent.Select 
     With .Resize(_ 
       UBound(aCells, 1) - LBound(aCells, 1) + 1, _ 
       UBound(aCells, 2) - LBound(aCells, 2) + 1) 
      .NumberFormat = "@" 
      .Value = aCells 
     End With 
    End With 

End Sub 

對我來說，輸出如下：

，這是一樣的網頁結果：

我在下面添加一些變量值，它可能有助於在出現任何問題時進行調試。要觀看sRespHeaders和sRespText的內容，我使用了額外的procedure WriteTextFile from this answer。提取Cookie後

Cache-Control: no-store, no-cache, must-revalidate, post-check=0, pre-check=0 
Date: Sat, 26 Aug 2017 14:24:48 GMT 
Pragma: no-cache 
Transfer-Encoding: chunked 
Content-Type: text/html; charset=UTF-8 
Expires: Thu, 19 Nov 1981 08:52:00 GMT 
Server: Apache 
Set-Cookie: PHPSESSID=rl4gc6nq91tfb34u2inj634u10; path=/ 
Set-Cookie: restrwww4=!hN5+tRTsssR9ii3Yf8b335uDNFxhmd5PNCjvCndeUeIwBxZnB38oHuGc9Nz19debb6vLbW1nYQ+Ncgw=; path=/; Httponly 
X-Cnection: close 

aSetHeaders：

sRespHeaders第一XmlHttpRequest呼叫後（執行WriteTextFile sRespHeaders, "C:\tmp.txt", -1）

有關部分sRespText含有第二XmlHttpRequest呼叫之後與目標數據的表（執行WriteTextFile sRespText, "C:\tmp.htm", -1）：

<table border="0" width="100%"> 
<tr> 
    <th>lp.</th> 
    <th>kod PNA</th> 
    <th>nazwa <br />(firmy lub placówki pocztowej)</th> 
    <th>miejscowość</th> 
    <th>adres</th> 
    <th>województwo</th> 
    <th>powiat</th> 
    <th>gmina</th> 
</tr> 
      <tr> 
      <td>1.</td> 
      <td>20-610</td> 
    <td></td> 
      <td>Lublin</td> 
      <td>     Kajetana Hryniewieckiego        <br /> 
      <i>numery od&nbsp;1&nbsp;do&nbsp;końca&nbsp;obie strony</i> 
      </td> 
      <td>LUBELSKIE</td> 
      <td>Lublin</td> 
      <td>Lublin</td> 
     </tr> 
     <tr> 
      <td>2.</td> 
      <td>20-610</td> 
    <td></td> 
      <td>Lublin</td> 
      <td>     Leszka Czarnego        <br /> 
      <i>numery od&nbsp;1&nbsp;do&nbsp;końca&nbsp;obie strony</i> 
      </td> 
      <td>LUBELSKIE</td> 
      <td>Lublin</td> 
      <td>Lublin</td> 
     </tr> 
     <tr> 
      <td>3.</td> 
      <td>20-610</td> 
    <td></td> 
      <td>Lublin</td> 
      <td>     Mieszka I        <br /> 
      <i>numery od&nbsp;1&nbsp;do&nbsp;końca&nbsp;obie strony</i> 
      </td> 
      <td>LUBELSKIE</td> 
      <td>Lublin</td> 
      <td>Lublin</td> 
     </tr> 
     <tr> 
      <td>4.</td> 
      <td>20-610</td> 
    <td></td> 
      <td>Lublin</td> 
      <td>     Piastowska        <br /> 
      <i>numery od&nbsp;1&nbsp;do&nbsp;końca&nbsp;obie strony</i> 
      </td> 
      <td>LUBELSKIE</td> 
      <td>Lublin</td> 
      <td>Lublin</td> 
     </tr> 
</table> 

aRows解析錶行後：

aRows解析表格單元格後：

aData後Denestify電話：