How to use appIE.Document.Body.innerHTML - excel

So I'm trying to retrieve the latitude and longitude of a given postal code, and am trying to use VBA to place this into an excel worksheet. My code is as follows:
Private appIE As Object
Function GeoCode(sLocationData As String) As String
'//Dont want to open and close all day long - make once use many
If appIE Is Nothing Then
CreateIEApp
'// Creates a new IE App
'// if = nothing now then there was an error
If appIE Is Nothing Then
GeoCode = "Sorry could not launch IE"
Exit Function
Else
'// do nothing
End If
Else
'// do nothing
End If
'//clearing up input data
'sLocationData = Replace(sLocationData, ",", " ")
sLocationData = Replace(sLocationData, " ", "+")
sLocationData = Trim(sLocationData)
'//Build URL for Query
sLocationData = "http://maps.google.com/maps/geo?q=%20_" & sLocationData
'// go to the google web service and get the raw CSV data
'// CAUSES PROBLEM AS SPECIFIED BELOW
appIE.Navigate sLocationData
Do While appIE.Busy
Application.StatusBar = "Contacting Google Maps API..."
Loop
Application.StatusBar = False
On Error Resume Next
'// Parsing
GeoCode = appIE.Document.Body.innerHTML
GeoCode = Mid(GeoCode, InStr(GeoCode, ",") + 1, InStr(GeoCode, "/") - InStr(GeoCode, ",") - 2)
appIE = Nothing
End Function
The Google Maps API then returns a JSON formatted value, as per this link:
http://maps.google.com/maps/geo?q=%20_400012
I then attempt to retrieve this value using
appIE.Document.Body.innerHTML,
and parsing that value for the data I want. However, the moment the code hits appIE.Navigate sLocationData,
I'm prompted to save a file called "geo". When saved and opened as a .txt file, I get the exact same JSON formatted value, but I need the values within my worksheet itself.
Is there a way to do this?
Thanks in advance!

That link didn't work for me in Firefox - response 610. If I remove the space and the underscore, it works. I don't know why IE wants to download, probably some setting that tells it to always download JSON rather than render it. In any case, consider using MSXML's http request rather than automating IE.
Set a reference to Microsoft XML, v6.0 or similar (VBE - Tools - References).
Function GeoCode(sLocData As String) As String
Dim xHttp As MSXML2.XMLHTTP
Dim sResponse As String
Dim lStart As Long, lEnd As Long
Const sURL As String = "http://maps.google.com/maps/geo?q="
Const sCOOR As String = "coordinates"": " 'substring that we'll look for later
'send the http request
Set xHttp = New MSXML2.XMLHTTP
xHttp.Open "GET", sURL & sLocData
xHttp.send
'wait until it's done
Do
DoEvents
Loop Until xHttp.readyState = 4
'get the returned data
sResponse = xHttp.responseText
'find the starting and ending points of the substring
lStart = InStr(1, sResponse, sCOOR)
lEnd = InStr(lStart, sResponse, "]")
GeoCode = Mid$(sResponse, lStart + Len(sCOOR), lEnd - lStart - Len(sCOOR) + 1)
End Function
Sub Test()
Dim sTest As String
sTest = GeoCode("400012")
Debug.Assert sTest = "[ 103.9041520, 1.3222160, 0 ]"
End Sub

Related

How to find and format an address from a cell using a VBA function and Google Places API?

To make sure an address is always formatted the same way (which I will use in another VBA Sub), I'm trying to use the Google Places API in combination with a created VBA function.
The query works in the browser but not from the created function.
The working API (temporary API-key added) with a random address: https://maps.googleapis.com/maps/api/place/findplacefromtext/json?fields=formatted_address%2Cname%2Crating%2Copening_hours%2Cgeometry&input=Coendersweg%202&inputtype=textquery&key=API_KEY
It gives "Formatted_Address" which I'd like to show up as the result of the function.
Example result of random address:
Coendersweg 2, 9722GE Groningen / [Streetname number, Zipcode City]
If it's possible to make resulting address have the zip code (9722 GE) formatted as "9722GE" and the country ", Nederland" not show up that would be even better.
VBA code I have so far:
Function FindAddress(address, APIKEY)
Dim strURL As String
strURL = "https://maps.googleapis.com/maps/api/place/findplacefromtext/" & _
"json?fields=formatted_address%2Cname%2Crating%2Copening_hours%2Cgeometry&input=" _
& address & "&inputtype=textquery&key=" & APIKEY
Set httpReq = CreateObject("MSXML2.XMLHTTP")
With httpReq
.Open "GET", strURL, False
.Send
End With
Dim Response As String
Response = httpReq.ResponseText
Dim parsed As Dictionary
Set parsed = JsonConverter.ParseJson(Response)
Dim FoundAddress As String
FoundAddress = (formatted_address)
FindAddress = FoundAddress
I've the "JsonConverter.bas" from https://github.com/VBA-tools/VBA-JSON as a module inside my VBA.
Most of the code is borrowed from the following YouTube video. I made some tweaks to work with Google Places API instead of Google Directions API:
https://www.youtube.com/watch?v=_P2lj4yHNu4.
Here's a method that will return the formatted_address field. You can return other fields if you prefer -- the modifications should be obvious.
Note that I used early binding, but you can use late binding if you prefer.
Run against your input, => Coendersweg 2, 9722 GE Groningen, Netherlands
Option Explicit
Function getAddress(S As String)
Const API As String = "key=YOUR_API_KEY"
Const sURL1 As String = "https://maps.googleapis.com/maps/api/place/findplacefromtext/json?fields=formatted_address"
Const sURL2 As String = "input="
Const sURL3 As String = "inputtype=textquery"
Dim sAddr As String
Dim sURL() As String
Dim sLocation As String
Dim xhrRequest As XMLHTTP60
Dim strJSON As String, JSON As Object
sAddr = Replace(S, " ", "%20")
'Many ways to create the URL to send
ReDim sURL(3)
sURL(0) = sURL1
sURL(1) = sURL2 & sAddr
sURL(2) = sURL3
sURL(3) = API
Set xhrRequest = New XMLHTTP60
With xhrRequest
.Open "Get", Join(sURL, "&"), False
.Send
strJSON = .ResponseText
End With
Set JSON = ParseJson(strJSON)
If Not JSON("status") = "OK" Then
MsgBox "Status message: " & JSON("status")
Exit Function
End If
'might need to check if more than one candidate is returned
getAddress = JSON("candidates")(1)("formatted_address")
End Function
If you want to have the format different from what is shown, I suggest you use the Places api to return the place_id. You can then feed that value into the Place Details to return the address_components and format the address however you prefer.

Scrape economic data from investing website

I am working on a code to get data from : https://www.investing.com/economic-calendar/core-durable-goods-orders-59
I have got the code for getting this via httprequest: but looking to change this to work for the economic data (link above) is there any way I can get the same for the economic indicators??
code below:
Option Explicit
Sub Export_Table()
'Html Objects---------------------------------------'
Dim htmlDoc As MSHTML.HTMLDocument
Dim htmlBody As MSHTML.htmlBody
Dim ieTable As MSHTML.HTMLTable
Dim Element As MSHTML.HTMLElementCollection
'Workbooks, Worksheets, Ranges, LastRow, Incrementers ----------------'
Dim wb As Workbook
Dim Table As Worksheet
Dim i As Long
Set wb = ThisWorkbook
Set Table = wb.Worksheets("Sheet1")
'-------------------------------------------'
Dim xmlHttpRequest As New MSXML2.XMLHTTP60 '
'-------------------------------------------'
i = 2
'Web Request --------------------------------------------------------------------------'
With xmlHttpRequest
.Open "POST", "https://www.investing.com/instruments/HistoricalDataAjax", False
.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
.setRequestHeader "X-Requested-With", "XMLHttpRequest"
.send "curr_id=951681&smlID=1695217&header=CLNX+Historical+Data&st_date=01%2F01%2F2017&end_date=03%2F01%2F2019&interval_sec=Monthly&sort_col=date&sort_ord=DESC&action=historical_data"
If .Status = 200 Then
Set htmlDoc = CreateHTMLDoc
Set htmlBody = htmlDoc.body
htmlBody.innerHTML = xmlHttpRequest.responseText
Set ieTable = htmlDoc.getElementById("curr_table")
For Each Element In ieTable.getElementsByTagName("tr")
Table.Cells(i, 1) = Element.Children(0).innerText
Table.Cells(i, 2) = Element.Children(1).innerText
Table.Cells(i, 3) = Element.Children(2).innerText
Table.Cells(i, 4) = Element.Children(3).innerText
Table.Cells(i, 5) = Element.Children(4).innerText
Table.Cells(i, 6) = Element.Children(5).innerText
Table.Cells(i, 7) = Element.Children(6).innerText
i = i + 1
DoEvents: Next Element
End If
End With
Set xmlHttpRequest = Nothing
Set htmlDoc = Nothing
Set htmlBody = Nothing
Set ieTable = Nothing
Set Element = Nothing
End Sub
Public Function CreateHTMLDoc() As MSHTML.HTMLDocument
Set CreateHTMLDoc = CreateObject("htmlfile")
End Function
I have used the excel tool Power Query for this very thing. It is also called Get & Transform Data. I don't like using vba for doing this type of thing.
To make it work:
In Excel Go to Data>Get Data>From Other Sources>From Web.
Enter the URL
Wait for the webpage to load and then pick the table that you want.
This website took awhile to load, but it did work for me.
Choose "Load" which goes directly to the sheet, or "Transform Data" to manipulate the data in Power Query. There are many options in power query such as split columns, filter data, Calculate Columns and ...
I would avoid the overhead of setting up a permanent connection and simply continue using XHR. With the data > from web, you cannot grab more rows than are present on the initial landing. If however you go with XHR, you can issue POST requests to get more data. The code below utilizes a loop to retrieve additional results beyond the immediate visible on the page.
When you press the Show more link there is a POST request for an additional 6 rows which uses the latest date from the current set of results as part of the POST body. The response returned is JSON. Rather than bringing in a JSON parser, given the standard nature of the JSON, and that I am already using regex to clean the date format in column 1 to put in the POST body, I use two simple regexes to extract the html for the next results table from the response, and to check whether there are more results.
The format of the JSON is:
{
"historyRows": "<tr>…..</tr>",
"hasMoreHistory": "1"
}
Or
{
"historyRows": "<tr>…..</tr>",
"hasMoreHistory": false
}
So, I do some cleaning of the extracted html in order to not confuse the html parser within MSHTML. Furthermore, I add in an id to identify the table I have constructed, so I can continue to use an id css selector (#) list within my UpdateDateResults function.
I initially oversize an array to store each retrieved table which I update ByRef. I loop requesting more results until either there are no more results, there is an error parsing the maximum date from the last retrieved table column 1, or until my specified earliest date for data retrieval falls within the date range of the latest returned table.
Finally, I write the results array out to the sheet in one go.
N.B. You can target the table by its id. It looks like the number at the end of the id could be the same as for the goods url, lending itself to generalizing the code below to work for other goods.
VBA:
Option Explicit
Public Sub GetInvestingInfo()
'tools > references > Microsoft HTML Object Library
Dim html As MSHTML.HTMLDocument, xhr As Object
Const STARTDATE As Date = "2019-11-25" 'Adjust as required. DateAdd("yyyy", -2, Date) 2 years back. This means may have some earlier months in _
batch that spans the start date but won't issue an additional request after this
Set xhr = CreateObject("MSXML2.XMLHTTP")
Set html = New MSHTML.HTMLDocument
With xhr
.Open "GET", "https://www.investing.com/economic-calendar/core-durable-goods-orders-59", False
.setRequestHeader "User-Agent", "Safari/537.36"
.send
html.body.innerHTML = .responseText
End With
Dim firstTable As Boolean, r As Long, results() As Variant
ReDim results(1 To 100000, 1 To 5)
'process initial table and update results, get cleaned date needed for request for more results
firstTable = True
Dim latestDate As String
UpdateDateResults latestDate, results, firstTable, r, html
Dim re As Object, maxDate As String, hasMoreHistory As Boolean, s As String
Set re = CreateObject("VBScript.RegExp")
With re
.Global = True
.MultiLine = False
End With
maxDate = cleanedDate(latestDate, re)
hasMoreHistory = True
Dim errorDate As Date
errorDate = DateAdd("d", 1, Date)
Do While maxDate >= STARTDATE And maxDate < errorDate 'break loop using pre-defined earliest date, error with date conversion, or when no more rows found
Application.Wait (Now + TimeSerial(0, 0, 1)) 'Pause
s = GetMoreRows(xhr, Format$(maxDate, "YYYY-MM-DD")) 'max a POST request for more data
re.Pattern = "hasMoreHistory"":(""?.*?""?)}" 'Check if there are more rows still available. "1" for yes, false for no
hasMoreHistory = (re.Execute(s)(0).submatches(0) <> False)
If Not hasMoreHistory Then Exit Do
re.Pattern = "historyRows"":""(.*)"","
html.body.innerHTML = "<table id=""me"">" & Replace$(re.Execute(s)(0).submatches(0), "\/", "/") & "</table>" 'fix html and feed into html variable
UpdateDateResults latestDate, results, firstTable, r, html
maxDate = cleanedDate(latestDate, re) 'convert value retrieved from last row in date column of table to an actual date
Loop
With ActiveSheet
.Cells.ClearContents
.Cells(1, 1).Resize(r, 5) = results 'Don't bother to resize results as clear all cells before write ou
End With
End Sub
Public Sub UpdateDateResults(ByRef latestDate As String, ByRef results() As Variant, ByRef firstTable As Boolean, ByRef r As Long, ByVal html As MSHTML.HTMLDocument)
Dim table As MSHTML.HTMLTable 'return latest date from function
Set table = html.querySelector("#eventHistoryTable59, #me")
latestDate = table.Rows(table.Rows.Length - 1).Children(0).innerText
Dim i As Long, n As Long, j As Long
n = IIf(firstTable, 0, 1)
For i = n To table.Rows.Length - 1
r = r + 1
For j = 0 To table.Rows(i).Children.Length - 2
results(r, j + 1) = table.Rows(i).Children(j).innerText
Next
Next
firstTable = False
End Sub
Public Function cleanedDate(ByVal dirtyString As String, ByVal re As Object) As Date
re.Pattern = "(^[A-Z][a-z]{2}).*(\d{2}),.(\d{4})(.*)"
On Error GoTo errhand:
If re.test(dirtyString) Then
cleanedDate = CDate(re.Replace(dirtyString, "$2" & Chr$(32) & "$1" & Chr$(32) & "$3"))
Exit Function
End If
errhand:
cleanedDate = DateAdd("d", 1, Date)
End Function
Public Function GetMoreRows(ByVal xhr As Object, ByVal dateStamp As String) As String
With xhr
.Open "POST", "https://www.investing.com/economic-calendar/more-history", False
.setRequestHeader "User-Agent", "Safari/537.36"
.setRequestHeader "x-requested-with", "XMLHttpRequest"
.setRequestHeader "content-type", "application/x-www-form-urlencoded"
.send "eventID=430865&event_attr_ID=59&event_timestamp=" & dateStamp & "+" & Application.WorksheetFunction.EncodeURL("12:30:00") & "&is_speech=0"
GetMoreRows = .responseText
End With
End Function
Regexes (without the double " escaping for VBA):
hasMoreHistory":("?.*?"?)}
historyRows":"(.*)",

VBA - web scraping can not find correct GET request

My question is related to other question VBA - web scraping can not get HTMLElement innerText. I have a similar problem
Website URL - https://www.hnb.hr/en/core-functions/monetary-policy/exchange-rate-list/exchange-rate-list
I need to get the date of currency reference and the selected values. The problem is that I can not find a correct GET request where these values are finally generated. I've found that it is related to the POST request:
POST /en/core-functions/monetary-policy/exchange-rate-list/exchange-rate-list?p_p_id=tecajnalistacontroller_WAR_hnbtecajnalistaportlet&p_p_lifecycle=2&p_p_state=normal&p_p_mode=view&p_p_resource_id=getTecajnaAjaxDataURL&p_p_cacheability=cacheLevelPage&p_p_col_id=column-2&p_p_col_count=2 HTTP/1.1
I would like to use a technique with getting by id, class or tag - whatever but again, provided GET URL request is too quick to retrieve the required info
XMLHTTP request and API:
I would use their API as shown below. I have some helper functions to aid with parsing the response. In GetDict function you can set the currencies you are interested in. In function GetRate you can specify the rate you are interested in. If you don't specify, it defaults to "median_rate".
Calling the API:
To get the rates for a particular date, make a[n] HTTP call to the
following URL:
http://hnbex.eu/api/v1/rates/daily/?date=YYYY-MM-DD
The date parameter is optional. If not set, the current date (today)
is used.
You can parse the JSON response with a JSON parser but I found it simpler to go with using Split to grab the required info from the JSON string. If you are familiar with JSON I will happily update with a JSON parsing example.
Option Explicit
Public Sub GetInfo()
'http://hnbex.eu/api/v1/
Dim strJSON As String, http As Object, json As Object
Const URL As String = "http://hnbex.eu/api/v1/rates/daily/"
Set http = CreateObject("MSXML2.XMLHTTP")
With http
.Open "GET", URL, False
.send
strJSON = .responseText
End With
'Set json = JsonConverter.ParseJson(strJSON) '<== You could parse the JSON using a JSON parse such as [JSONConverter][1]
Dim currencyDict As Object
Set currencyDict = GetDict
Dim key As Variant, dictKeys As Variant, result As Variant
For Each key In currencyDict.keys
result = GetRate(strJSON, key)
If Not IsError(result) Then currencyDict(key) = result
result = vbNullString
Next key
PrintDictionary currencyDict
End Sub
Public Function GetDict() As Object '<== You could adapt to pass currencies as string arguments to the function. Or even a string array.
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
dict.Add "EUR", vbNullString
dict.Add "CZK", vbNullString
dict.Add "HRK", vbNullString
dict.Add "HUF", vbNullString
dict.Add "PLN", vbNullString
dict.Add "RON", vbNullString
dict.Add "RSD", vbNullString
Set GetDict = dict
End Function
Public Function GetRate(ByVal json As String, ByVal key As Variant, Optional ByVal rate As String = "median_rate") As Variant
Dim arr() As String, tempString As String
On Error GoTo Errhand
arr = Split(json, """currency_code"": " & Chr$(34) & key & Chr$(34))
tempString = arr(1)
tempString = Split(arr(1), Chr$(34) & rate & Chr$(34) & ":")(1)
tempString = Split(tempString, ",")(0)
GetRate = tempString
Exit Function
Errhand:
GetRate = CVErr(xlErrNA)
End Function
Public Sub PrintDictionary(ByVal dict As Object)
Dim key As Variant
For Each key In dict.keys
Debug.Print key & " : " & dict(key)
Next
End Sub
Internet Explorer:
You can use an loop with explicit wait for element to be present on page (or populated)
Option Explicit
Public Sub GetInfo()
Dim IE As New InternetExplorer, t As Date, hTable As HTMLTable, clipboard As Object
Const WAIT_TIME_SECS As Long = 5
t = Timer
With IE
.Visible = True
.navigate "https://www.hnb.hr/en/core-functions/monetary-policy/exchange-rate-list/exchange-rate-list"
While .Busy Or .readyState < 4: DoEvents: Wend
Do
DoEvents
On Error Resume Next
Set hTable = .document.getElementById("records_table")
On Error GoTo 0
If Timer - t > WAIT_TIME_SECS Then Exit Do
Loop While hTable Is Nothing
If hTable Is Nothing Then
.Quit
Exit Sub
End If
Set clipboard = GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
clipboard.SetText hTable.outerHTML
clipboard.PutInClipboard
ThisWorkbook.Worksheets("Sheet1").Cells(1, 1).PasteSpecial
.Quit '<== Remember to quit application
End With
End Sub

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

Getting HTML Source with Excel-VBA

I would like to direct an excel VBA form to certain URLs, get the HTML source and store that resource in a string. Is this possible, and if so, how do I do it?
Yes. One way to do it is to use the MSXML DLL - and to do that you need to add a reference to the Microsoft XML library via Tools->References.
Here's some code that displays the content of a given URL:
Public Sub ShowHTML(ByVal strURL)
On Error GoTo ErrorHandler
Dim strError As String
strError = ""
Dim oXMLHTTP As MSXML2.XMLHTTP
Set oXMLHTTP = New MSXML2.XMLHTTP
Dim strResponse As String
strResponse = ""
With oXMLHTTP
.Open "GET", strURL, False
.send ""
If .Status <> 200 Then
strError = .statusText
GoTo CleanUpAndExit
Else
If .getResponseHeader("Content-type") <> "text/html" Then
strError = "Not an HTML file"
GoTo CleanUpAndExit
Else
strResponse = .responseText
End If
End If
End With
CleanUpAndExit:
On Error Resume Next ' Avoid recursive call to error handler
' Clean up code goes here
Set oXMLHTTP = Nothing
If Len(strError) > 0 Then ' Report any error
MsgBox strError
Else
MsgBox strResponse
End If
Exit Sub
ErrorHandler:
strError = Err.Description
Resume CleanUpAndExit
End Sub
Just an addition to the above response. The question was how to get the HTML source which the stated answer does not actually provide.
Compare the contents of oXMLHTTP.responseText with the source code in a browser for URL "http://finance.yahoo.com/q/op?s=T+Options". They do not match and even the returned values are different. (This should be executed after hours to avoid changes during the trading day.)
If I find a way to perform this task the basic code will be posted.
Compact getHTTP function
Below is a compact & generic function that will return HTTP response from a specified URL to, for example:
return the HTML Source of a web page,
JSON response from an API URL,
parse a text file at a URL, etc.
This does not require any VBA References since MSXML2 is used as a late-bound object.
Public Function getHTTP(ByVal url As String) As String
With CreateObject("MSXML2.XMLHTTP")
.Open "GET", url, False: .Send
getHTTP = StrConv(.responseBody, vbUnicode)
End With
End Function
Note that this basic function has no validation or error handling, as those are the parts that can vary considerably depending on which URL you're hitting.
If desired, check the value of .Status after the .Send) to check for success codes like 0 or 200, and also you can setup an error trap with On Error Goto... (never Resume Next!)
Example Usage:
This procedure scrapes this Stack Overflow page for the current score of this question.
Sub demo_getVoteCount()
Const answerID$ = 2522760
Const url_SO = "https://stackoverflow.com/a/" & answerID
Dim html As String, startPos As Long, voteCount As Variant
html = getHTTP(url_SO) 'get html from url
startPos = InStr(html, "answerid=""" & answerID) 'locate this answer
startPos = InStr(startPos, html, "vote-count-post") 'locate vote count
startPos = InStr(startPos, html, ">") + 1 'locate value
voteCount=Mid(html,startPos,InStr(startPos,html,"<")-startPos) 'extract score
MsgBox "Answer #" & answerID & " has a score of " & voteCount & "."
End Sub
Of course in reality there are far better ways to get the score of an answer than the example above, such as this way.)

Resources