Question

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

是否可能是对象：＆＃34; WinHttp.WinHttpRequest.5.1＆＃34;不适用于这种数据库连接？或者我可能错过了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输出以下信息：

缓存控制：必须重新验证，无缓存，无存储

连接：保持活力

日期：2017年2月24日星期五17:19:54 GMT

内容长度：30633

Content-Type：text / html; charset = ISO-8859-1

服务器：nginx / 1.11.6

WWW-Authenticate：Digest realm =＆＃34; QRDWEB-MNM＆＃34;，domain =＆＃34;＆＃34;，nonce =＆＃34; aB5DLmvuCfok9Zo112jo4S0evgOuXntE＆＃34;，algorithm = MD5，qop =＆＃34; auth＆＃34;，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

当我注释掉包含以下内容的3行代码：oHttp.setRequestHeader，并更改行：设置oHttp = CreateObject（＆＃34; WinHttp.WinHttpRequest.5.1＆＃34;）通过Set oHttp = CreateObject（＆＃ 34; MSXML2.XMLHTTP＆＃34;），出现一个登录名和密码的弹出窗口。如果我填写信息，以下回复是不同的：

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

服务器：nginx / 1.11.6

日期：2017年2月24日星期五18:19:02 GMT

Transfer-Encoding：chunked

连接：保持活力

显示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

我现在正尝试将摘要式身份验证与以下子集合到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

Answer 1

根据Microsoft docs，JScript示例，看起来身份验证需要在同一连接上有两对成功的Open / Send对。第一个告诉HTTP请求对象需要摘要式身份验证，第二个实际执行它。试试这个（未经测试）：

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

VBA setRequestHeader＆＃34;授权＆＃34;失败

编辑1

编辑2

1 个答案: