带有 ADFS 的 Excel vba 和 XMLHTTP - 不返回 xml答案

【问题标题】：Excel vba and XMLHTTP with ADFS - not returning xml带有 ADFS 的 Excel vba 和 XMLHTTP - 不返回 xml
【发布时间】：2014-04-07 23:52:15
【问题描述】：

我有一个使用了多年的 Excel 宏，它使用 XMLHttp 调用发布到数据库。代码经过数字签名。

最近发布到的站点启用了 ADFS。现在，我没有获取 xml，而是获取了 ADFS 身份验证表单的内容。由于已经进行了身份验证，因此没有提示输入凭据。我从 Web 浏览器中打开 url，它使用现有的凭据并加载了页面。

我尝试为 url 设置可信设置并允许外部内容，但这没关系。

我错过了什么吗？

我得到的 html 看起来像......

<html><head><title>Working...</title></head><body><form method="POST" name="hiddenform" action="https://isvcci.jttest.com:444/"><input type="hidden" name="wa" value="wsignin1.0" />
...
<noscript><p>Script is disabled. Click Submit to continue.</p><input type="submit" value="Submit" /></noscript></form><script language="javascript">window.setTimeout('document.forms[0].submit()', 0);</script></body></html>

这是vba：

Sub PostXml(strType As String, strAddress As String, objXml As MSXML2.DOMDocument60)
    Dim objHttp As MSXML2.XMLHTTP60, objXmlResponse As MSXML2.DOMDocument60, objNode As MSXML2.IXMLDOMNode
    Dim strText As String
    Set objHttp = New MSXML2.XMLHTTP60

    objHttp.Open "POST", strAddress, False
    objHttp.setRequestHeader "Content-Type", "text/xml; charset=utf-8"

    objHttp.send objXml
    Set objXmlResponse = objHttp.responseXML
    rem responseXML is always empty but responseText has the adfs page <------
    Set objNode = objXmlResponse.SelectSingleNode("root/errorMessage")
    If objNode Is Nothing Then
        MsgBox "Error: Unable to retrieve expected response from the server." + vbCrLf + "The opportunity may not have been updated."
    Else
    ... code for success goes here
    End If
End Sub

感谢您的帮助！

【问题讨论】：

标签： vba excel adfs xmlhttprequest

【解决方案1】：

XMLHttp 不能在 adfs 上工作，所以我改用 InternetExplorer 控件。尽管使用设置表单值的页面可能会更简单，但要返回生成的 xml 是一件麻烦事。生成的 xml 以您在 Web 浏览器中看到的格式返回。我使用一个简单的正则表达式来删除标签之外的破折号。

我对 vba 和 excel 没有那么丰富的经验，所以可能有更好的方法来编写代码，但它可以工作。

Sub PostXml(strType As String, strAddress As String, objXml As MSXML2.DOMDocument60)
    Dim objHttp As MSXML2.XMLHTTP60, objXmlResponse As MSXML2.DOMDocument60, objNode As MSXML2.IXMLDOMNode
    Dim objDoc As MSHTML.HTMLDocument
    Dim strText As String, strHeaders As String, strPostData As String
    Dim MyBrowser As InternetExplorer
    Dim PostData() As Byte
    Dim expr As VBScript_RegExp_55.RegExp
    Dim colMatch As VBScript_RegExp_55.MatchCollection
    Dim vbsMatch As VBScript_RegExp_55.Match
    Dim sMatchString As String

    ' XMLHttp doesn't work with ADFS so browser was used

    Set MyBrowser = New InternetExplorer
    strHeaders = "Content-Type: text/xml; charset=utf-8" & vbCrLf
    PostData = StrConv(objXml.XML, vbFromUnicode)
    MyBrowser.Visible = False
    MyBrowser.navigate strAddress, 0, "", PostData, strHeaders
    Do While MyBrowser.Busy Or MyBrowser.readyState <> 4
    Loop
    Set objDoc = MyBrowser.Document
    strText = objDoc.body.innerText
    Set expr = New VBScript_RegExp_55.RegExp
    expr.Pattern = "(?:\s|&nbsp;|^)(-)(?=\s|\r|\n|$)"
    expr.IgnoreCase = True
    expr.MultiLine = True
    expr.Global = True
    strText = expr.Replace(strText, "")

    Set objXmlResponse = New MSXML2.DOMDocument60
    Set objNode = Nothing
    If objXmlResponse.LoadXML(strText) Then
       Set objNode = objXmlResponse.SelectSingleNode("root/errorMessage")
    'Else
       'MsgBox "Invalid XML " & objXmlResponse.parseError.ErrorCode & "," & objXmlResponse.parseError.reason
    End If
    MyBrowser.Quit
    Set MyBrowser = Nothing

    Rem MsgBox "response =" & vbCrLf & objXmlResponse.XML

    If objNode Is Nothing Then
        MsgBox "Error: Unable to retrieve expected response from the server."
    Else
        strText = objNode.Text
        If strText > "" Then
            MsgBox strText, vbOKOnly, "Error"
        Else
            ' it worked, read the xml here
        End If
    End If
End Sub

【讨论】：