设置身份验证 XMLHTTP 导出 HTML

Question

我正在尝试以下代码，以便能够导出特定的 HTML 页面，但该网站需要凭据。这是我的尝试

Sub NewTest()
Const sURL As String = "https://courses.myexcelonline.com/courses/take/microsoft-teams/lessons/11482643-microsoft-teams-course-overview"
Dim http As MSXML2.XMLHTTP60, html As MSHTML.HTMLDocument

Set http = New MSXML2.XMLHTTP60
Set html = New MSHTML.HTMLDocument

Dim sUser As String, sPass As String
sUser = Application.WorksheetFunction.EncodeURL("myemail")
sPass = Application.WorksheetFunction.EncodeURL("mypass")

Dim postData As String
postData = "user%5Bemail%5D=" & sUser & "&user%5Bpassword%5D=" & sPass

With http
    .Open "POST", sURL, False
    .setRequestHeader "User-Agent", "Mozilla/5.0"
    .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
    .send postData
    html.body.innerHTML = .responseText
    ExportHTML .responseText
End With

Stop
End Sub

Sub ExportHTML(sInput As String)
With CreateObject("ADODB.Stream")
    .Charset = "UTF-8"
    .Open
    .WriteText sInput
    .SaveToFile Environ("USERPROFILE") & "\Desktop\OutputHTML.html", 2
    .Close
End With
End Sub

我不知道我的代码有什么问题。我希望在我的桌面上存储特定的 HTML 页面，但是当我打开 HTML 页面时，我没有找到该页面，但找到了电子邮件和密码的凭据请求。

我更改了网址，这解决了我认为Const sURL As String = "https://courses.myexcelonline.com/users/sign_in" 的问题。但我需要知道如何从站点获取特定的 HTML 页面？

Answer 1

看起来您发送的是“GET”而不是“POST”。

由于您在请求中发送 POST 数据，因此您需要将“GET”更改为“POST”

.Open "Get", sURL, False

到

.Open "POST", sURL, False

编辑： 您提供的 URL 与 POST 无关，而是与 GET 相关。

您需要先向登录页面发送一个 GET 请求，然后向它所在的同一登录 URL 页面发送一个 POST 请求 - https://courses.myexcelonline.com/users/sign_in，然后再向您提供的原始 URL 发送一个 GET 请求，因为那时您已经已登录并可以正确导航到您的 URL。

这是一个示例 POST 数据 - 当您发送第一个 GET 到 HTML 中的登录页面时，可以找到真实性令牌。为此，请在 GET 请求之后获取 .responseText。然后，您可以像这样使用 Split 函数来获取身份验证令牌。

<meta name="csrf-param" content="authenticity_token" />
<meta name="csrf-token" content="ReGa49vTQ0KqSZtje3VerA8q3O9J1RLO7lEU/+q1hccys6S1uXn6UigKiKTjDp2yEFQRpYpziRQLnXifJLxb+Q==" />

Dim authToken As String
authToken = Application.WorksheetFunction.EncodeURL(Split(Split(http.responseText, "csrf-token"" content=""")(1), """")(0))

Dim postData As String
postdata = "utf8=%E2%9C%93&authenticity_token=" & authToken & "&user%5Bemail%5D=" & sUser & "&user%5Bpassword%5D=" & sPass & "&user%5Bremember_me%5D=0"

这是最终代码

Sub NewTest()
Const sURL As String = "https://courses.myexcelonline.com/courses/take/microsoft-teams/lessons/11482643-microsoft-teams-course-overview"
Const sLoginURL As String = "https://courses.myexcelonline.com/users/sign_in"
Dim http As MSXML2.XMLHTTP60, html As MSHTML.HTMLDocument

Set http = New MSXML2.XMLHTTP60
Set html = New MSHTML.HTMLDocument

Dim sUser As String, sPass As String, sAuthToken As String, postData As String
sUser = Application.WorksheetFunction.EncodeURL("myemail")
sPass = Application.WorksheetFunction.EncodeURL("mypass")

'Load Login Page
With http
    .Open "GET", sLoginURL, False
    .setRequestHeader "User-Agent", "Mozilla/5.0"
    .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
    .send
    .WaitForResponse
    html.body.innerHTML = .responseText
End With

'Get Auth Token from HTML
sAuthToken = Application.WorksheetFunction.EncodeURL((Split( (Split(http.body.innerHTML, "csrf-token"" content=""")(1)), """")(0)))

'Construct the POST data that will be sent
postData = "utf8=%E2%9C%93&authenticity_token=" & sAuthToken & "&user%5Bemail%5D=" & sUser & "&user%5Bpassword%5D=" & sPass & "&user%5Bremember_me%5D=0"

'Attempt to login 
With http
    .Open "POST", sLoginURL, False
    .setRequestHeader "User-Agent", "Mozilla/5.0"
    .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
    .send (postData)
    .WaitForResponse
End With

'Add code here to verify if login was successful...

'If successful... navigate to sURL 
With http
    .Open "GET", sURL, False
    .setRequestHeader "User-Agent", "Mozilla/5.0"
    .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
    .send 
    .WaitForResponse
    html.body.innerHTML = .responseText
    ExportHTML .responseText
End With

Stop
End Sub

Sub ExportHTML(sInput As String)
With CreateObject("ADODB.Stream")
    .Charset = "UTF-8"
    .Open
    .WriteText sInput
    .SaveToFile Environ("USERPROFILE") & "\Desktop\OutputHTML.html", 2
    .Close
End With
End Sub
enter code here