VBA setRequestHeader“授权”失败答案

【问题标题】：VBA setRequestHeader "Authorization" failingVBA setRequestHeader“授权”失败
【发布时间】：2017-07-15 15:34:22
【问题描述】：

我正在尝试使用以下代码连接到 Web 数据库，但在 VBA 中自动化时它似乎不起作用。登录名和密码很好，因为我可以手动连接它们。

对象：“WinHttp.WinHttpRequest.5.1”是否可能不适用于这种数据库连接？或者我是否在我的 Connect 子程序中遗漏了一个参数？非常感谢您对此事的任何帮助。

Sub Connect()

Dim oHttp As Object
Set oHttp = CreateObject("WinHttp.WinHttpRequest.5.1")
Call oHttp.Open("GET", "http://qrdweb/mg/loan/loans.html?show=all", False)

oHttp.setRequestHeader "Content-Type", "application/xml"
oHttp.setRequestHeader "Accept", "application/xml"
oHttp.setRequestHeader "Authorization", "Basic " + Base64Encode("login123" +  ":" + "pass123")


Call oHttp.send

Sheets("Sheet1").Cells(1, 1).Value = oHttp.getAllResponseHeaders
Sheets("Sheet1").Cells(1, 2).Value = oHttp.ResponseText

End Sub

Private Function Base64Encode(sText)
Dim oXML, oNode
Set oXML = CreateObject("Msxml2.DOMDocument.3.0")
Set oNode = oXML.createElement("base64")
oNode.DataType = "bin.base64"
oNode.nodeTypedValue = StringToBinary(sText)


Base64Encode = oNode.Text
Set oNode = Nothing
Set oXML = Nothing
End Function

Private Function StringToBinary(Text)
Const adTypeText = 2
Const adTypeBinary = 1

Dim BinaryStream
Set BinaryStream = CreateObject("ADODB.Stream")

BinaryStream.Type = adTypeText
BinaryStream.Charset = "us-ascii"
BinaryStream.Open
BinaryStream.WriteText Text

'Change stream type To binary
BinaryStream.Position = 0
BinaryStream.Type = adTypeBinary

'Ignore first two bytes - sign of
BinaryStream.Position = 0

StringToBinary = BinaryStream.Read

Set BinaryStream = Nothing
End Function

显示getAllresponseHeaders的oHttp.getAllResponseHeaders输出如下信息：

Cache-Control: must-revalidate,no-cache,no-store

连接：保持活动

日期：格林威治标准时间 2017 年 2 月 24 日星期五 17:19:54

内容长度：30633

内容类型：text/html;charset=ISO-8859-1

服务器：nginx/1.11.6

WWW-Authenticate: Digest realm="QRDWEB-MNM", domain="", nonce="aB5DLmvuCfok9Zo112jo4S0evgOuXntE", algorithm=MD5, qop="auth", stale=true

当显示 ResponseText 的 oHttp.ResponseText 输出以下信息时：

<html>
    <head>
        <meta http-equiv="Content-Type" content="text/html; charset=ISO-8859-1"/>
        <title>Error 401 Server Error</title>
    </head>
    <body>

编辑 1

当我注释掉包含 oHttp.setRequestHeader 的 3 行代码并更改行： Set oHttp = CreateObject("WinHttp.WinHttpRequest.5.1") by Set oHttp = CreateObject("MSXML2.XMLHTTP"), a弹出登录名和密码。如果我填写信息，下面的回答会有所不同：

显示getAllresponseHeaders的oHttp.getAllResponseHeaders输出如下信息：

服务器：nginx/1.11.6

日期：格林威治标准时间 2017 年 2 月 24 日星期五 18:19:02

传输编码：分块

连接：保持活动

当显示 ResponseText 的 oHttp.ResponseText 输出以下信息时：

<html>

    <head>

        <title>M&M - Loan Viewer</title>

        <script language="javascript" type="text/javascript">

            function showTransactionComments(loanId, date, type, commentsTableWidth) {

    //alert(loanId + " " + date + " " + type + " " + commentsTableWidth);
    if (window.ActiveXObject) {
        return;

编辑 2

我现在正在尝试将 Digest Authentication 与以下 sub 集成到 VBA 中，我得到 2 个可能的结果：第一个结果是使用错误的登录信息时出现相同的 401 错误，并且立即返回。但是，当我提供正确的登录信息时，操作超时......可能是什么原因造成的？

Sub digest()
    Dim http As New WinHttpRequest
    Dim strResponse As String

    Set http = New WinHttpRequest

    http.Open "GET", "http://qrdweb/mg/loan/loans.html?show=all", False
    http.SetCredentials "login123", "pass123", HTTPREQUEST_SETCREDENTIALS_FOR_SERVER
    http.send

    Sheets("Sheet1").Cells(1, 1).Value = http.getAllResponseHeaders
    Sheets("Sheet1").Cells(1, 2).Value = http.ResponseText

    http.Open "PROPFIND", "http://qrdweb/mg/loan/loans.html?show=all", False
    http.send

End Sub

【问题讨论】：

在我看来，服务器需要摘要式身份验证 (WWW-Authenticate: Digest)。您提供的是服务器可能不愿意接受的基本身份验证。你试过在你的 VBA 代码中使用 Digest 吗？我找到了this link，它看起来很有用。
您好，感谢您的指导。我没有摘要身份验证的经验。我正在研究这个话题。
连接更新：我目前正在尝试一种新的登录形式（见下文），我得到了 2 个可能的结果：第一个结果是使用错误的登录信息时出现相同的 401 错误，返回是即时。但是，当我提供正确的登录信息时，操作会超时...可能是什么原因造成的？
代码：Sub digest() Dim http As New WinHttpRequest Dim strResponse As String Set http = New WinHttpRequest http.Open "GET", "qrdweb/mg/loan/loans.html?show=all", False http.SetCredentials "login123", " Pass123", HTTPREQUEST_SETCREDENTIALS_FOR_SERVER http.send End Sub
好的我已经更新了Edit2下的主线程

标签： vba excel http msxml winhttp

【解决方案1】：

根据 JScript 示例 Microsoft docs，看起来身份验证需要同一连接上的两个连续的 Open/Send 对。第一个告诉 HTTP 请求对象需要 Digest 身份验证，第二个实际执行此操作。试试这个（未测试）：

Sub digest()
    Dim http As WinHttpRequest      ' *** Not "New" - you do it below
    Dim strResponse As String

    Set http = New WinHttpRequest

    http.Open "GET", "http://qrdweb/mg/loan/loans.html?show=all", False
    http.Send   ' *** Try it without authentication first

    if http.Status <> 401 then Exit Sub     ' *** Or do something else

    http.Open "GET", "http://qrdweb/mg/loan/loans.html?show=all", False
        ' *** Another Open, same as the JScript example

    http.SetCredentials "login123", "pass123", HTTPREQUEST_SETCREDENTIALS_FOR_SERVER
    http.Send

    MsgBox CStr(http.Status) & ": " & http.StatusText ' *** Just to check

    Sheets("Sheet1").Cells(1, 1).Value = http.getAllResponseHeaders
    Sheets("Sheet1").Cells(1, 2).Value = http.ResponseText

    ' *** Not sure what these two lines are for --- I have commented them out
    'http.Open "PROPFIND", "http://qrdweb/mg/loan/loans.html?show=all", False
    'http.send

End Sub

【讨论】：