Question

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

我尝试过几件事......首先，我使用了一个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

查看您的代码，在.SetCredentials之后和.Open之前，您似乎错过了.Send来电：

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 & "--"

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

1 个答案: