Option Explicit
Option Compare Database

' from other source, cannot remember and forgot to bookmark
' modified by arnelgp
'
' this no longer work since win 10
'
'Public Sub GetExchangeRates(ByVal strFilter As String)
'    Dim ie As Object, strSource As String, strSQL As String
'    Dim strCurrencyName As String, strCode As String, sngRate As Single
'    Dim strLastUpdated As String, ar As Variant
'    Dim i As Integer, j As Integer, s As String, sc As String
'    Dim db As DAO.Database
'
'    Set ie = CreateObject("internetexplorer.application")
''   No need to show the user the web page if we're just getting values from it
'    ie.Visible = False
'    On Error GoTo error_here
''   Open the web page in our custom object
'    ie.Navigate "http://www.floatrates.com/daily/usd.xml" '"https://www.x-rates.com/table/?from=USD&amount=1"
''   Wait until the web page is done loading
'    On Error GoTo 0
'TryAgain:
'    While ie.Busy
'       DoEvents
'    Wend
'   Get the outerHTML, which includes the XML on the web page
'    On Error GoTo TryAgain
'    strSource = ie.Document.body.outerHTML
'    'strSource = ie.Document.body.innerHTML
'    On Error GoTo 0
''    CurrentDb.Execute "delete * from tblExchangeRates"
'    i = InStr(strSource, "<div class=""right"">Updated:")
'    strSource = Mid(strSource, i + Len("<div class=""right"">Updated:"))
'    strLastUpdated = Trim(Left(strSource, InStr(1, strSource, "</div>") - 1))
'    strSource = Mid(strSource, InStr(strSource, "<tr class=""row"">"))
'    strSource = Left(strSource, InStrRev(strSource, "</tbody></table>") - 1)
'    strSource = ReplaceTag(strSource, "|", "tr", "td")
'    ar = Split(strSource, "|")
'    j = 1
'    Set db = CurrentDb
'    For i = 0 To UBound(ar)
'        s = Trim(ar(i))
'        If (s <> "") And (s <> "|") And (s <> vbCrLf) And (s <> vbCr) And (s <> vbLf) Then
'            Select Case j
'            Case 1
'                strCurrencyName = s
'            Case 2
'                strCode = s
'                sc = s
'            Case 3
'                sngRate = CSng(s)
'            End Select
'            j = j + 1
'            If j > 3 Then
'                j = 1
'                If (strFilter = "") Or (InStr(strFilter, """" & sc & """" & ",") <> 0) Then
'                    If DCount("1", "tblExchangeRates", "[Updated]='" & strLastUpdated & "' and " & _
'                                "[Code]='" & strCode & "'") < 1 Then
'
'                            db.Execute "Insert Into tblExchangeRates ([Updated], CurrencyName, Code, Rate) " & _
'                            "select '" & strLastUpdated & "','" & strCurrencyName & "','" & _
'                            strCode & "'," & sngRate & ";"
'                    Else
'                        db.Execute "Update tblExchangeRates Set Rate = " & sngRate & _
'                                    ",[deleted]=0 where [updated]='" & strLastUpdated & "' and " & _
'                                    "Code = '" & strCode & "';"
'
'                    End If
'
'                End If
'            End If
'        End If
'    Next
'
'exit_here:
'    Set ie = Nothing
'    Exit Sub
'error_here:
'    MsgBox "Unable to use internet"
'    Resume exit_here
'End Sub

' oct-13-2021
' good thing is there is an alternative
' arnelgp
'
Public Sub GetRates(ByVal strFilter As String)
    Dim oXML As Object
    Dim strSource As String, strSQL As String
    Dim strCurrencyName As String, strCode As String, sngRate As Single
    Dim strLastUpdated As String, ar As Variant
    Dim i As Long, j As Long, s As String, sc As String
    Dim db As DAO.Database
    Dim strToLook As String, sNum As String
    strToLook = "<title>1 USD = "
    Set oXML = CreateObject("MSXML2.XMLHTTP")
'   No need to show the user the web page if we're just getting values from it
    On Error GoTo error_here
    With oXML
        .Open "GET", "http://www.floatrates.com/daily/usd.xml"
        .setRequestHeader "User-Agent", "Mozilla/5.0"
        .send
        'Debug.Print .responsetext
        'Exit Sub
        Do While .ReadyState <> 4
            'Debug.Print .ReadyState
            DoEvents
        Loop
        strSource = .responsetext
    End With
    Set oXML = Nothing
    On Error GoTo 0
'    CurrentDb.Execute "delete * from tblExchangeRates"
    strSource = Replace$(strSource, Chr(9), "")
    i = InStr(1, strSource, "<item>")
    strSource = Mid$(strSource, i)
    i = InStr(1, strSource, "</channel>")
    strSource = Left$(strSource, i - 1)
    WriteToText Environ("temp") & "\xchange.txt", strSource
    Set db = CurrentDb
    
    With CreateObject("scripting.filesystemobject").opentextfile(Environ("temp") & "\xchange.txt", 1, 0, 0)
    Do Until .AtEndOfStream
        s = .Readline
        'Debug.Print s
        If InStr(1, s, strToLook) Then
            s = Replace$(Trim$(Replace$(s, strToLook, "")), ",", "")
            s = Trim$(Replace$(s, "</title>", ""))
            s = Replace$(s, " ", "")
            sNum = getNum(s)
            sngRate = Val(sNum)
            strCode = Trim$(Replace$(s, sNum, ""))
            sc = strCode
        End If
        If InStr(1, s, "<description>1 U.S. Dollar = ") Then
            s = Trim$(Replace$(Replace$(s, "<description>1 U.S. Dollar = ", ""), ",", ""))
            s = Trim$(Replace$(s, "</description>", ""))
            s = Trim$(Replace$(s, sNum, ""))
            strCurrencyName = s
        End If
            
        If InStr(1, s, "<pubDate>") Then
            strLastUpdated = Trim$(Replace$(Replace$(s, "<pubDate>", ""), "</pubDate>", ""))
            If (strFilter = "") Or (InStr(strFilter, """" & sc & """" & ",") <> 0) Then
                If DCount("1", "tblExchangeRates", "[Updated]='" & strLastUpdated & "' and " & _
                            "[Code]='" & strCode & "'") < 1 Then
                            
                        db.Execute "Insert Into tblExchangeRates ([Updated], CurrencyName, Code, Rate) " & _
                        "select '" & strLastUpdated & "','" & strCurrencyName & "','" & _
                        strCode & "'," & sngRate & ";"
                Else
                    db.Execute "Update tblExchangeRates Set Rate = " & sngRate & _
                                ",[deleted]=0 where [updated]='" & strLastUpdated & "' and " & _
                                "Code = '" & strCode & "';"
                
                End If
            End If
            strCode = ""
        End If
    Loop
    End With
exit_here:
    
    Exit Sub
error_here:
    MsgBox "Unable to use internet"
    Resume exit_here
End Sub



Public Sub WriteToText(ByVal spath As String, ByVal the_content As String)
On Error GoTo Err_Handler
Open spath For Output As #1
Print #1, the_content
Close #1
Exit_WriteToText:
Exit Sub
Err_Handler:
MsgBox Err.Number & Err.Description, vbExclamation, "Error"
Resume Exit_WriteToText
End Sub

Public Function getNum(ByVal p As String) As String
On Error GoTo Err_Handler
Dim s As String
Dim x As String
Dim j As Long, ln As Long
ln = Len(p)
For j = 1 To ln
    s = Mid$(p, j, 1)
    If IsNumeric(s) Or s = "." Then
        x = x & s
    Else
        Exit For
    End If
Next
getNum = x
Exit_getNum:
Exit Function
Err_Handler:
MsgBox Err.Number & Err.Description, vbExclamation, "Error"
Resume Exit_getNum
End Function

Public Function getTxt(ByVal p As String) As String
On Error GoTo Err_Handler
    With CreateObject("VBScript.RegExp")
        .Global = True
        .IgnoreCase = True
        .pattern = "[^a-z]"
        getTxt = .Replace(p, "")
    End With
Exit_getTxt:
Exit Function
Err_Handler:
MsgBox Err.Number & Err.Description, vbExclamation, "Error"
Resume Exit_getTxt
End Function


Public Sub GetNewRates(ByVal strFilter As String)
    'Dim strFilter As String: strFilter = ""
    Dim oXML As Object
    Dim strSource As String, strSQL As String
    Dim strCurrencyName As String, strCode As String, sngRate As Single
    Dim strLastUpdated As String, ar As Variant
    Dim i As Long, j As Long, s As String, sc As String
    Dim db As DAO.Database, rs As DAO.Recordset
    Dim strToLook As String, sNum As String
    Dim the_file As String
    strToLook = "1 USD = "
    Set oXML = CreateObject("MSXML2.XMLHTTP")
'   No need to show the user the web page if we're just getting values from it
    On Error GoTo error_here
    With oXML
        .Open "GET", "http://www.floatrates.com/daily/usd.xml"
        .setRequestHeader "User-Agent", "Mozilla/5.0"
        .send
        'Debug.Print .responsetext
        'Exit Sub
        Do While .ReadyState <> 4
            'Debug.Print .ReadyState
            DoEvents
        Loop
        strSource = .responsetext
    End With
    Set oXML = Nothing
    On Error GoTo 0
'    CurrentDb.Execute "delete * from tblExchangeRates"
    strSource = Replace$(strSource, Chr(9), "")
    i = InStr(1, strSource, "<item>")
    strSource = Mid$(strSource, i)
    i = InStr(1, strSource, "</channel>")
    strSource = Left$(strSource, i - 1)
    strSource = "<?xml version=""1.0""?>" & vbCrLf & "<content>" & vbCrLf & strSource & "</content>"
    
    
    Set db = CurrentDb
    Set rs = db.OpenRecordset("tblXMLSpecs", dbOpenSnapshot, dbReadOnly)
    'we need a Well formatted xml, so it can be parsed correctly
    With rs
        .MoveFirst
        Do Until .EOF
            strSource = Replace$(strSource, !old_element, !new_element)
            .MoveNext
        Loop
    End With
    rs.Close
    Set rs = Nothing
        
    'add ID to each <item>
    i = InStr(1, strSource, "<item>")
    j = 0
    Do Until i = 0
        j = j + 1
        strSource = Replace$(strSource, "<item>", "<item id=""" & j & """>", 1, 1)
        i = InStr(1, strSource, "<item>")
    Loop
    Do While Right$(strSource, 1) = Chr(10) Or Right$(strSource, 1) = Chr(13)
        strSource = Left$(strSource, Len(strSource) - 1)
    Loop
    'the_file = Environ("userprofile") & "\desktop\xchange.xml"
    'WriteToText the_file, strSource

    
    
    Dim TitleNodes, DescriptNodes, PublishNodes
    Dim oNodes
    'Set oXML = CreateObject("Microsoft.XMLDOM")
    Set oXML = CreateObject("MSXML2.DOMDocument")
    oXML.async = False: oXML.validateOnParse = False
    'oXML.Load (the_file)
    oXML.loadXML strSource
    Set TitleNodes = oXML.selectNodes("content/item/title/text()")
    Set DescriptNodes = oXML.selectNodes("content/item/description/text()")
    Set PublishNodes = oXML.selectNodes("content/item/pubDate/text()")
    
    'Set oNodes = oXML.selectNodes("/content/item")
    'For i = 0 To (oNodes.length - 1)
    '    Debug.Print oNodes(i).Text
    'Next
    For i = 0 To (TitleNodes.length - 1)
        'title
        s = TitleNodes(i).nodeValue
        s = Replace$(Trim$(Replace$(s, strToLook, "")), ",", "")
        s = Trim$(Replace$(s, "</title>", ""))
        s = Replace$(s, " ", "")
        sNum = getNum(s)
        sngRate = Val(sNum)
        strCode = Trim$(Replace$(s, sNum, ""))
        sc = strCode
        
        'description
        s = DescriptNodes(i).nodeValue
        s = Trim$(Replace$(Replace$(s, "1 U.S. Dollar = ", ""), ",", ""))
        s = Trim$(Replace$(s, sNum, ""))
        strCurrencyName = s
        
        'pubDate
        s = PublishNodes(i).nodeValue
        strLastUpdated = Trim$(s)
    
        'update or insert to table
        If (strFilter = "") Or (InStr(strFilter, sc) <> 0) Then
            If DCount("1", "tblExchangeRates", "[Updated]='" & strLastUpdated & "' and " & _
                        "[Code]='" & strCode & "'") < 1 Then
                        
                    db.Execute "Insert Into tblExchangeRates ([Updated], CurrencyName, Code, Rate) " & _
                    "select '" & strLastUpdated & "','" & strCurrencyName & "','" & _
                    strCode & "'," & sngRate & ";"
            Else
                db.Execute "Update tblExchangeRates Set Rate = " & sngRate & _
                            ",[deleted]=0 where [updated]='" & strLastUpdated & "' and " & _
                            "Code = '" & strCode & "';"
            
            End If
        End If
    Next
exit_here:
    Set db = Nothing
    Set oXML = Nothing
    Exit Sub
error_here:
    MsgBox "Unable to use internet"
    Resume exit_here
End Sub

Sub TestXML()
On Error GoTo Err_Handler
    Dim XDoc As Object
    Dim lists As Object, getFirstChild As Object
    Set XDoc = CreateObject("MSXML2.DOMDocument")
    XDoc.async = False: XDoc.validateOnParse = False
    XDoc.Load (Environ("userprofile") & "\desktop\xchange.xml")
    
    'Get Document Elements
    Set lists = XDoc.documentElement
    
    'Get first child ( same as ChildNodes(0) )
    Set getFirstChild = lists.firstChild
    'Print first child XML
    Debug.Print getFirstChild.XML
    'Print first child Text
    Debug.Print getFirstChild.Text
 
    Set XDoc = Nothing
Exit_TestXML:
Exit Sub
Err_Handler:
MsgBox Err.Number & Err.Description, vbExclamation, "Error"
Resume Exit_TestXML
End Sub

Sub TestXML2()
On Error GoTo Err_Handler
    Dim XDoc As Object, lists, listNode, fieldNode
    
    Set XDoc = CreateObject("MSXML2.DOMDocument")
    XDoc.async = False: XDoc.validateOnParse = False
    XDoc.Load (Environ("userprofile") & "\desktop\xchange.xml")
    
    'Get Document Elements
    Set lists = XDoc.documentElement
    
    'Traverse all elements 2 branches deep
    For Each listNode In lists.childNodes
        Debug.Print "---Email---"
        For Each fieldNode In listNode.childNodes
            Debug.Print "[" & fieldNode.baseName & "] = [" & fieldNode.Text & "]"
        Next fieldNode
    Next listNode
    
    Set XDoc = Nothing
Exit_TestXML2:
Exit Sub
Err_Handler:
MsgBox Err.Number & Err.Description, vbExclamation, "Error"
Resume Exit_TestXML2
End Sub