从VBA访问SurveyMonkey API [英] Accessing SurveyMonkey API from VBA

问题描述

我正在建立一个Excel VBA项目，将个人调查回复读取到Excel中的表单中进行一些计算，然后进行PDF报告。

I am tying to set-up a Excel VBA project to readout individual survey responses into a form in Excel for some calculations and then PDF reporting.

然而，很容易部署.NET库（SurveyMonkeyApi）可供VBA参考。

However I have great difficulty to deploy the .NET library (SurveyMonkeyApi) to be available for reference in VBA.

我已经设置了一个VisualStudio项目来测试这种方式，我可以安装它用于特定的VS项目（通过NuGet PM）。但是该库不能在该机器上提供Excel。

I have set up a VisualStudio project to test that way , and I can install it for that specific VS project (through NuGet PM). But the library is not made available for Excel on that machine.

我已经通过独立的NuGet下载（在另一台机器上）库，他们下载了，但是我在损失如何注册Excel VBA访问。除此之外，它还有一个依赖于NewtonsoftJson库（它们在两种情况下自动下载）。

I have downloaded (on another machine) the libraries through standalone NuGet and they download OK but then I am at loss on how to register for Excel VBA access. On top of it there is a dependency on NewtonsoftJson library too (which downloaded automatically on both occasions).

好的建议赞赏！

推荐答案

StackOverflow有什么功能可以在添加评论或回答问题时提醒我，所以我知道回头看看？

I just saw this now - is there a feature for StackOverflow to alert me when a comment is added or a question answered, so I know to look back?

这是开始的代码：

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

编辑23-APRIL添加更多代码。

EDIT 23-APRIL add more code.

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

---

编辑25-April的VBA代码概述以获取数据

这在SM文档中有所描述，但我将草图在VBA中看起来如何。
对get_survey_details的响应给你所有的调查设置数据。使用
设置oJson = jLib.parse（替换（sResponse，\r\\\
，））
获取一个json对象。

设置dictSurvey = oJson （data）

给你字典，这样你可以得到像dictSurvey（num_responses）这样的数据。我认为你知道如何索引到字典对象以获取字段值。

---

Edit 25-April overview of VBA code to get the data

This is covered in the SM documentation, but I'll sketch how that looks in VBA. the response to get_survey_details gives you all the survey setup data. Use Set oJson = jLib.parse(Replace(sResponse, "\r\n", " ")) to get a json object.
Set dictSurvey = oJson("data")
gives you the dictionary so you can get data like dictSurvey("num_responses"). I take it you know how to index into dictionary objects to get field values.

Set collPages = dictSurvey("pages") 

给您一个页面集合。未记录的字段位置给您调查界面中的页面顺序。

gives you a collection of Pages. The undocumented field "position" gives you the order of pages in the survey 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。

Then given the number of responses from above, loop through the respondents 100 at a time - again see the SM doc for details of how to specify start and end dates to do incremental downloads over time. create a json object from the response to "get_respondent_list" Collect the fields for each respondent and accumulate a list of at most 100 respondent IDs. Then "get_responses" for that list.

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

并将所有这些值保存在记录集或工作表中或任何
希望有帮助。

and save all those values in a recordset or sheet or whatever Hope that helps.

这篇关于从VBA访问SurveyMonkey API的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！