我正在尝试使用VBA将MS Word连接到微软的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 data上
发布于 2019-04-12 04:04:02
您链接的GitHub问题似乎有答案,但它并不完整。下面是您要执行的操作(从Word中的VBA Dev控制台):
在模块> 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
https://stackoverflow.com/questions/55628303
复制相似问题