设置身份验证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页面时，我没有找到页面，而是找到了电子邮件和密码的凭据请求。

我已经更改了url，这解决了我认为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与帖子无关，而与GET相关。

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

下面是一个示例POST数据--当您将第一个GET发送到HTML中的登录页面时，可以找到真实性令牌。为此，在get请求之后获取.responseText。然后，您可以使用拆分函数获得如下所示的auth令牌。

<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