尝试 PUT 到 HTTPS 站点时出现无效凭据错误

Question

我正在尝试使用 VBA 在 HTTPS 站点上提交文件，但我遇到了身份验证问题。 （查看时，该站点具有文件名的标准字段，带有“浏览”按钮和“提交”按钮。）

我已经尝试了几件事...首先，我使用了一个 InternetExplorer.Application 对象，但我需要填充的元素类型是 file，而且我已经读到这不能通过以下方式直接访问出于安全原因的代码。 （对不起，我没有引用链接...）

下一个建议是使用WinHttp.WinHttpRequest.5.1 对象和PUT 请求。但是，当我这样做时，来自站点的响应是 401，无效的身份验证错误。

当我正常浏览时，我无需输入任何凭据即可访问该站点。我查看了一些关于 HTTPS 标头 here 和 here 的问题，但无法让它们工作。谁能看到我做错了什么？

Dim objHTTP As Object
Dim URL As String
Set objHTTP = CreateObject("WinHttp.WinHttpRequest.5.1")
URL = "https://siteImUploadingTo.domain.com/site"
objHTTP.Open "PUT", URL, False

objHTTP.setRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)"
objHTTP.setRequestHeader "Content-type", "application/x-www-form-urlencoded"
objHTTP.Send ("_fileToPost=" & ThisWorkbook.Path & \filename.PDF&_pagesSelection=1-100")
Debug.Print objHTTP.ResponseText 'returns a 401 invalid credentials error.

Answer 1

查看您的代码，您似乎在.Open 之后和.Send 之前缺少一个.SetCredentials 调用：

objHTTP.SetCredentials username, password, HTTPREQUEST_SETCREDENTIALS_FOR_SERVER

我在我的测试环境中运行了您的代码，并且我还必须设置 WinHttpRequestOption_SslErrorIgnoreFlags 选项才能忽略所有 SSL 错误 (reference)：

objHTTP.Option(WinHttpRequestOption_SslErrorIgnoreFlags) = &H3300 //SslErrorFlag_Ignore_All

最后，我认为您的Send 命令无法实际将文件发布到您的服务器。我建议您使用以下代码，改编自 blog post。

' add a reference to "Microsoft WinHTTP Services, version 5.1"
Public Function PostFile( _
    sUrl As String, sFileName As String, sUsername As String, sPassword As String, _
    Optional bIgnoreAllSslErrors As Boolean = False, Optional bAsync As Boolean _
) As String
    Const HTTPREQUEST_SETCREDENTIALS_FOR_SERVER = 0
    Const STR_BOUNDARY  As String = "3fbd04f5-b1ed-4060-99b9-fca7ff59c113"
    Dim nFile           As Integer
    Dim baBuffer()      As Byte
    Dim sPostData       As String
    Dim browser         As WinHttp.WinHttpRequest

    '--- read file
    nFile = FreeFile
    Open sFileName For Binary Access Read As nFile
    If LOF(nFile) > 0 Then
        ReDim baBuffer(0 To LOF(nFile) - 1) As Byte
        Get nFile, , baBuffer
        sPostData = StrConv(baBuffer, vbUnicode)
    End If
    Close nFile

    '--- prepare body
    sPostData = _
        "--" & STR_BOUNDARY & vbCrLf & _
            "Content-Disposition: form-data; name=""uploadfile""; filename=""" & Mid$(sFileName, InStrRev(sFileName, "\") + 1) & """" & vbCrLf & _
            "Content-Type: application/octet-stream" & vbCrLf & vbCrLf & _
            sPostData & vbCrLf & _
        "--" & STR_BOUNDARY & "--"

    '--- post
    Set browser = New WinHttpRequest
    browser.Open "POST", sUrl, bAsync

    browser.SetCredentials sUsername, sPassword, HTTPREQUEST_SETCREDENTIALS_FOR_SERVER

    If bIgnoreAllSslErrors Then
        ' https://stackoverflow.com/questions/12080824/how-to-ignore-invalid-certificates-with-iwinhttprequest#12081003
        browser.Option(WinHttpRequestOption_SslErrorIgnoreFlags) = &H3300
    End If

    browser.SetRequestHeader "Content-Type", "multipart/form-data; boundary=" & STR_BOUNDARY
    browser.Send pvToByteArray(sPostData)
    If Not bAsync Then
        PostFile = browser.ResponseText
    End If
End Function

Private Function pvToByteArray(sText As String) As Byte()
    pvToByteArray = StrConv(sText, vbFromUnicode)
End Function

如果您需要发送额外的字段，您可以通过修改 sPostData 变量来实现：

sPostData = _
    "--" & STR_BOUNDARY & vbCrLf & _
        "Content-Disposition: form-data; name=""field1""" & vbCrLf & vbCrLf & _
        field1 & vbCrLf & _
    "--" & STR_BOUNDARY & vbCrLf & _
        "Content-Disposition: form-data; name=""field2""" & vbCrLf & vbCrLf & _
        field2 & vbCrLf & _
    "--" & STR_BOUNDARY & vbCrLf & _
        "Content-Disposition: form-data; name=""uploadfile""; filename=""" & Mid$(FileFullPath, InStrRev(FileFullPath, "\") + 1) & """" & vbCrLf & _
        "Content-Type: application/octet-stream" & vbCrLf & vbCrLf & _
        sPostData & vbCrLf & _
    "--" & STR_BOUNDARY & "--"