Public Function TransformCurrencyExchange()
On Error GoTo Err_handler
Dim rates As Variant ', value As Variant, quotes As Variant
Dim strTemp As String
Dim lngStart As Long
Dim lngEnd As Long
Dim strBase As String
Dim dteDate As Date
Dim arrFieldsValues As Variant, var As Variant, arrTemp As Variant
Dim arrFields() As String
Dim arrValues() As Variant
Dim blnFirst As Boolean
Dim lngCount As Long
'get start time
Start = Timer
ReadJSON:
'Read .json file
Set JsonTS = FSO.OpenTextFile(strFilePath, ForReading, False, 0)
strJSON = JsonTS.readall
JsonTS.Close
ModifyJSON:
'add dummy text to make parsing easier
strJSON = "{""result"":[" & strJSON & "]}"
' Debug.Print strJSON
If InStr(strJSON, """rates"":") = 0 Then
FormattedMsgBox "The JSON file does not contain valid exchange rate data" & _
"@ ================================================================ " & vbNewLine & _
"ERROR MESSAGE: " & vbNewLine & vbNewLine & Replace(strJSON, """", "'") & " " & vbNewLine & _
"================================================================ " & vbNewLine & vbNewLine & _
"CHECK the status of your CurrencyExchange key online @", vbCritical, "Download error"
Exit Function
End If
N = DCount("*", "tblCurrencyExchange")
If N > 0 Then
'delete existing records to prevent duplicates
CurrentDb.Execute "DELETE tblCurrencyExchange.* FROM tblCurrencyExchange;"
End If
'write to table
Set db = CurrentDb
Set rst = db.OpenRecordset("tblCurrencyExchange", dbOpenDynaset, dbSeeChanges)
'Set JSON = JsonConverter.ParseJson(http.responseText)
Set JSON = modJsonConverter.ParseJson(strJSON)
' i = 1
With rst
For Each result In JSON("result")
strBase = result("base")
dteDate = result("date")
Next
'==================================================
'get string in array
lngStart = InStr(1, strJSON, """rates""") + 9
lngEnd = InStr(lngStart, strJSON, "}")
strTemp = Mid(strJSON, lngStart, lngEnd - lngStart)
Debug.Print strTemp
'parse string in array
'Thanks to arnelgp @AWF for suggesting this approach
arrFieldsValues = Split(strTemp, ",")
For Each var In arrFieldsValues
var = Replace(var, """", "")
Debug.Print var
arrTemp = Split(var, ":")
For i = 0 To UBound(arrTemp) Step 2
'remove extra spaces
arrTemp(i) = Trim(arrTemp(i))
arrTemp(i + 1) = Trim(arrTemp(i + 1))
If Not blnFirst Then
If lngCount = 0 Then
ReDim Preserve arrFields(UBound(arrFields) + 1)
ReDim Preserve arrValues(UBound(arrValues) + 1)
End If
Else
blnFirst = False
End If
If lngCount = 0 Then
arrFields(UBound(arrFields)) = arrTemp(i)
arrValues(UBound(arrValues)) = arrTemp(i + 1)
End If
.AddNew
!Currency = arrTemp(i)
!Rate = arrTemp(i + 1)
!Base = strBase
!DownloadDate = dteDate
' Debug.Print i, "Currency = " & arrTemp(i), "Rate = " & arrTemp(i + 1)
.Update
Next i
Next
lngCount = UBound(arrFields)
'Debug.Print lngCount
Erase arrFieldsValues
Erase arrTemp
'===================================================
' Next
.Close
End With
'Set arrTemp = Nothing
Set rst = Nothing
'calculate time taken
Finish = Timer
TimeTaken = Finish - Start
CalculateTimeTaken
'count records
N = DCount("*", "tblCurrencyExchange")
'=====================
If N > 0 Then
Forms!frmMain.lblInfo.Caption = N & " new exchange rate records " & _
" added to table " & strTableName & vbNewLine & strTimeTaken
Else
Forms!frmMain.lblInfo.Caption = "New exchange rate records " & _
" were not added to table " & strTableName & vbNewLine & strTimeTaken
End If
Exit_Handler:
Exit Function
Err_handler:
If Err = 9 Then Resume Next
MsgBox "Error " & Err.Number & " in TransformCurrencyExchange procedure: " & Err.Description, vbExclamation, "Program error"
Resume Exit_Handler
End Function
