VBA загрузка файла с логином не работает - PullRequest
Новая
       31

VBA загрузка файла с логином не работает

2 голосов
/ 11 октября 2019

Я пытаюсь загрузить файл с этого веб-сайта, пробовал кучу кода, который я могу найти, и файл загружается, но показывает HTML-код страницы входа в систему

Ниже приведены 2 версии, которые я пробовал. Я перепробовал каждый фрагмент кода, который смог найти на SO, но пока мне не повезло.

Я попробовал обе версии здесь, у них была одна и та же проблема, но их решение не работает для меня. VBA скачать файл из интернета WinHttpReq с логином не работает

Похоже, я не прошёл процесс входа в систему. Я знаю, что переменные (имя пользователя, пароль) неверны в приведенном ниже коде, но я пробовал каждую переменную, которую я могу найти в источнике (UniqueUser, UniqueLogin, LoginName, каждое слово, которое у них было там), и все еще не повезло.

Некоторые версии ошибки кода в строке SET COOKIE, другие не выдают ошибок, файл загружен, но все равно это HTML-код страницы входа в файл 

 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

1 Ответ

0 голосов
/ 08 ноября 2019

Я бы сделал небольшую рекурсивную функцию, которая проверяет перенаправления, пока не останется ни одного.

Например: 

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= GetResult(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

ПРИМЕЧАНИЕ. Этот код не проверен и его необходимо адаптировать для вашего варианта использования.

...