vba - 如何将 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

...

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

错误发生在以下行:xmlhttp.send data

Answer 1

您链接的 GitHub 问题已经有了答案，但并不完整。您需要执行以下操作(通过 Word 中的 VBA 开发控制台):

在模块中 > JsonConverter

转到私有(private)函数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

这是我的完整工作代码:

在此文档中:

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