从 VBA 访问 SurveyMonkey API
Accessing SurveyMonkey API from VBA
我正准备建立一个 Excel VBA 项目，以将个人调查回复读出到 Excel 的表格中进行一些计算，然后生成 PDF 报告。
然而，我很难部署 .NET 库 (SurveyMonkeyApi) 以供 VBA 参考。
我已经建立了一个 VisualStudio 项目来测试这种方式，我可以为那个特定的 VS 项目安装它（通过 NuGet PM）。但是该库不适用于该机器上的 Excel。
我已经（在另一台机器上）通过独立的 NuGet 下载了这些库，它们下载正常，但是我不知道如何注册 Excel VBA 访问权限。最重要的是，它也依赖于 NewtonsoftJson 库（在这两种情况下都会自动下载）。
非常感谢您的建议！
我认为您需要将它添加到您的 Excel 项目的参考文献中。
从功能区，select，工具，然后是参考，然后滚动列表以查找有关 SurveyMonkey API。
的内容
我直接访问 SM API VBA。
只需 CreateObject("MSXML2.XMLHTTP") 然后发出调用并使用 SimpleJsON JSONLib 来解析它。
如果我想访问 VB.Net 代码，我会将其与 ExcelDNA 打包以创建一个 XLL，并提供一个直接的 Excel 插件。
在@sysmod 的鼓励下，我尝试直接在 VBA 中做一些事情。由于我已经有麻烦了，所以我暂时省略了 JSON。结果是 "Developer Inactive"，尽管我在 VB.NET 中有另一个项目，其中相同的密钥和令牌工作正常。
Public Sub GetSMList()
Dim apiKey As String
Dim Token As String
Dim sm As Object
apiKey = "myKey"
Token = "myToken"
Set sm = CreateObject("MSXML2.XMLHTTP.6.0")
With sm
.Open "POST", "https://api.surveymonkey.net/v2/surveys/get_survey_list", False
.setRequestHeader "Authorization", "Bearer " & Token
.setRequestHeader "Content-Type", "application/json"
.send "api_key=" & apiKey
result = .responseText
End With
End Sub
我现在才看到这个 - Whosebug 是否有一项功能可以在添加评论或回答问题时提醒我，以便我回头看看？
这是起始代码：
Option Explicit
Public Const gACCESS_TOKEN As String = "xxxxxxxxxxxxxxxxxxxxxx"
Declare Function GetTickCount Lib "kernel32" () As Long
Declare Sub Sleep Lib "kernel32" (ByVal lngMilliSeconds As Long)
' for a JSON parser see https://code.google.com/p/vba-json/
Public Sub test()
Dim vRequestBody As Variant, sResponse As String, sSurveyID As String
sSurveyID = "1234567890"
vRequestBody = "{""survey_id"":" & """" & sSurveyID & """" _
& ", ""fields"":[""collector_id"", ""url"", ""open"", ""type"", ""name"", ""date_created"", ""date_modified""]" _
& "}"
sResponse = SMAPIRequest("get_collector_list", vRequestBody)
End Sub
Function SMAPIRequest(sRequest As String, vRequestBody As Variant) As String
Const SM_API_URI As String = "https://api.surveymonkey.net/v2/surveys/"
Const SM_API_KEY As String = "yyyyyyyyyyyyyyyyyyyyyyyy"
Dim bDone As Boolean, sMsg As String, sUrl As String, oHttp As Object ' object MSXML2.XMLHTTP
Static lsTickCount As Long
If Len(gACCESS_TOKEN) = 0 Then
Err.Raise 9999, "No Access token"
End If
On Error GoTo OnError
sUrl = SM_API_URI & URLEncode(sRequest) & "?api_key=" & SM_API_KEY
'Debug.Print Now() & " " & sUrl
Application.StatusBar = Now() & " " & sRequest & " " & Left$(vRequestBody, 127)
Set oHttp = CreateObject("MSXML2.XMLHTTP") ' or "MSXML2.ServerXMLHTTP"
Do While Not bDone ' 4.33 offer retry
If GetTickCount() - lsTickCount < 1000 Then ' if less than 1 sec since last call, throttle to avoid sResponse = "<h1>Developer Over Qps</h1>"
Sleep 1000 ' wait 1 second so we don't exceed limit of 2 qps (queries per second)
End If
lsTickCount = GetTickCount()
'Status Retrieves the HTTP status code of the request.
'statusText Retrieves the friendly HTTP status of the request.
'Note The timeout property has a default value of 0.
'If the time-out period expires, the responseText property will be null.
'You should set a time-out value that is slightly longer than the expected response time of the request.
'The timeout property may be set only in the time interval between a call to the open method and the first call to the send method.
RetryPost: ' need to do all these to retry, can't just retry .Send apparently
oHttp.Open "POST", sUrl, False ' False=not async
oHttp.setRequestHeader "Authorization", "bearer " & gACCESS_TOKEN
oHttp.setRequestHeader "Content-Type", "application/json"
oHttp.send CVar(vRequestBody) ' request body needs brackets EVEN around Variant type
'-2146697211 The system cannot locate the resource specified. => no Internet connection
'-2147024809 The parameter is incorrect.
'String would return {"status": 3, "errmsg": "No oJson object could be decoded: line 1 column 0 (char 0)"} ??
'A Workaround would be to use parentheses oHttp.send (str)
'"GET" err -2147024891 Access is denied.
'"POST" Unspecified error = needs URLEncode body? it works with it but
SMAPIRequest = oHttp.ResponseText
'Debug.Print Now() & " " & Len(SMAPIRequest) & " bytes returned"
sMsg = Len(SMAPIRequest) & " bytes returned in " & (GetTickCount() - lsTickCount) / 1000 & " seconds: " & sRequest & " " & Left$(vRequestBody, 127)
If Len(SMAPIRequest) = 0 Then
bDone = MsgBox("No data returned - do you wish to retry?" _
& vbLf & sMsg, vbYesNo, "Retry?") = vbNo
Else
bDone = True ' got reply.
End If
Loop ' Until bdone
Set oHttp = Nothing
GoTo ExitProc
OnError: ' Pass True to ask the user what to do, False to raise to caller
Select Case MsgBox(Err.Description, vbYesNoCancel, "SMAPIRequest")
Case vbYes
Resume RetryPost
Case vbRetry
Resume RetryPost
Case vbNo, vbIgnore
Resume Next
Case vbAbort
End
Case Else
Resume ExitProc ' vbCancel
End Select
ExitProc:
End Function
Public Function URLEncode(StringVal As String, Optional SpaceAsPlus As Boolean = False) As String
Dim StringLen As Long
StringLen = Len(StringVal)
If StringLen > 0 Then
ReDim result(StringLen) As String
Dim i As Long, CharCode As Integer
Dim Char As String, Space As String
If SpaceAsPlus Then Space = "+" Else Space = "%20"
For i = 1 To StringLen
Char = Mid$(StringVal, i, 1)
CharCode = Asc(Char)
Select Case CharCode
Case 97 To 122, 65 To 90, 48 To 57, 45, 46, 95, 126
result(i) = Char
Case 32
result(i) = Space
Case 0 To 15
result(i) = "%0" & Hex(CharCode)
Case Else
result(i) = "%" & Hex(CharCode)
End Select
Next i
URLEncode = Join(result, "")
End If
End Function
编辑 4 月 23 日添加更多代码。
那个我。来自用户表单中的代码。
Set jLib = New JSONLib
vRequestBody = "{"
If Me.txtDaysCreated > "" Then
vRequestBody = vRequestBody & JKeyValue("start_date", Format$(Now() - CDbl(Me.txtDaysCreated), "yyyy-mm-dd")) & ","
End If
If Me.txtTitleContains > "" Then
' title contains "text", case insensitive
vRequestBody = vRequestBody & JKeyValue("title", Me.txtTitleContains) & ","
End If
vRequestBody = vRequestBody _
& JKeyValue("fields", Array("title", "date_created", "date_modified", "num_responses", _
"language_id", "question_count", "preview_url", "analysis_url")) & "}"
'returns in this order: 0=date_modified 1=title 2=num_responses 3=date_created 4=survey_id
' and in date_created descending
sResponse = GetSMAPIResponse("get_survey_list", vRequestBody)
------------------------------------------
Function JKeyValue(sKey As String, vValues As Variant) As String
Dim jLib As New JSONLib
JKeyValue = jLib.toString(sKey) & ":" & jLib.toString(vValues)
Set jLib = Nothing
End Function
编辑 VBA 代码的 25-April 概述以获取数据
这在 SM 文档中有所介绍，但我将在 VBA 中概述它的外观。
对 get_survey_details 的响应为您提供了所有调查设置数据。采用
设置 oJson = jLib.parse(替换(sResponse, "\r\n", " "))
得到一个 json 对象。
设置 dictSurvey = oJson("data")
给你字典，这样你就可以得到像 dictSurvey("num_responses") 这样的数据。我认为您知道如何索引字典对象以获取字段值。
Set collPages = dictSurvey("pages")
为您提供了一组页面。未记录的字段 "position" 为您提供调查中页面的顺序 UI.
For lPage = 1 To collPages.Count
Set dictPage = collPages(lPage)
Set collPageQuestions = dictPage("questions") ' gets you the Qs on this page
For lPageQuestion = 1 To collPageQuestions.Count
Set dictQuestion = collPageQuestions(lPageQuestion) ' gets you one Q
Set collAnswers = dictQuestion("answers") ' gets the QuestionOptions for this Q
For lAnswer = 1 To collAnswers.Count
Set dictAnswer = collAnswers(lAnswer) ' gets you one Question Option
等等等等
然后根据上面给出的响应数量，一次遍历 100 个响应者 - 再次查看 SM 文档，了解如何指定开始和结束日期以随着时间的推移进行增量下载的详细信息。
根据对 "get_respondent_list" 的响应创建一个 json 对象
收集每个受访者的字段并累积最多 100 个受访者 ID 的列表。
然后 "get_responses" 该列表。
Set collResponsesData = oJson("data")
For lResponse = 1 To collResponsesData.Count
If not IsNull(collResponsesData(lResponse)) then
... get fields...
Set collQuestionsAnswered = collResponsesData(lResponse)("questions")
For lQuestion = 1 To collQuestionsAnswered.Count
Set dictQuestion = collQuestionsAnswered(lQuestion)
nQuestion_ID = CDbl(dictQuestion("question_id"))
Set collAnswers = dictQuestion("answers") ' this is a collection of dictionaries
For lAnswer = 1 To collAnswers.Count
On Error Resume Next ' only some of these may be present
nRow = 0: nRow = CDbl(collAnswers(lAnswer)("row"))
nCol = 0: nCol = CDbl(collAnswers(lAnswer)("col"))
nCol_choice = 0: nCol_choice = CDbl(collAnswers(lAnswer)("col_choice"))
sText = "": sText = collAnswers(lAnswer)("text")
nValue = 0: nValue = Val(sText)
On Error GoTo 0
并将所有这些值保存在记录集中或 sheet 或其他任何地方
希望对您有所帮助。
我正准备建立一个 Excel VBA 项目，以将个人调查回复读出到 Excel 的表格中进行一些计算，然后生成 PDF 报告。
然而，我很难部署 .NET 库 (SurveyMonkeyApi) 以供 VBA 参考。
我已经建立了一个 VisualStudio 项目来测试这种方式，我可以为那个特定的 VS 项目安装它（通过 NuGet PM）。但是该库不适用于该机器上的 Excel。
我已经（在另一台机器上）通过独立的 NuGet 下载了这些库，它们下载正常，但是我不知道如何注册 Excel VBA 访问权限。最重要的是，它也依赖于 NewtonsoftJson 库（在这两种情况下都会自动下载）。
非常感谢您的建议！
我认为您需要将它添加到您的 Excel 项目的参考文献中。
从功能区，select，工具，然后是参考，然后滚动列表以查找有关 SurveyMonkey API。
的内容我直接访问 SM API VBA。 只需 CreateObject("MSXML2.XMLHTTP") 然后发出调用并使用 SimpleJsON JSONLib 来解析它。 如果我想访问 VB.Net 代码，我会将其与 ExcelDNA 打包以创建一个 XLL，并提供一个直接的 Excel 插件。
在@sysmod 的鼓励下，我尝试直接在 VBA 中做一些事情。由于我已经有麻烦了，所以我暂时省略了 JSON。结果是 "Developer Inactive"，尽管我在 VB.NET 中有另一个项目，其中相同的密钥和令牌工作正常。
Public Sub GetSMList()
Dim apiKey As String
Dim Token As String
Dim sm As Object
apiKey = "myKey"
Token = "myToken"
Set sm = CreateObject("MSXML2.XMLHTTP.6.0")
With sm
.Open "POST", "https://api.surveymonkey.net/v2/surveys/get_survey_list", False
.setRequestHeader "Authorization", "Bearer " & Token
.setRequestHeader "Content-Type", "application/json"
.send "api_key=" & apiKey
result = .responseText
End With
End Sub
我现在才看到这个 - Whosebug 是否有一项功能可以在添加评论或回答问题时提醒我，以便我回头看看？
这是起始代码：
Option Explicit
Public Const gACCESS_TOKEN As String = "xxxxxxxxxxxxxxxxxxxxxx"
Declare Function GetTickCount Lib "kernel32" () As Long
Declare Sub Sleep Lib "kernel32" (ByVal lngMilliSeconds As Long)
' for a JSON parser see https://code.google.com/p/vba-json/
Public Sub test()
Dim vRequestBody As Variant, sResponse As String, sSurveyID As String
sSurveyID = "1234567890"
vRequestBody = "{""survey_id"":" & """" & sSurveyID & """" _
& ", ""fields"":[""collector_id"", ""url"", ""open"", ""type"", ""name"", ""date_created"", ""date_modified""]" _
& "}"
sResponse = SMAPIRequest("get_collector_list", vRequestBody)
End Sub
Function SMAPIRequest(sRequest As String, vRequestBody As Variant) As String
Const SM_API_URI As String = "https://api.surveymonkey.net/v2/surveys/"
Const SM_API_KEY As String = "yyyyyyyyyyyyyyyyyyyyyyyy"
Dim bDone As Boolean, sMsg As String, sUrl As String, oHttp As Object ' object MSXML2.XMLHTTP
Static lsTickCount As Long
If Len(gACCESS_TOKEN) = 0 Then
Err.Raise 9999, "No Access token"
End If
On Error GoTo OnError
sUrl = SM_API_URI & URLEncode(sRequest) & "?api_key=" & SM_API_KEY
'Debug.Print Now() & " " & sUrl
Application.StatusBar = Now() & " " & sRequest & " " & Left$(vRequestBody, 127)
Set oHttp = CreateObject("MSXML2.XMLHTTP") ' or "MSXML2.ServerXMLHTTP"
Do While Not bDone ' 4.33 offer retry
If GetTickCount() - lsTickCount < 1000 Then ' if less than 1 sec since last call, throttle to avoid sResponse = "<h1>Developer Over Qps</h1>"
Sleep 1000 ' wait 1 second so we don't exceed limit of 2 qps (queries per second)
End If
lsTickCount = GetTickCount()
'Status Retrieves the HTTP status code of the request.
'statusText Retrieves the friendly HTTP status of the request.
'Note The timeout property has a default value of 0.
'If the time-out period expires, the responseText property will be null.
'You should set a time-out value that is slightly longer than the expected response time of the request.
'The timeout property may be set only in the time interval between a call to the open method and the first call to the send method.
RetryPost: ' need to do all these to retry, can't just retry .Send apparently
oHttp.Open "POST", sUrl, False ' False=not async
oHttp.setRequestHeader "Authorization", "bearer " & gACCESS_TOKEN
oHttp.setRequestHeader "Content-Type", "application/json"
oHttp.send CVar(vRequestBody) ' request body needs brackets EVEN around Variant type
'-2146697211 The system cannot locate the resource specified. => no Internet connection
'-2147024809 The parameter is incorrect.
'String would return {"status": 3, "errmsg": "No oJson object could be decoded: line 1 column 0 (char 0)"} ??
'A Workaround would be to use parentheses oHttp.send (str)
'"GET" err -2147024891 Access is denied.
'"POST" Unspecified error = needs URLEncode body? it works with it but
SMAPIRequest = oHttp.ResponseText
'Debug.Print Now() & " " & Len(SMAPIRequest) & " bytes returned"
sMsg = Len(SMAPIRequest) & " bytes returned in " & (GetTickCount() - lsTickCount) / 1000 & " seconds: " & sRequest & " " & Left$(vRequestBody, 127)
If Len(SMAPIRequest) = 0 Then
bDone = MsgBox("No data returned - do you wish to retry?" _
& vbLf & sMsg, vbYesNo, "Retry?") = vbNo
Else
bDone = True ' got reply.
End If
Loop ' Until bdone
Set oHttp = Nothing
GoTo ExitProc
OnError: ' Pass True to ask the user what to do, False to raise to caller
Select Case MsgBox(Err.Description, vbYesNoCancel, "SMAPIRequest")
Case vbYes
Resume RetryPost
Case vbRetry
Resume RetryPost
Case vbNo, vbIgnore
Resume Next
Case vbAbort
End
Case Else
Resume ExitProc ' vbCancel
End Select
ExitProc:
End Function
Public Function URLEncode(StringVal As String, Optional SpaceAsPlus As Boolean = False) As String
Dim StringLen As Long
StringLen = Len(StringVal)
If StringLen > 0 Then
ReDim result(StringLen) As String
Dim i As Long, CharCode As Integer
Dim Char As String, Space As String
If SpaceAsPlus Then Space = "+" Else Space = "%20"
For i = 1 To StringLen
Char = Mid$(StringVal, i, 1)
CharCode = Asc(Char)
Select Case CharCode
Case 97 To 122, 65 To 90, 48 To 57, 45, 46, 95, 126
result(i) = Char
Case 32
result(i) = Space
Case 0 To 15
result(i) = "%0" & Hex(CharCode)
Case Else
result(i) = "%" & Hex(CharCode)
End Select
Next i
URLEncode = Join(result, "")
End If
End Function
编辑 4 月 23 日添加更多代码。
那个我。来自用户表单中的代码。
Set jLib = New JSONLib
vRequestBody = "{"
If Me.txtDaysCreated > "" Then
vRequestBody = vRequestBody & JKeyValue("start_date", Format$(Now() - CDbl(Me.txtDaysCreated), "yyyy-mm-dd")) & ","
End If
If Me.txtTitleContains > "" Then
' title contains "text", case insensitive
vRequestBody = vRequestBody & JKeyValue("title", Me.txtTitleContains) & ","
End If
vRequestBody = vRequestBody _
& JKeyValue("fields", Array("title", "date_created", "date_modified", "num_responses", _
"language_id", "question_count", "preview_url", "analysis_url")) & "}"
'returns in this order: 0=date_modified 1=title 2=num_responses 3=date_created 4=survey_id
' and in date_created descending
sResponse = GetSMAPIResponse("get_survey_list", vRequestBody)
------------------------------------------
Function JKeyValue(sKey As String, vValues As Variant) As String
Dim jLib As New JSONLib
JKeyValue = jLib.toString(sKey) & ":" & jLib.toString(vValues)
Set jLib = Nothing
End Function
编辑 VBA 代码的 25-April 概述以获取数据
这在 SM 文档中有所介绍，但我将在 VBA 中概述它的外观。
对 get_survey_details 的响应为您提供了所有调查设置数据。采用
设置 oJson = jLib.parse(替换(sResponse, "\r\n", " "))
得到一个 json 对象。
设置 dictSurvey = oJson("data")
给你字典，这样你就可以得到像 dictSurvey("num_responses") 这样的数据。我认为您知道如何索引字典对象以获取字段值。
Set collPages = dictSurvey("pages")
为您提供了一组页面。未记录的字段 "position" 为您提供调查中页面的顺序 UI.
For lPage = 1 To collPages.Count
Set dictPage = collPages(lPage)
Set collPageQuestions = dictPage("questions") ' gets you the Qs on this page
For lPageQuestion = 1 To collPageQuestions.Count
Set dictQuestion = collPageQuestions(lPageQuestion) ' gets you one Q
Set collAnswers = dictQuestion("answers") ' gets the QuestionOptions for this Q
For lAnswer = 1 To collAnswers.Count
Set dictAnswer = collAnswers(lAnswer) ' gets you one Question Option
等等等等
然后根据上面给出的响应数量，一次遍历 100 个响应者 - 再次查看 SM 文档，了解如何指定开始和结束日期以随着时间的推移进行增量下载的详细信息。 根据对 "get_respondent_list" 的响应创建一个 json 对象 收集每个受访者的字段并累积最多 100 个受访者 ID 的列表。 然后 "get_responses" 该列表。
Set collResponsesData = oJson("data")
For lResponse = 1 To collResponsesData.Count
If not IsNull(collResponsesData(lResponse)) then
... get fields...
Set collQuestionsAnswered = collResponsesData(lResponse)("questions")
For lQuestion = 1 To collQuestionsAnswered.Count
Set dictQuestion = collQuestionsAnswered(lQuestion)
nQuestion_ID = CDbl(dictQuestion("question_id"))
Set collAnswers = dictQuestion("answers") ' this is a collection of dictionaries
For lAnswer = 1 To collAnswers.Count
On Error Resume Next ' only some of these may be present
nRow = 0: nRow = CDbl(collAnswers(lAnswer)("row"))
nCol = 0: nCol = CDbl(collAnswers(lAnswer)("col"))
nCol_choice = 0: nCol_choice = CDbl(collAnswers(lAnswer)("col_choice"))
sText = "": sText = collAnswers(lAnswer)("text")
nValue = 0: nValue = Val(sText)
On Error GoTo 0
并将所有这些值保存在记录集中或 sheet 或其他任何地方 希望对您有所帮助。