Accessing SurveyMonkey API from VBA

问题:

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.

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

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.

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).

Good advice appreciated!

回答1:

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?

Here is starting code:

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

EDIT 23-APRIL add more code.

the Me. comes from code in a Userform.

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

---

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

etc etc

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.

回答2:

I access the SM API in straight VBA. Just CreateObject("MSXML2.XMLHTTP") then issue calls and use the SimpleJsON JSONLib to parse it. If I wanted to access VB.Net code, I'd package it with ExcelDNA to create a XLL and that gives a straight Excel addin.

回答3:

I would think you would need to add it into the References for your Excel project.

From the Ribbon, select, Tools, then References, then scroll through the list looking for something about SurveyMonkey API.

回答4:

So encouraged by @sysmod I have tried to do something in VBA directly. I have left out the JSON for now as I am already in trouble. The below is giving me "Developer Inactive" as a result, though I have another project in VB.NET where the same key and token works fine.

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