Question

我正在尝试使用VBA将MS Word连接到Microsoft的QnAMaker，以帮助回答我收到的各种类似问题。我的想法是选择问题，然后让vba查询答案并将其复制到剪贴板（答复模板不同，这样我可以选择将答案输出到何处）。

感谢您的帮助。谢谢。

（我正在使用此JSON库：https://github.com/VBA-tools/VBA-JSON）

我已经应用了以下问题部分中描述的建议解决方案：https://github.com/VBA-tools/VBA-JSON/issues/68

Sub copyAnswer()

'User Settings
Dim questionWorksheetName As String, questionsColumn As String, 
firstQuestionRow As String, kbHost As String, kbId As String, endpointKey 
As String
Dim str As String

str = Selection.Text

    kbHost = "https://rfp1.azurewebsites.net/********"
    kbId = "********-********-*********"
    endpointKey = "********-********-********"

'Loop through all non-blank cells
Dim answer, score As String
Dim myArray() As String
Dim obj As New DataObject

        answer = GetAnswer(str, kbHost, kbId, endpointKey)

        Call ClipBoard_SetData(answer)
End Sub

Function GetAnswer(question, kbHost, kbId, endpointKey) As String
'HTTP Request Settings
Dim qnaUrl As String
    qnaUrl = kbHost & "/knowledgebases/" & kbId & "/generateAnswer"
Dim contentType As String
    contentType = "application/json"
Dim data As String
    data = "{""question"":""" & question & """}"

'Send Request
Dim xmlhttp As New MSXML2.XMLHTTP60

xmlhttp.Open "POST", qnaUrl, False
    xmlhttp.setRequestHeader "Content-Type", contentType
    xmlhttp.setRequestHeader "Authorization", "EndpointKey " & endpointKey
**xmlhttp.send data**

'Convert response to JSON
Dim json As Scripting.Dictionary

Set json = JsonConverter.ParseJson(xmlhttp.responseText)

Dim answer As Scripting.Dictionary

For Each answer In json("answers")
'Return response
    GetAnswer = answer("answer")
Next

End Function

Private Function json_ParseObject(json_String As String, ByRef json_Index As Long) As Scripting.Dictionary
Dim json_Key As String
Dim json_NextChar As String

Set json_ParseObject = New Scripting.Dictionary
json_SkipSpaces json_String, json_Index

...

我遇到以下错误，不确定如何解决：“调用send方法后无法调用此方法”。

该错误发生在以下行：xmlhttp.send数据

Answer 1

您链接的GitHub问题可以解决，但还不完整。这是您要执行的操作（从Word中的VBA开发控制台）：

在模块中> JsonConverter

转到Private Function json_ParseObject

在两个位置的Scripting.中添加Dictionary：

来自：

Private Function json_ParseObject(json_String As String, ByRef json_Index As Long) As Dictionary

收件人：

Private Function json_ParseObject(json_String As String, ByRef json_Index As Long) As Scripting.Dictionary

和来自：

Set json_ParseObject = New Dictionary

收件人：

Set json_ParseObject = New Scripting.Dictionary

在GetAnswer()中：

也从以下位置更改：

Dim json As Dictionary

收件人：

Dim json As Scripting.Dictionary

和来自：

Dim answer As Dictionary

收件人：

Dim answer As Scripting.Dictionary

这是我完整的工作代码：

在ThisDocument中：

Sub copyAnswer()

'User Settings
Dim kbHost As String, kbId As String, endpointKey As String
Dim str As String

str = "test"

    kbHost = "https:/*********.azurewebsites.net/qnamaker"
    kbId = "***************************"
    endpointKey = "*************************"

'Loop through all non-blank cells
Dim answer, score As String
Dim myArray() As String
    answer = GetAnswer(str, kbHost, kbId, endpointKey)
End Sub

Function GetAnswer(question, kbHost, kbId, endpointKey) As String
    'HTTP Request Settings
    Dim qnaUrl As String
        qnaUrl = kbHost & "/knowledgebases/" & kbId & "/generateAnswer"
    Dim contentType As String
        contentType = "application/json"
    Dim data As String
        data = "{""question"":""" & question & """}"

    'Send Request
    Dim xmlhttp As New MSXML2.XMLHTTP60

    xmlhttp.Open "POST", qnaUrl, False
        xmlhttp.setRequestHeader "Content-Type", contentType
        xmlhttp.setRequestHeader "Authorization", "EndpointKey " & endpointKey
    xmlhttp.send data

    'Convert response to JSON
    Dim json As Scripting.Dictionary
    Set json = JsonConverter.ParseJson(xmlhttp.responseText)

    Dim answer As Scripting.Dictionary

    For Each answer In json("answers")
    'Return response
        GetAnswer = answer("answer")
    Next

End Function

在模块中> JsonConverter

Private Function json_ParseObject(json_String As String, ByRef json_Index As Long) As Scripting.Dictionary
    Dim json_Key As String
    Dim json_NextChar As String

    Set json_ParseObject = New Scripting.Dictionary
    json_SkipSpaces json_String, json_Index
    If VBA.Mid$(json_String, json_Index, 1) <> "{" Then
        Err.Raise 10001, "JSONConverter", json_ParseErrorMessage(json_String, json_Index, "Expecting '{'")
    Else
        json_Index = json_Index + 1

        Do
            json_SkipSpaces json_String, json_Index
            If VBA.Mid$(json_String, json_Index, 1) = "}" Then
                json_Index = json_Index + 1
                Exit Function
            ElseIf VBA.Mid$(json_String, json_Index, 1) = "," Then
                json_Index = json_Index + 1
                json_SkipSpaces json_String, json_Index
            End If

            json_Key = json_ParseKey(json_String, json_Index)
            json_NextChar = json_Peek(json_String, json_Index)
            If json_NextChar = "[" Or json_NextChar = "{" Then
                Set json_ParseObject.Item(json_Key) = json_ParseValue(json_String, json_Index)
            Else
                json_ParseObject.Item(json_Key) = json_ParseValue(json_String, json_Index)
            End If
        Loop
    End If
End Function

如何将MS Word连接到Microsoft的QnA Maker（VBA）

1 个答案:

这是我完整的工作代码：