Excel 从VBA访问SurveyMonkey API

我正准备建立一个Excel VBA项目，将个人的调查结果读出到Excel表格中进行一些计算，然后进行PDF报告

但是，我很难部署.NET库（SurveyMonkeyApi）以便在VBA中提供参考

我已经建立了一个VisualStudio项目来进行测试，我可以为特定的VS项目安装它（通过NuGet PM）。但该库在该计算机上不可用于Excel

我已经（在另一台机器上）通过独立的NuGet下载了这些库，它们下载正常，但我不知道如何注册Excel VBA access。除此之外，它还依赖于NewtonsoftJson库（这两种情况下都会自动下载）

---

好建议，谢谢

我认为您需要将其添加到Excel项目的引用中

从功能区中，选择“工具”，然后选择“引用”，然后滚动列表以查找有关SurveyMonkey API的信息

---

我直接用VBA访问SM API。 只需创建对象（“MSXML2.XMLHTTP”），然后发出调用并使用SimpleJSONlib对其进行解析。

---

如果我想访问VB.Net代码，我会将其与ExcelDNA打包以创建一个XLL，并提供一个直接的Excel加载项。

受@sysmod的鼓励，我尝试直接在VBA中执行一些操作。我暂时没有使用JSON，因为我已经有麻烦了。下面给出的结果是“开发人员不活动”，尽管我在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

---

我现在看到了这一点——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月25日VBA代码概述以获取数据 SM文档中介绍了这一点，但我将在VBA中概述这一点。 获取调查详细信息的响应将提供所有调查设置数据。使用 Set oJson=jLib.parse（替换（sResponse，“\r\n”，”） 获取json对象。
设置dictSurvey=oJson（“数据”）
为您提供字典，以便您可以获取dictSurvey（“num_响应”）之类的数据。我认为您知道如何索引到字典对象以获取字段值

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_Responder_list”的响应创建json对象 收集每个响应者的字段，并累积最多100个响应者ID的列表。 然后为该列表“获取响应”

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

并将所有这些值保存在记录集或工作表或其他任何地方

---

希望有帮助。

是的，这是我打算做的，但问题是它没有显示在列表中，因此我无法选择它。此外，如果我进行“后期绑定”，我不确定是否需要在那里引用它，但我如何知道我是否正确地对其进行了重新登录？我将尝试重新命名并更新我的发现。因此，我尝试重新命名库，我认为我使用/tlb开关（生成类型库文件）时成功了。然后，我可以从“引用”对话框中浏览库并选择tlb文件（不是DLL文件），然后在“引用”对话框中获得一个条目。然而，当我尝试用代码访问库时，我失败了，并且查看对象浏览器，我只看到了库的名称，但看到了内容（类等）。对不起，@MatsOlsson，你比我所做的要深刻得多。你必须等待其他人加入。谢谢sysmod，这听起来很鼓舞人心！但是，我根本不习惯使用MSXML2.XMLHTTP对象。除此之外，所有授权和请求的示例都在Phyton中，我很难（失败）转换到VBA或VB.NET。一些代码示例将非常有用。谢谢@sysmod，我非常感谢您的帮助。我来看看这个。再给我几个小时来消化，我会回来找你的！我以为在评论中你的“名字”前面加一个@会提醒你有回复等吗？你今天过得很愉快，@sysmod！我现在让它工作了！即使是一个基本的get_survey_list调用。尽管构建vRequestBody字符串似乎有点复杂！这比我想象的要复杂。JSON是否也有助于构建vRequestBody字符串？或者这仅仅是为了“解包”我收到的回复？不，我在发帖后没有收到Stackoverflow的电子邮件提醒。是否有我应该勾选“有人回复时提醒我”的框？我使用JSONlib中的.toString函数来形成主体。例如函数JKeyValue（sKey作为字符串，vValues作为变量）作为字符串Dim jLib作为新的JSONLib JKeyValue=jLib.toString（sKey）&“&jLib.toString（vValues）Set jLib=Nothing结束函数我需要更多的空间来回复，并且无法将注释格式化为代码，所以我；我将添加另一个答案。您需要修补JSONlib-自从我找到它之后，所有者可能也这么做了：在函数ParseString中更改此：Case“”，“\”，“/”，POB修复lib中的问题22，在parseNumber:parseNumber=CDbl（Value）”中，POB始终是双精度的，而不是Int，不必是长数字的小数点，例如623478675和sub-skipChar，而索引>0和索引我搜索了帮助，发现将鼠标悬停在[surveymonkey]标记上会弹出一个带有“订阅”链接的弹出窗口，通知我使用该标记的新帖子。我试试看。

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