问题描述
我正在建立一个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 whateverHope that helps.
这篇关于从VBA访问SurveyMonkey API的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持！