excel - 从 VBA 访问 SurveyMonkey API

Question

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

但是，我很难部署 .NET 库 (SurveyMonkeyApi) 以供 VBA 中引用。

我已经设置了一个 VisualStudio 项目来测试这种方式，并且我可以为该特定 VS 项目安装它(通过 NuGet PM)。但该库不可用于该计算机上的 Excel。

我已经通过独立的 NuGet 下载了(在另一台计算机上)这些库，它们下载正常，但我不知道如何注册 Excel VBA 访问。除此之外，还依赖于 NewtonsoftJson 库(两次都会自动下载)。

好的建议值得赞赏!

Answer 1

我现在才看到这个 - StackOverflow 是否有一个功能可以在添加评论或回答问题时提醒我，以便我知道要回头看？

这是起始代码:

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

<小时/>

编辑 4 月 25 日的 VBA 代码概述以获取数据

SM 文档对此进行了介绍，但我将在 VBA 中概述它的外观。对 get_survey_details 的响应为您提供所有调查设置数据。使用 设置 oJson = jLib.parse(Replace(sResponse, "\r\n", ""))获取 json 对象。
设置 dictSurvey = oJson("data")
为您提供字典，以便您可以获得像 dictSurvey("num_responses") 这样的数据。我认为您知道如何索引字典对象以获取字段值。

Set collPages = dictSurvey("pages") 

为您提供页面集合。未记录的字段“位置”为您提供调查 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

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