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

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开发者控制台）：

在Modules> 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

Here's my full working code:

在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