VBA downloading file with login isn't working

Question

I'm trying to download a file from this website, tried a bunch of code i can find and the file is downloaded but shows the html of the login page

Below are 2 versions that I tried. I tried every code snippet I could find on SO and have had no luck so far.

I tried both versions here, they had the same problem but their solution isn't working for me. Vba download file from internet WinHttpReq with login not working

It seems like I'm not getting past the login process. I know that the variables (username, password) are wrong in the code below, but I did try every variable I can find in the source (UniqueUser, UniqueLogin, LoginName, every word they had there) and still no luck.

Some versions of the code error on the SET COOKIE line, others give no errors, the file is downloaded but it's still the html of the login page inside the file

 Sub DownloadFile2(myURL As String)


Dim CurPath As String

CurPath = CurrentProject.Path & "\"
Dim strCookie As String, strResponse As String, _
  strUrl As String
  Dim xobj As Object
  Dim WinHttpReq As Object
  Set xobj = New WinHttp.WinHttpRequest

UN = "hhhhh"
PW = "gggg"

  strUrl = "https://pnds.health.ny.gov/login"
  xobj.Open "POST", strUrl, False
  xobj.SetRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 6.1; WOW64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/33.0.1750.154 Safari/537.36"
  xobj.SetRequestHeader "Content-Type", "application/x-www-form-urlencoded"
  xobj.Send "username=" & UN & "&password=" & PW & "&login=login"
  strResponse = xobj.ResponseText

  strUrl = myURL
  xobj.Open "GET", strUrl, False

  xobj.SetRequestHeader "Connection", "keep-alive"
  xobj.SetRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 6.1; WOW64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/33.0.1750.154 Safari/537.36"
  xobj.Send

  strCookie = xobj.GetResponseHeader("Set-Cookie")
  strResponse = xobj.ResponseBody

 If xobj.Status = 200 Then
    Set oStream = CreateObject("ADODB.Stream")
    oStream.Open
    oStream.Type = 1
    oStream.Write xobj.ResponseBody
    oStream.SaveToFile CurPath & "ValidationDataHFIS.csv", 2 ' 1 = no overwrite, 2 = overwrite
    oStream.Close
End If
End Sub


Sub ddd()

DownloadFile2 ("https://pnds.health.ny.gov/xxxx/xxxx/8")
End Sub

Answer 1

I would make a little recursive function that checks for redirects until there are none left.

Like this:

Option Explicit
Const WinHttpRequestOption_EnableRedirects = 6

Public Function GetRedirect(ByRef oHttp As Object, ByVal strUrl As String) As String
    With oHttp
        .Open "HEAD", strUrl, False
        .Send
    End With

    If oHttp.Status = 301 Or oHttp.Status = 302 Or oHttp.Status = 303 Then
        GetRedirect= GetRedirect(oHttp, oHttp.GetResponseHeader("Location"))
    Else
        GetRedirect= strUrl
    End If
End Function

Sub DownloadFile2(myURL As String)

    Dim CurrentProject
    Dim CurPath As String

    CurPath = CurrentProject.Path & "\"
    Dim strCookie As String, strResponse As String, _
    strUrl As String
    Dim xobj As Object
    Dim WinHttpReq As Object
    Set xobj = CreateObject("WINHTTP.WinHTTPRequest.5.1")
    Dim UN As String
    UN = "hhhhh"
    Dim PW As String
    PW = "gggg"

    strUrl = "https://pnds.health.ny.gov/login"
    With xobj
        .Open "POST", strUrl, False
        .SetRequestHeader "Connection", "keep-alive"
        .SetRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 6.1; WOW64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/33.0.1750.154 Safari/537.36"
        .SetRequestHeader "Content-Type", "application/x-www-form-urlencoded"
        .Send "&username=" & UN & "&password=" & PW & "&login=login"
    End With

    strUrl = GetRedirect(xobj, myURL)

    If xobj.Status = 200 Then
        Dim oStream As Object
        Set oStream = CreateObject("ADODB.Stream")
        With oStream
            .Open
            .Type = 1
            .Write xobj.ResponseBody
            .SaveToFile CurPath & "ValidationDataHFIS.csv", 2 ' 1 = no overwrite, 2 = overwrite
            .Close
        End With
    End If
End Sub

Sub ddd()

    DownloadFile2 ("https://pnds.health.ny.gov/xxxx/xxxx/8")
End Sub

NOTE: This code is untested and would need to be adapted for your use case.