This is the base code for using an API to get information from Finnhub and Polygon. Calls are made to these subs from other subs which iterate through a stock table to provide the stock symbol. I've removed some enhancements for tasks not related to the API calls. I'm not an expert VBA coder so the code below may not be the best way to do it but it does work.
Finnhub is used for stock prices; variations can be used to retrieve 52-week high and low and stock name:
Code:
Public Sub GetQuotesFinnhub(strSymbol, numID, StockQuote, _
Optional ByVal boolAPICallsExceeded As Boolean, _
Optional lngBatch As Long)
Dim objXML As Object
Dim strTemp, strURL, strCurrent, strResponse, strSQL As String
Dim curDividend As Currency
Dim dblCurrentPrice As Double
Dim arrResponse, arrCurrent As Variant
Dim intRandom As Long
Dim intStockOwned, intResponse As Integer
' My code to set a random number to add to the call
GetRandom intRandom
Set objXML = CreateObject("MSXML2.XMLHTTP")
'conFinnhubAPIKey is API key provided by Finnhub when signing up for an account
strURL = "https://finnhub.io/api/v1/quote?symbol=" & strSymbol & "&token=" & conFinnhubAPIKey _
& "&rnd=" & intRandom
objXML.Open "GET", strURL
objXML.Send
Do
DoEvents
Loop Until objXML.ReadyState = 4
strResponse = objXML.ResponseText
If InStr(strResponse, "API limit reached") > 0 Then
boolAPICallsExceeded = True
Set objXML = Nothing
Exit Sub
End If
If InStr(strResponse, "Bad gateway") > 0 Then
MsgBox (strResponse)
Exit Sub
End If
arrResponse = Split(objXML.ResponseText, ",")
strCurrent = arrResponse(0) '"{"status":"OK"
arrCurrent = Split(strCurrent, ":")
strTemp = Mid(arrCurrent(1), 1, Len(arrCurrent(1)))
dblCurrentPrice = CDbl(strTemp)
strSQL = "insert into FinnHubPrices (Symbol, Quote, QuoteDate, StockOwned, Batch )" _
& " VALUES ('" & strSymbol & "', " & dblCurrentPrice & ", Now(), " & intStockOwned & ", " & lngBatch & " )"
DoCmd.SetWarnings False
DoCmd.RunSQL strSQL
DoCmd.SetWarnings True
Set objXML = Nothing
End Sub
Polygon is used for dividends:
Code:
Public Sub GetQuotesPolygon(strSymbol, numID, strDisplay, dblAnnualDividend, _
Optional dtExDividend As Date, _
Optional dtPayDate As Date, _
Optional dblDividend As Double, _
Optional intFrequency As Integer)
Dim objXML As Object
Dim strTemp, strURL, strStatus, strResponse, strSQL, strSeparator As String
Dim curDividend As Currency
Dim arrResponse, arrTempArray As Variant
Dim intRandom As Long
Dim ResponseItem As Variant
Dim intReturnCount, intCount As Integer
Dim objFS, objDiv As Object
Set objXML = CreateObject("MSXML2.XMLHTTP")
CallPolygon:
' My code to set a random number to add to the call
GetRandom intRandom
'conPolygonAPIKey is API key provided by Polygon when signing up for an account
strURL = "https://api.polygon.io/v3/reference/dividends?ticker=" & strSymbol _
& "÷nd_type=CD&limit=1&apiKey=" & conPolygonAPIKey & "&rnd=" & intRandom
objXML.Open "GET", strURL
objXML.Send
Do
DoEvents
Loop Until objXML.ReadyState = 4
strResponse = objXML.ResponseText
' Debug watch window can't always show wntire response so I write it out to text file
Set objFS = CreateObject("Scripting.FileSystemObject")
Set objDiv = objFS.OpenTextFile("c:\#Temp\PolygonResponse.txt", 8, True)
strSeparator = "------------------------------- " & Now() & " ---------------------------------------"
objDiv.WriteLine (strSeparator)
objDiv.WriteLine (strResponse)
objDiv.Close
Set objFS = Nothing
Set objDiv = Nothing
arrResponse = Split(objXML.ResponseText, ",")
strStatus = arrResponse(1) '"{"status":"OK"
If InStr(strStatus, "status") And InStr(strStatus, "OK") Then
strDisplay = "*** No dividend information available ***"
Set objXML = Nothing
Exit Sub
End If
intReturnCount = 0
For Each ResponseItem In arrResponse
If InStr(ResponseItem, "cash_amount") Then
arrTempArray = Split(ResponseItem, ":")
strTemp = arrTempArray(2) '<==== Item 3 (array element 2) because it's the first result
dblDividend = CDbl(arrTempArray(2))
intReturnCount = intReturnCount + 1
ElseIf InStr(ResponseItem, "ex_dividend_date") Then
arrTempArray = Split(ResponseItem, ":")
strTemp = Mid(arrTempArray(1), 2, 10)
dtExDividend = DateValue(strTemp)
intReturnCount = intReturnCount + 1
ElseIf InStr(ResponseItem, "frequency") Then
arrTempArray = Split(ResponseItem, ":")
strTemp = arrTempArray(0)
strTemp = arrTempArray(1)
intFrequency = strTemp
intReturnCount = intReturnCount + 1
ElseIf InStr(ResponseItem, "pay_date") Then
arrTempArray = Split(ResponseItem, ":")
strTemp = Mid(arrTempArray(1), 2, 10)
dtPayDate = DateValue(strTemp)
intReturnCount = intReturnCount + 1
End If
If intReturnCount = 4 Then Exit For
Next
If intReturnCount < 4 Then
MsgBox ("Not all return values received from Polygon; exiting.")
Exit Sub
End If
'Insert info into table if it doesn't already exist
intCount = DCount("*", "tblDividendsFuture", "StockID = " & numID & " and [Next Paid] = #" & dtPayDate & "#")
If intCount = 0 Then
strSQL = "insert into tblDividendsFuture (StockID, [Next Paid], [Next Ex-Dividend], Dividend) " & _
"Values ('" & numID & "', #" & Format(dtPayDate, "mm/dd/yyyy") & "# , " & _
" #" & Format(dtExDividend, "mm/dd/yyyy") & "#, " & dblDividend & ")"
DoCmd.RunSQL strSQL
End If
DoCmd.SetWarnings True
Set objXML = Nothing
End Sub
I hope this helps. I assume the forum has a method to message me directly so please feel free to do so.