How to connect MS Word to microsoft's QnA Maker (VBA)

Question

I am trying to connect MS Word to Microsoft's QnAMaker using VBA to help answer a wide variety of similar questions I receive. My idea is select the question and then have vba query the answer and copy it to the clipboard (templates for replies are different, this way I can select where to output the answer).

Any help is appreciated. Thank you.

(I am using this JSON library: https://github.com/VBA-tools/VBA-JSON)

I have already applied the suggested solutions described in the issue section below: 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

...

I am encountering the following error which I am uncertain how to resolve: "This method cannot be called after the send method has been called".

The error occurs on the line: xmlhttp.send data

Answer 1

The GitHub issue you linked kind of had the answer, but it's not complete. Here's what you do (from the VBA Dev Console in Word):

In Modules > JsonConverter

Go to Private Function json_ParseObject

Add Scripting. to Dictionary in two places:

from:

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

to:

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

and from:

Set json_ParseObject = New Dictionary

to:

Set json_ParseObject = New Scripting.Dictionary

In GetAnswer():

Also change from:

Dim json As Dictionary

to:

Dim json As Scripting.Dictionary

and from:

Dim answer As Dictionary

to:

Dim answer As Scripting.Dictionary

Here's my full working code:

In 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

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