I am trying to query a web API using VBa.
The issue I am having is the return result throws this exception
Type Mismatch
This occurs when I exit the getJson function (shown below)
Function StartOfCode()
'...code
Dim jsonResult As Object
Set jsonResults = getJson(query) 'cannot get past this
'... more code
End Function
Function getJson(ByRef query As String) As Object
Dim MyRequest As Object
Set MyRequest = CreateObject("WinHttp.WinHttpRequest.5.1")
With MyRequest
.Open "GET", query
.setRequestHeader "Content-Type", "application/json"
.setRequestHeader "Accept", "application/json"
.send
End With
Set getJson = DecodeJson(MyRequest.ResponseText) ' returns fine and I can see the object, of type Object/JScript/TypeInfo
Set MyRequest = Nothing
End Function
Function DecodeJson(JsonString As Variant) As Object
Set DecodeJson = m_ScriptEngine.Eval("(" + JsonString + ")")
End Function
I don't understand what I've done wrong here
The problem is with the object declaration:
Dim jsonResult As Object
Set jsonResults = getJson(query)
You have declared an object called jsonResult but in the next line you are using the plural form of the varibable name: jsonResults. So you need to change one of these variable names so they match.
Related
I have been trying without success to return data from a an internally developed WebApi. The API uses Post requests to return data the body of the request containing complex criteria. I have previously had success using a Post Request to write data via the API, but I seem to have hit a brick wall in my efforts to return data. Here is the method I have been using:
Public Async Function Request(ByVal client As HttpClient, ByVal content As String) As Task
Dim buffer = System.Text.Encoding.UTF8.GetBytes(content)
Dim byteContent = New ByteArrayContent(buffer)
byteContent.Headers.ContentType = New MediaTypeHeaderValue("application/json")
Dim response = Await client.PostAsync(client.BaseAddress, byteContent)
Dim result As String = response.Content.ReadAsStringAsync().Result
_result = result
End Function
For conveninence the results are stored in a class variable, which enables me to test the routine using MSTest. The function should return a JSON array however it doesn't even return an error, rather it just returns Nothing.
Here is the associated TestMethod:
<TestMethod()> Public Sub ShouldSuccessfullyInterrodateTheSpenHapi()
Dim da = New SPEN.ODSDataPackagerService
Dim crit As New HttpCriterion
Dim stopped As Boolean
Dim jsonString As String = Nothing
crit.StartTime = "2022-11-03T00:00:00"
crit.EndTime = "2022-11-03T00:30:00"
crit.Interval = "30m"
crit.TagAttribute = "InstrumentTag"
crit.TagFilter = "confidential"
crit.Delimiter = "~"
crit.ServerName = "SPRODA"
'Deserialize object to JSON
jsonString = da.GetCriteriaJson(crit)
Try
da.InitialiseSettings()
da.Request(da.Clients(0), jsonString)
Debug.Print(da.Result)
Assert.IsTrue(True)
Catch ex As Exception
Assert.IsTrue(False)
End Try
End Sub
What am I missing guys?
EDIT:
Ok some further experimentation with the following code, I am at least now getting an error:
Public Async Function GetVoltagesFromPI(ByVal client As HttpClient, ByVal content As String) As Task(Of PIItemList)
Dim piItems As PIItemList = New PIItemList
Dim buffer = System.Text.Encoding.UTF8.GetBytes(content)
Dim byteContent = New ByteArrayContent(buffer)
byteContent.Headers.ContentType = New MediaTypeHeaderValue("application/json")
Try
Dim response As New HttpResponseMessage
response = Await client.PostAsync(client.BaseAddress, byteContent)
If response.IsSuccessStatusCode Then
_result = New PIItemList
_result = JsonConvert.DeserializeObject(response.Content.ReadAsStringAsync().Result)
End If
Catch ex As Exception
Throw
Finally
End Try
End Function
The function errors at:
response = Await client.PostAsync(client.BaseAddress, byteContent)
with:
System.NullReferenceException: 'Object variable or With block
But really I am no further forward with regards a solution as far as I can make out the code should work, but there is obviously smething flawed in the code implementation.
Kind Regards
Paul.
Finally... Managed to get things working, here is the bare bones working code. Would appreciate any additional input though:
''' <summary>
''' Request pi data via the specified http endpoint (baseaddress)
''' </summary>
''' <param name="client"></param>
''' <param name="content"></param>
Public Function GetVoltagesFromPI(ByVal client As HttpClient, ByVal content As String) As Task(Of PIItemList)
Dim requestMsg As New HttpRequestMessage(HttpMethod.Post, client.BaseAddress)
Dim response As HttpResponseMessage
Dim interim As Object
Try
requestMsg.Content = New StringContent(content, Text.UTF8Encoding.Default, "application/json")
response = client.SendAsync(requestMsg).Result
If (response.StatusCode = System.Net.HttpStatusCode.OK) Then
_resultSet = JsonConvert.DeserializeObject(response.Content.ReadAsStringAsync().Result)
End If
Catch ex As Exception
Throw
Finally
End Try
End Function
With assistance from outside sources I have this code that takes latitude and longitude and extracts zipcodes. Here is the code:
Public Function ReverseGeoCode(myInput1 As String, myInput2 As String) As String
'You will need to reference Microsoft XML, v6.0 object library
Dim XMLDoc As New DOMDocument60
Dim XMLNODE As IXMLDOMNode
Dim I As Long
Dim lat, lng, myAddress, myZipcode, reportZipcode As String
Dim splitAddress, splitZipcode As Variant
lat = myInput1
lng = myInput2
XMLDoc.Load "http://maps.googleapis.com/maps/api/geocode/xml?latlng=" & lat & "," & lng & " &sensor=false"
Do Until XMLDoc.readyState = 4
DoEvents
Loop
If Len(XMLDoc.Text) = 0 Then
Call MsgBox("No Data!")
Exit Function
End If
Set XMLNode = XMLDoc.SelectSingleNode("/GeocodeResponse/result/formatted_address")
For i= 0 To XMLNode.ChildNodes.Length - 1
myAddress = XMLNode.ChildNodes(i).Text
Next i
splitAddress = Split(myAddress, ",")
myZipcode = splitAddress(2)
myZipcode = Trim(myZipcode)
splitZipcode = Split(myZipcode, " ")
reportZipcode = splitZipcode(1)
reportZipcode = Trim(reportZipcode)
ReverseGeoCode = reportZipcode
End Function
So the code works, and I know it might not be the cleanest. But the issue is when I call it in the Excel sheet using "=ReverseGeoCode(Cell1, Cell2)". Sometimes it works fine, other times it produces the return "#VALUE!" and I am not entirely sure why. I attached an image below to show you an example of the error. Does anyone have an idea of why this error is producing?
General observations:
So to pick up on what I wrote in the comments, here is an outline.
You don't want to use an User Defined Function. This will keep on making repeated calls. You definitely risk hitting a call limit to the API without an API key, and possibly with; it is inefficient and it is not necessary. Instead, write a sub which you call once and which loops all the required cells in the sheet and issues the API calls and returns the zip codes. An API key is a method of authentication used with many API calls. You shouldn't share it by the way.
These repeated calls, possibly hitting a limit and the fact that UDFs are frequently calculated maybe the source of your woes.
With efficiency in mind, first remove duplicates from the sheet to avoid calls that are not required. Switch of Screen-Updating and anything else e.g. CalculationMode to manual whilst performing.
From what I have read you require an API key once you have hit a daily limit. Not sure what the API limit is for free version or without API key.
Outline code (XML request with some psuedo code):
Option Explicit
Public Sub ListZipCodes()
Dim lat As Double, longitude As Double
Const APIKEY As String = "yourAPIkey"
Application.ScreenUpdating = False '<==Speed up code when actually working with sheet
'Code to remove duplicates
'Code to loop sheet and call function on each input set of values
'Example call. These would be picked up from cells
lat = 40.714224
longitude = -73.961452
Debug.Print GetZipCode(lat, longitude, APIKEY)
Application.ScreenUpdating = True
End Sub
Public Function GetZipCode(ByVal lat As Double, ByVal longitude As Double, ByVal APIKEY As String) As String
Dim sResponse As String
With CreateObject("MSXML2.XMLHTTP")
Dim URL As String
URL = "https://maps.googleapis.com/maps/api/geocode/xml?latlng=" & lat & "," & longitude & "&key=" & APIKEY
.Open "GET", URL, False
.send
If .Status <> 200 Then
GetZipCode = "API call failed"
Exit Function
End If
Dim XMLDoc As New DOMDocument60, XMLNODE As IXMLDOMNode
XMLDoc.Load .responseBody
If Len(XMLDoc.Text) = 0 Then GetZipCode = "No data"
Set XMLNODE = XMLDoc.SelectSingleNode("/GeocodeResponse/result/formatted_address")
GetZipCode = Split(Trim$(Split(XMLNODE.Text, Chr$(44))(2)), Chr$(32))(1)
End With
End Function
Requesting JSON rather than XML response:
The reason calling as JSON was falling over was that the response needed to be decoded. Here is the function re-written to handle a JSON response.
This requires the download of JSONConverter, which you then import and add a reference to Microsoft Scripting Runtime via VBE > Tools > References.
The example below was run with
latitude: 42.9865913391113,
longitude: -100.137954711914
VBA:
Public Function GetZipCode(ByVal lat As Double, ByVal longitude As Double, ByVal APIKEY As String) As String
Dim sResponse As String, json As Object
With CreateObject("MSXML2.XMLHTTP")
Dim URL As String, formattedAddress As String
URL = "https://maps.googleapis.com/maps/api/geocode/json?latlng=" & lat & "," & longitude & "&key=" & APIKEY
.Open "GET", URL, False
.send
If .Status <> 200 Then
GetZipCode = "API call failed"
Exit Function
End If
Set json = JsonConverter.ParseJson(StrConv(.responseBody, vbUnicode))
formattedAddress = json("results").item(1)("formatted_address")
GetZipCode = Split(Trim$(Split(formattedAddress, Chr$(44))(2)), Chr$(32))(1)
End With
End Function
With a JSON request the initial object you get back is a dictionary, as denoted by the opening "{" in the decoded response:
i.e. Set json = JsonConverter.ParseJson(StrConv(.responseBody, vbUnicode)) returns a dictionary object
The data of interest, in the dictionary, has the key "results", as you may observe from the above.
This can be accessed with json("results"), which returns a collection of dictionaries. This being denoted by the following "[", for collection, and subsequently by the start of the first dictionary within the collection, indicated again by "{".
I can grab the first dictionary in the collection by index with:
json("results").item(1)
An inspection of the keys in this dictionary shows that one of the keys is what we are after i.e."formatted_address".
It's associated value is a primitive datatype; in this case a string. This means we can directly access it using the key (a further object is not returned).
formattedAddress = json("results").item(1)("formatted_address")
Now that we have the address string, we can parse it as we did before:
GetZipCode = Split(Trim$(Split(formattedAddress, Chr$(44))(2)), Chr$(32))(1)
End note:
You can use Postman, amongst other tools, to test API calls, and in this case inspect the JSON response. Indeed, to see what kind of response you are getting full stop.
Help:
It is very quick and easy to set up a project, generate an API key and get started. Maybe 10 minutes to read through and perform.
Instructions on setting up a project and getting an API key
Enabling the API
Understanding how to make API calls to the Geocoding API
The following code was posted by Justin Dearing here:
url checker VBA, when redirected, show redirected url
However, how on earth can I call this function to return T/F AND the target? I've tried various ways (Call, straight request etc) and continue to get compile errors, invalid use of object.
If I cut the function down to: Public Function GetResult(strUrl As String) As Boolean
This returns the T/F for a 301 or 302 however doesn't return the target.
What is the correct approach to calling this function to get the isRedirect True/False AND the target redirected too? What am I missing?
Any pointers appreciated. B
Public Function GetResult(ByVal strUrl As String, Optional ByRef isRedirect As Boolean, Optional ByRef target As String) As String
Dim oHttp As New WinHttp.WinHttpRequest
oHttp.Option(WinHttpRequestOption_EnableRedirects) = False
oHttp.Open "HEAD", strUrl, False
oHttp.send
GetResult = oHttp.Status & " " & oHttp.statusText
If oHttp.Status = 301 Or oHttp.Status = 302 Then
isRedirect = True
target = oHttp.getResponseHeader("Location")
Else
isRedirect = False
target = Nothing
End If
End Function
Try this, see if this works.
Option explicit
Public Function GetResult(ByVal strUrl As String, Optional ByRef isRedirect As Boolean, Optional ByRef target As String) As String
Dim oHttp As WinHttp.WinHttpRequest
Set oHttp = new winhttp.winhttprequest
With ohttp
.Option(WinHttpRequestOption_EnableRedirects) = False
.Open "HEAD", strUrl, False
.send
GetResult = .Status & " " & .statusText
If .Status = 301 Or .Status = 302 Then
isRedirect = True
target = .getResponseHeader("Location")
Else
isRedirect = False
target = vbnullstring
End If
End with
End Function
Untested and written on mobile, sorry for bad formatting.
Note that I don't use Dim ... As new syntax. Instead I use dim and set.
Hope it works. Let me know how you get on.
My understanding is that you want the function to return multiple values. Passing parameters ByRef is one workaround to achieve this. An alternative might be to return a single delimited string, which you then split() on the chosen delimiter. Or returning a variant.
I am trying to write simple application for myself and when i try to call
getInfo method i always get a error into the response. Key, sign, method or nonce is incorrect. I found a number of examples but i still can't find mistake in my code. Could anyone help me with it?
The code works fine for hitbtc. I know yobit is a bit different but I think I have accomodate that.
My code:
Protected Shared Function readStrings(signatureheader As String, host As String, pathandQuery As String, post As String, secret As String, hasher As System.Security.Cryptography.HMAC, otherHeaders As Tuple(Of String, String)()) As String
'apikey=98998BEEB8796455044F02E4864984F4
'secret=44b7659167ffc38bb34fa35b5c816cf5
hasher.Key = exchanges.getBytes(secret)
Dim url = host + pathandQuery ' url = "https://yobit.net/tapi/"
Dim wc = New CookieAwareWebClient()
Dim sigHash2 = ""
If post = "" Then
sigHash2 = CalculateSignature2(pathandQuery, hasher)
Else
'post = "method=getInfo&nonce=636431012620"
sigHash2 = CalculateSignature2(post, hasher) 'sighash2= "ece0a3c4af0c68dedb1f840d0aef0fd5fb9fc5e808105c4e6590aa39f4643679af5da52b97d595cd2277642eb27b8a357793082007abe1a3bab8de8df24f80d2"
End If
wc.Headers.Add(signatureheader, sigHash2) ' SignatureHeader ="Sign"
Dim response = ""
For Each oh In otherHeaders ' otherHeaders =(0) {(Key, 98998BEEB8796455044F02E4864984F4)} System.Tuple(Of String, String)
wc.Headers.Add(oh.Item1, oh.Item2)
Next
'- wc.Headers {Sign: ece0a3c4af0c68dedb1f840d0aef0fd5fb9fc5e808105c4e6590aa39f4643679af5da52b97d595cd2277642eb27b8a357793082007abe1a3bab8de8df24f80d2 Key: 98998BEEB8796455044F02E4864984F4 } System.Net.WebHeaderCollection
'url = "https://yobit.net/tapi/"
'post = "method=getInfo&nonce=636431012620"
If post = "" Then
response = wc.DownloadString(url)
Else
response = wc.UploadString(url, post) 'response = response "{"success":0,"error":"invalid key, sign, method or nonce"}" String
End If
Return response
End Function
The code has been tested succesfully for hitbtc.
So the crypto part is correct. I put it here anyway for completeness
Protected Shared Function CalculateSignature2(text As String, hasher As System.Security.Cryptography.HMAC) As String
Dim siginhash = hasher.ComputeHash(exchanges.getBytes(text))
Dim sighash = exchanges.getString(siginhash)
Return sighash
End Function
So,
for sanity check
This code works
Public Overrides Sub readbalances()
Dim response = readStrings("X-Signature", "https://api.hitbtc.com", "/api/1/trading/balance?nonce=" + exchanges.getNonce().ToString + "&apikey=" + _apiKey, "", _secret, New System.Security.Cryptography.HMACSHA512(), {})
End Sub
With yobit things are different. I got to use post instead of get. I got to add more headers. However, I think I have fixed that.
It doesn't work.
The python function for yobit API is this I just need to translate that to vb.net which I think I have done faithfully
API Call Authentication in Python ( Working PHP example )
I think the mistake is around here
request_url = "https://yobit.net/tapi";
request_body = "method=TradeHistory&pair=ltc_btc&nonce=123";
signature = hmac_sha512(request_body,yobit_secret);
http_headers = {
"Content-Type":"application/x-www-form-urlencoded",
"Key":yobit_public_key,
"Sign":signature
}
response = http_post_request(request_url,request_body,http_headers);
result = json_decode(response.text);
There the stuff that I copied is method=getInfo&nonce=636431012620 which is what I put in post.
So that seems right.
Looks like it works.
I just need to change the nonce so that it's between 0 to 2^31
So this is the error
post = "method=getInfo&nonce=636431012620
The nonce shouldn't be that big. At most it should be
2147483646
Also though not documented, I must add
content type as one of the header. This is the final solution
Dim nonce = exchanges.getNonce().ToString
Dim content = hashObject("", nonce, "method=getInfo&nonce=")
Dim sighash = computeSig(content)
Dim result = CookieAwareWebClient.downloadString1("https://yobit.net/tapi/", content, {New Tuple(Of String, String)("Key", _apiKey), New Tuple(Of String, String)("Sign", sighash), New Tuple(Of String, String)("Content-Type", "application/x-www-form-urlencoded")})
So I added New Tuple(Of String, String)("Content-Type", "application/x-www-form-urlencoded") as one of the headers
Protected Overridable Function computeSig(content As String) As String
Dim hasher = New System.Security.Cryptography.HMACSHA512(System.Text.Encoding.UTF8.GetBytes(_secret))
Return CalculateSignature2(content, hasher)
End Function
Public Shared Function CalculateSignature2(content As String, hasher As System.Security.Cryptography.HMAC) As String
Dim siginhash = hasher.ComputeHash(System.Text.Encoding.UTF8.GetBytes(content))
Dim sighash = exchanges.getString(siginhash) 'convert bytes to string
Return sighash
End Function
Public Shared Function downloadString1(url As String, post As String, otherHeaders As Tuple(Of String, String)()) As String
Dim wc = New CookieAwareWebClient()
For Each oh In otherHeaders
wc.Headers.Add(oh.Item1, oh.Item2)
Next
Dim response = String.Empty
Try
If post = "" Then
response = wc.DownloadString(url)
Else
response = wc.UploadString(url, post)
End If
Catch ex As Exception
Dim a = 1
End Try
Return response
End Function
What is the best approach to send a Pushover via VBA?
In Pushover website code example, I didn't find a VBA example.
He is the Function.
PS: I use an auxiliar function to format strings
TesteFunction:
Public Sub Test()
Debug.Print PushOverPost("myApplication", "mySubscriptionGroup", "Hello Stackoverflow!")
End Sub
PushoverFunction:
' Send a post via PushOver
' #param In application as String: The application's token
' #param In group as String: The user/group token
' #param In message as String: The message that you want to send
' #return as String(): The post response
Public Function PushOverPost(ByVal application As String, ByVal group As String, ByVal message As String) As String
Dim xhttp As Object, params As String, url As String
Set xhttp = CreateObject("MSXML2.ServerXMLHTTP")
params = StringFormat("token={0}&user={1}&message={2}", application, group, message)
url = "https://api.pushover.net/1/messages.json"
With xhttp
.Open "POST", url, False
.setRequestHeader "Content-type", "application/x-www-form-urlencoded"
.send params
PushOverPost = .responseText
End With
End Function
Auxiliar Function:
' Generate a string using .NET format, i.e. {0}, {1}, {2} ...
' #param In strValue as String: A composite format string that includes one or more format items
' #param In arrParames as Variant: Zero or more objects to format.
' #return as String: A copy of format in which the format items have been replaced by the string representations of the corresponding arguments.
' #example: Debug.Print StringFormat("My name is {0} {1}. Hey!", "Mauricio", "Arieira")
Public Function StringFormat(ByVal strValue As String, ParamArray arrParames() As Variant) As String
Dim i As Integer
For i = LBound(arrParames()) To UBound(arrParames())
strValue = Replace(strValue, "{" & CStr(i) & "}", CStr(arrParames(i)))
Next
StringFormat = strValue
End Function