How to set and get JSESSIONID cookie in VBA

问题:

I'm writing a VBA web service client in Excel 2010 using MSXML2.XMLHTTP60 for my Java REST web services hosted on Tomcat 8.5.5.

In VBA, I want to be able to snag the string JSESSIONID=E4E7666024C56427645D65BEB49ADC11 from a response and be able to set it in a subsequent request. (The reason for wanting to do so is that if Excel crashes, it seems that this cookie is lost and the user has to authenticate again. I want to be able to set the last stored session ID for the user, so if the session is still alive on the server, they don't have to re-authenticate in the Excel client.)

I saw some online resources according to which the following will pull the JSESSIONID cookie, but the last line always prints empty:

Dim httpObj As New MSXML2.XMLHTTP60
With httpObj
    .Open "POST", URL, False
    .SetRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.1)"
    .SetRequestHeader "Connection", "keep-alive"
    .Send
End With
Debug.Print "Response header Cookie: " & httpObj.GetResponseHeader("Cookie")  'This should pull the JSESSIONID cookie but is empty

When I print httpObj.GetAllResponseHeaders I do not see any headers that hold JSESSIONID.

In the same resources, the following should set the desired cookie, but it doesn't (I print out the headers of the incoming request on the server and see that my attempt did not override the JSESSIONID value).

httpObj.SetRequestHeader "Cookie", "JSESSIONID=blahblah"

I may be missing the mechanism for how JSESSIONED is transmitted, and how and when VBA pulls it and sets it.

How can this be done? I'd appreciate any pointer in the right direction.

回答1:

Try to use MSXML2.ServerXMLHTTP to get control over cookies. The code below shows how to retrieve and parse cookies, and make request using that cookies:

Option Explicit

Sub Test_ehawaii_gov()

    Dim sUrl, sRespHeaders, sRespText, aSetHeaders, aList

    ' example for https://energy.ehawaii.gov/epd/public/energy-projects-map.html
    ' get cookies
    sUrl = "https://energy.ehawaii.gov/epd/public/energy-projects-map.html"
    XmlHttpRequest "GET", sUrl, Array(), "", sRespHeaders, sRespText
    ParseResponse "^Set-(Cookie): (\S*?=\S*?);[\s\S]*?$", sRespHeaders, aSetHeaders
    ' get projects list
    sUrl = "https://energy.ehawaii.gov/epd/public/energy-projects-list.json?sEcho=2&iColumns=5&sColumns=&iDisplayStart=1&iDisplayLength=0&mDataProp_0=0&mDataProp_1=1&mDataProp_2=2&mDataProp_3=3&mDataProp_4=4&sSearch=&bRegex=false&sSearch_0=&bRegex_0=false&bSearchable_0=true&sSearch_1=&bRegex_1=false&bSearchable_1=true&sSearch_2=&bRegex_2=false&bSearchable_2=true&sSearch_3=&bRegex_3=false&bSearchable_3=true&sSearch_4=&bRegex_4=false&bSearchable_4=true&iSortCol_0=0&sSortDir_0=asc&iSortingCols=1&bSortable_0=true&bSortable_1=true&bSortable_2=true&bSortable_3=true&bSortable_4=true"
    XmlHttpRequest "GET", sUrl, aSetHeaders, "", "", sRespText
    ' parse project names
    ParseResponse "\[""([\s\S]*?)""", sRespText, aList
    Debug.Print Join(aList, vbCrLf)

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)
    Dim oMatch, aTmp, sSubMatch
    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(aList, vItem)
    ReDim Preserve aList(UBound(aList) + 1)
    aList(UBound(aList)) = vItem
End Sub

You can see the result of cookies parsing in Locals window on breakpoint, first element contain nested array, representing JSESSIONID:

Generally the above example scrapes project names from http://energy.ehawaii.gov/epd/public/energy-projects-list.html (question):

Another one example is for https://netforum.avectra.com/eweb/ (question). Just add the below Sub:

Sub Test_avectra_com()

    Dim sUrl, sRespHeaders, sRespText, aSetHeaders

    ' example for https://netforum.avectra.com/eweb/
    sUrl = "https://netforum.avectra.com/eweb/DynamicPage.aspx?Site=NEFAR&WebCode=IndResult&FromSearchControl=Yes"
    XmlHttpRequest "GET", sUrl, Array(), "", sRespHeaders, sRespText
    ParseResponse "^Set-(Cookie): (\S*?=\S*?);[\s\S]*?$", sRespHeaders, aSetHeaders

End Sub

You can also see the cookies in Locals window, either not JSESSIONID, but others showing the method:

Note it's simplified method, it parses all cookies regardless path, domain, Secure or HttpOnly options.

回答2:

While omegastripes posted a great solution, I wanted to share the solution I ended up using.

The original MSXML2.XMLHTTP60 object I used does not support cookies. So instead I used WinHttp.WinHttpRequest.

This requires adding a reference to your code: In VBA IDE go to Tools-->References and make sure that Microsoft WinHTPP.Services version xxx is selected.

Snagging the cookie:

Code that grabs the cookie and stores it (assuming an object httpObj of type WinHttp.WinHttpRequest):

' Get the JESSIONID cookie
Dim strCookie As String
Dim jsessionidCookie As String

strCookie = httpObj.GetResponseHeader("Set-Cookie")     ' --> "JSESSIONID=40DD2DFCAF24A2D64544F55194FCE04E;path=/pamsservices;HttpOnly"
jsessionidCookie = GetJsessionIdCookie(strCookie)       ' Strips to  "JSESSIONID=40DD2DFCAF24A2D64544F55194FCE04E"

'Store JSESSIONID cookie in the cache sheet

Where the procedure GetJsessionIdCookie is:

' Takes a string of the form "JSESSIONID=40DD2DFCAF24A2D64544F55194FCE04E;path=/pamsservices;HttpOnly"
' and returns only the portion "JSESSIONID=40DD2DFCAF24A2D64544F55194FCE04E"
Public Function GetJsessionIdCookie(setCookieStr As String) As String
    'JSESSIONID=40DD2DFCAF24A2D64544F55194FCE04E;path=/pamsservices;HttpOnly

    Dim jsessionidCookie As String

    Dim words() As String
    Dim word As Variant

    words = Split(setCookieStr, ";")
    For Each word In words
        If InStr(1, word, "JSESSIONID") > 0 Then
            jsessionidCookie = word
        End If
    Next word

    GetJsessionIdCookie = jsessionidCookie
End Function

Setting the cookie:

Here's the method that creates an WinHttp.WinHttpRequest object and sets the cookie that was previously stored:

Public Function GetHttpObj(httpMethod As String, uri As String, Optional async As Boolean = False, _
    Optional setJessionId As Boolean = True, _
    Optional contentType As String = "application/xml") As WinHttp.WinHttpRequest
    Dim cacheUtils As New CCacheUtils
    Dim httpObj As New WinHttp.WinHttpRequest
    With httpObj
        .Open httpMethod, uri, async
        .SetRequestHeader "origin", "pamsXL"
        .SetRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.1)"
        .SetRequestHeader "Connection", "keep-alive"
        .SetRequestHeader "Content-type", contentType
        .SetRequestHeader "cache-control", "no-cache"
    End With

    ' --- Pull stored cookie and attach to request ---
    If setJessionId Then
        httpObj.SetRequestHeader "Cookie", cacheUtils.GetCachedValue(wsJsessionidAddr)
    End If

    Set GetHttpObj = httpObj
End Function

Where CCacheUtils is a class I implemented for storing and retrieving cached values such as the JSESSIONID cookie.

回答3:

To get and set cookies on the fly, there is an easiest approach I've discovered lately. Here is how the implementation may be:

Sub GetRequestHeaders()
    Const URL$ = "https://finance.yahoo.com/quote/AAPL?p=AAPL"
    Dim Http As New ServerXMLHTTP60, Html As New HTMLDocument, strCookie$

    With Http
        .Open "GET", URL, False
        .send
        strCookie = .getAllResponseHeaders
        strCookie = Split(Split(strCookie, "Cookie:")(1), ";")(0)
        .Open "GET", URL, False
        .setRequestHeader "Cookie", Trim(strCookie)
        .send
        Html.body.innerHTML = .responseText
    End With

    MsgBox Html.querySelector("#quote-market-notice span").innerText

End Sub