I got referenced value in my sub, but I want to use my referenced value within the GET statement.
I want to use my num1 value as my destaination = in my .Open "Get" statement.
Dim num1 As String
Set htm = CreateObject("htmlFile")
num1 = Cells(2, 2).Value
With CreateObject("msxml2.xmlhttp")
.Open "GET", "https://maps.googleapis.com/maps/api/distancematrix/json?origins=sy10 5tp&destinations='num1'&mode=driving&language=en-GB&v=3&sensor=fals", False
Many Thanks.
Close the quoted string literal with " and use the & concatenation operator to append the variable:
x = "abc" & stringVariable & "def"
So
.Open "GET", "https://maps.googleapis.com/maps/api/distancematrix/json?origins=sy10 5tp&destinations=" & num1 & "&mode=driving&language=en-GB&v=3&sensor=fals", False
(You also have fals which presumably should be false)
Related
I've created a script to fetch json response from a website. To get the response I had to issue post http requests along with appropriate parameters. The script is doing fine.
The payload that I've used within the script is substantially long. It could have been longer.
Now, my question is, how can I break such long line to multiple lines?
This is how I've tried:
Sub GetJsonResponse()
Const URL = "https://api.pcexpress.ca/product-facade/v3/products/category/listing"
Dim payload$
payload = "{""pagination"":{""from"":2,""size"":48},""banner"":""loblaw"",""cartId"":""702da51e-a7ab-4f54-be5e-5bf38bd6d7a2"",""lang"":""en"",""date"":""09062021"",""storeId"":""1032"",""pcId"":null,""pickupType"":""STORE"",""enableSeldonIntegration"":true,""features"":[""loyaltyServiceIntegration"",""sunnyValeServiceIntegration""],""inventoryInfoRequired"":true,""sort"":{""topSeller"":""desc""},""categoryId"":""27985""}"
With CreateObject("MSXML2.XMLHTTP")
.Open "POST", URL, False
.setRequestHeader "content-type", "application/json;charset=UTF-8"
.setRequestHeader "x-apikey", "1im1hL52q9xvta16GlSdYDsTsG0dmyhF"
.send (payload)
Debug.Print .responseText
End With
End Sub
Use the & concatenation to join smaller parts. I would personally examine the json structure and then decide on logical breaks (within reason), then transfer to a text editor and use regex/ find and replace to generate the new strings to concatenate based on your chosen line breaks.
Below you will see most lines have payload = payload & " at the start and " at the end, after the break indicated by the ,.
Of course, also replacing inner " with "".
Option Explicit
Sub GetJsonResponse()
Const URL = "https://api.pcexpress.ca/product-facade/v3/products/category/listing"
Dim payload$
payload = "{""pagination"": {""from"": 2,""size"": 48},"
payload = payload & """banner"": ""loblaw"","
payload = payload & """cartId"": ""702da51e-a7ab-4f54-be5e-5bf38bd6d7a2"","
payload = payload & """lang"": ""en"","
payload = payload & """date"": ""09062021"","
payload = payload & """storeId"": ""1032"","
payload = payload & """pcId"": null,"
payload = payload & """pickupType"": ""STORE"","
payload = payload & """enableSeldonIntegration"": true,"
payload = payload & """features"": [""loyaltyServiceIntegration"", ""sunnyValeServiceIntegration""],"
payload = payload & """inventoryInfoRequired"": true,"
payload = payload & """sort"": {""topSeller"": ""desc""},"
payload = payload & """categoryId"": ""27985""}"
With CreateObject("MSXML2.XMLHTTP")
.Open "POST", URL, False
.setRequestHeader "content-type", "application/json;charset=UTF-8"
.setRequestHeader "x-apikey", "1im1hL52q9xvta16GlSdYDsTsG0dmyhF"
.send payload
Debug.Print .responseText
End With
End Sub
This fits with how I re-arranged this:
To this:
As you noted in the comments, you can absolutely split the string into pieces and continue the line with the line continuation character _.
Using the Windows Clipboard API functions from here:
https://learn.microsoft.com/en-us/office/vba/access/concepts/windows-api/send-information-to-the-clipboard
You can copy text to the clipboard and do something like:
Sub ClipboardTextToVbaString()
Dim s As String, arr, e, rv As String, i As Long, n As Long
s = GetClipboard() 'read text from clipboard
If Len(s) = 0 Then Exit Sub
arr = Split(s, vbCrLf)
rv = "s = "
For i = LBound(arr) To UBound(arr)
e = Replace(arr(i), """", """""")
rv = rv & """" & e & """ "
If i < UBound(arr) Then
If n < 20 Then
rv = rv & " & vbCRLf & _" & vbCrLf
n = n + 1
Else
rv = rv & " & vbCRLf" & vbCrLf & "s = s & "
n = 0
End If
End If
Next i
'Debug.Print rv
SetClipboard rv 'set the modified text back into the clipboard for pasting
End Sub
Not very thoroughly-tested but you get the idea: something for your personal.xlsb file...
Note this is more aimed at formatting multi-line text into a VB-compatible format - not really for breaking up long single lines, which I guess was your original form.
How to GET response using VBA?
This code here does not work. In Debug.Pring() or MsgBox is empty.
TargetURL = snURL + selectedMail
Set HTTPReq = CreateObject("WinHttp.WinHttpRequest.5.1")
HTTPReq.Open "GET", TargetURL, False
HTTPReq.SetCredentials snUser, snPass, 0
HTTPReq.setRequestHeader "Accept", "application/json"
Debug.Print HTTPReq.responseText
I want to get JSON data.
Optional libraries (needed, if early binding is used, in general the code will work without them):
Change the companyName variable:
Sub TestMe()
Dim xmlObject As Object
Dim companyName As String: companyName = "Google"
Dim strUrl As String
strUrl = "http://dev.markitondemand.com/MODApis/Api/v2/Lookup/json?input=" & companyName
Set xmlObject = CreateObject("MSXML2.XMLHTTP")
With xmlObject
.Open "GET", strUrl, False
.Send
End With
Dim response As String
response = "{""data"":" & xmlObject.ResponseText & "}"
Debug.Print response
End Sub
I have a VBA macro that I found somewhere on the internet last year after they changed their API around Q2 2017. It looks like they might have changed it again as when I run it all I get is:
Error: ZNGA
Details: {
"finance": {
"error": {
"code": "Unauthorized",
"description": "Invalid cookie"
}
}
}
For every ticker.
I'm looking at the Sub where crumb and cookie are established which is the following:
Sub BSRawData()
Dim sURL As String, sResult, strSQL As String
Dim oResult As Variant, oData As Variant, r As Long, c As Long, period1 As Double, period2 As Double
Dim db As Database
Dim rst As Recordset
Dim lastRow, recs, i, i2 As Integer
Dim baseDate As Date
Dim startDate As Date
Dim finalDate As Date
Dim crumb As String, cookie As String, validCookieCrumb As Boolean
' Load the ticker symbol into a recordset for iteration
Set db = CurrentDb
Set rst = db.OpenRecordset("SELECT DISTINCT Ticker FROM clients WHERE Ticker IS NOT NULL ORDER BY Ticker DESC;")
'Debug.Print (rst.RecordCount)
recs = rst.RecordCount
rst.MoveFirst
For i = 1 To recs
For i2 = 1 To 2
ExcelObject
Call getCookieCrumb(crumb, cookie, validCookieCrumb)
' Date ranges, do not need to touch the first one
baseDate = #1/1/1970#
startDate = #5/2/2017#
finalDate = #5/1/2018#
' Calculate the number of seconds
period1 = (startDate - baseDate) * 86400
period2 = Round((finalDate - baseDate + 0.33333333) * 86400)
' The first time through it fetches the 52-week data which does not contain dividends. The second time through it fetches dividends only.
If i2 = 1 Then
' Construct the URL string
sURL = "https://query1.finance.yahoo.com/v7/finance/download/" & rst!Ticker & "?period1=" & period1 & "&period2=" & period2 & "&interval=1wk&events=history&crumb=" & crumb
Else
' Construct the URL string
sURL = "https://query1.finance.yahoo.com/v7/finance/download/" & rst!Ticker & "?period1=" & period1 & "&period2=" & period2 & "&interval=1wk&events=div&crumb=" & crumb
End If
' Debug.Print "URL: " & sURL
' Pass the URL into the GetHTTPResult function
sResult = GetHTTPResult(sURL, cookie)
' Takes the result from the function and iterates through it, putting it into Excel
If sResult Like "*Error*" Then
Debug.Print ("Error: " & rst!Ticker)
Debug.Print ("Details: " & sResult)
xl.ActiveWorkbook.Close False
xl.Quit
GoTo NextRecord
End If
oResult = Split(sResult, vbLf)
' Debug.Print "Lines of result: " & UBound(oResult)
For r = 0 To UBound(oResult)
oData = Split(oResult(r), ",")
For c = 0 To UBound(oData)
If oData(UBound(oData)) <> "Null" Then
xl.ActiveSheet.Cells(r + 1, c + 1) = oData(c)
End If
Next c
Next r
Set oResult = Nothing
' Find and replace 'Date' with 'Week' to clear up reserved work complications
xl.Application.DisplayAlerts = False
xl.Cells.Replace What:="Date", Replacement:="Week", LookAt:=xlPart
xl.Application.DisplayAlerts = True
' Insert column and add ticker symbol. won't go into access without it since it is the primary key and indexed
xl.Columns("A").Insert Shift:=xlRight
xl.Range("A1").Value = "Ticker"
lastRow = xl.Cells(xl.Rows.Count, "B").End(xlUp).Row
xl.Range("A2:A" & lastRow).Value = rst!Ticker
' Save the file and close Excel
xl.Application.DisplayAlerts = False
xl.ActiveWorkbook.SaveAs fileName:="C:\Black-Scholes\temp.xlsx"
xl.Application.DisplayAlerts = True
xl.ActiveWorkbook.Close False
xl.Quit
' Go to next record if there were no dividends
If lastRow = 1 Then
GoTo NextRecord
End If
' Back to Access to delete records from the table if ticker is already in there
If i2 = 1 Then
DoCmd.SetWarnings False
strSQL = "DELETE * FROM blackscholes_raw_data WHERE Ticker = '" & rst!Ticker & "';"
DoCmd.RunSQL strSQL
DoCmd.SetWarnings True
End If
' Back to Access to import
DoCmd.TransferSpreadsheet acImport, TableName:="blackscholes_raw_data", fileName:="C:\Black-Scholes\temp.xlsx", HasFieldNames:=True
Next i2
NextRecord:
' On to the next record
rst.MoveNext
Next i
' Move dividends to the week they correspond to and delete row
DoCmd.SetWarnings False
strSQL = "UPDATE blackscholes_raw_data t1 " & _
"LEFT JOIN blackscholes_raw_data t2 " & _
"ON t1.Ticker = t2.Ticker " & _
"SET t1.Dividends = t2.Dividends " & _
"WHERE t1.Dividends IS NULL AND t2.Dividends IS NOT NULL AND t2.Week BETWEEN t1.Week AND t1.Week + 6;"
DoCmd.RunSQL strSQL
strSQL = "DELETE * FROM blackscholes_raw_data WHERE Open IS NULL;"
DoCmd.RunSQL strSQL
DoCmd.SetWarnings True
MsgBox "Done."
End Sub
Sub getCookieCrumb(crumb As String, cookie As String, validCookieCrumb As Boolean)
Dim i As Integer
Dim str As String
Dim crumbStartPos As Long
Dim crumbEndPos As Long
Dim objRequest
validCookieCrumb = False
For i = 0 To 5 'ask for a valid crumb 5 times
Set objRequest = CreateObject("WinHttp.WinHttpRequest.5.1")
With objRequest
.Open "GET", "https://finance.yahoo.com/lookup?s=bananas", False
.setRequestHeader "Content-Type", "application/x-www-form-urlencoded; charset=UTF-8"
.send
.waitForResponse (10)
cookie = Split(.getResponseHeader("Set-Cookie"), ";")(0)
crumbStartPos = InStr(1, .responseText, """CrumbStore"":{""crumb"":""", vbBinaryCompare) + Len("""CrumbStore"":{""crumb"":""")
crumbEndPos = InStr(crumbStartPos, .responseText, """", vbBinaryCompare)
crumb = Mid(.responseText, crumbStartPos, crumbEndPos - crumbStartPos)
End With
If Len(crumb) = 11 Then 'a valid crumb is 11 characters long
validCookieCrumb = True
Exit For
End If:
' If i = 5 Then ' no valid crumb
' validCookieCrumb = False
' End If
Next i
End Sub
Function GetHTTPResult(sURL As String, cookie As String) As String
Dim strUrl, sResult As String
Dim http As WinHttp.WinHttpRequest
Set http = New WinHttp.WinHttpRequest
' Uncomment the line directly below if you need to get a new crumb and cookie
' sURL = "https://finance.yahoo.com/lookup?s=%7B0%7D"
' strCookie = "B=bnnkr99cklnh9&b=3&s=69"
With http
.Open "GET", sURL, False
.setRequestHeader "Cookie", cookie
.send
.waitForResponse
' Debug.Print (http.responseText)
' Debug.Print "Status: " & http.Status & " - " & http.statusText
sResult = .responseText
Set http = Nothing
GetHTTPResult = sResult
End With
End Function
What it should do is import the table on this link into Excel and then import it into Access.
https://finance.yahoo.com/quote/AAPL/history?period1=1503558000&period2=1535094000&interval=1wk&filter=history&frequency=1wk
I'm using Postman to send GET requests to the API. The response header does not contain "Set-Cookie", nor any mention of ""CrumbStore"". The VBA does return values for "Set-Cookie" and a few other things I wouldn't expect it to, so don't quite understand that.
Anyone encountered this yet and have a solution?
Ok, pretty simple fix actually.
This line:
.Open "GET", "https://finance.yahoo.com/lookup?s=bananas", False
Just needed to be changed to a valid ticker. So for my needs I did:
.Open "GET", "https://finance.yahoo.com/quote/AAPL/history?period1=1503558000&period2=1535094000&interval=1wk&filter=history&frequency=1wk", False
Apparently, it used to return a valid crumb by just looking up anything, whether or not the ticker was good. Now doing so doesn't return CrumbStore, so there isn't anything to find.
Disable row with (')
cookie = Split(.getResponseHeader("Set-Cookie"), ";")(0)
and write:
cookie = "thamba"
(If not run, find setCookie in finance yahoo site)
I am working on a procedure, in MS-Access VBA, to POST an XML text string to a web service and process the XML text string that is returned from the service.
The issue I am having is that the responseText property is always empty when it should contain a XML text string. No errors are returned and the .status = "OK".
I have tried the WinHttp.WinHttpRequest, MSXML2.XMLHTTP, and MSXML2.ServerXMLHTTP objects and consistently have the same issue.
Here is a code example:
Public Function Send() As Boolean
Dim oXHR As MSXML2.XMLHTTP60
Dim sURL, sCred As String
Dim sRequest, sResult, sStatus, sHeader As String
Dim bRtn As Boolean
BuildReqXML
sRequest = Me.RequestXML_String
With orsValues
sURL = .Fields("WebServiceURL").Value
sCred = Base64Encode(Trim(.Fields("User").Value) & ":" & Trim(.Fields("Password").Value))
End With
Set oXHR = New MSXML2.XMLHTTP60
With oXHR
.Open "POST", sURL, False
.SetRequestHeader "Authorization", "Basic " & sCred & """"
.SetRequestHeader "User-Agent", "Mozilla/4.0"
.SetRequestHeader "Content-Type", "text/xml"
.Send sRequest
sStatus = .StatusText
sResult = .ResponseText
sHeader = .GetAllResponseHeaders
If sResult <> "" Then
If Contains(sResult, "<") Then ReadXML sResult, "Response"
Debug.Print sResult
Else
Debug.Print sHeader
Debug.Print sRequest
End If
End With
Set oXHR = Nothing
End Function
I have verified that the web service is working correctly by building a similar call in a HTML document, sending the XML string, and receiving the response XML string.
Can someone please help me fix my issue?
I found the problem, with help from Fiddler.
The line setting the authorization header
.SetRequestHeader "Authorization", "Basic " & sCred & """"
Was adding a (") to the header line. The corrected line is
.SetRequestHeader "Authorization", "Basic " & sCred
Thank you for your help
Background/objective: Web Scrape: Problem with the Syntax using the .send
I am attempting to send the last name and first name from a list of names in two columns of cells, I am coming across Syntax Errors as it does not recognize the cell and assumes the range is the "name"
code:
The syntax error begins on the "last" and "first" line under the .send, as I am attempting to send a cell value rather than type in the name. What is the correct formatting when referencing a range of cells?
Option Explicit
Sub Test()
Dim sContent As String
Dim i As Long
Dim j As Long
Dim aHeader() As String
Dim aRows() As String
' Retrieve HTML content via XHR
With CreateObject("MSXML2.XMLHTTP")
.Open "POST", "http://npinumberlookup.org/getResults.php", False
.setRequestHeader "content-type", "application/x-www-form-urlencoded"
.send _
"last=Range(G:1)" & _
"&first=Range(F:1)" & _
"&pracstate=TX" & _
"&npi=" & _
"&submit=Search"
When you want to reference the value of a Range, is exactly as #Qharr said before. I tried doing:
' Retrieve HTML content via XHR
With CreateObject("MSXML2.XMLHTTP")
.Open "POST", "http://npinumberlookup.org/getResults.php", False
.setRequestHeader "content-type", "application/x-www-form-urlencoded"
.send _
"last=" & Range("G1").Value & _
"&first=" & Range("F1").Value & _
"&pracstate=TX" & _
"&npi=" & _
"&submit=Search"
End With
And it worked. No errors when running the code.