我正试图用下面的代码连接到一个web数据库，但在vba中实现自动化时似乎不起作用。登录名和密码都很好，因为我可以手动与它们连接。
对象“winhttp.winhttprequest.5.1”是否可能不适用于这种数据库连接？或者我的connect sub中缺少一个参数？对此事的任何帮助都将不胜感激。
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
内容类型：text/html；字符集=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（“msxml2.xmlhttp”）更改行：set ohttp=createobject（“winhttp.winhttprequest.5.1”）时，会出现一个用于登录和密码的弹出窗口。如果我填写这些信息，则以下回答不同：
显示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
我现在尝试将摘要式身份验证与下面的sub集成到vba中，得到了两个可能的结果：第一个结果与使用错误登录信息时的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
最佳答案
根据jscript示例中的Microsoft docs，身份验证似乎需要在同一个连接上有两个成功的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