Question

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

最近发布的网站启用了ADFS。现在不再获取xml，而是获取ADFS身份验证表单的内容。由于身份验证已经发生，因此无法提示凭据。我通过Web浏览器打开网址，按预期使用现有凭据并加载页面。

我尝试为网址设置可信设置并允许外部内容，但这无关紧要。

我错过了什么吗？

我回来的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

感谢您的帮助！

Answer 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

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

1 个答案: