VBA-Récupération automatique taux de change sur web

Function ImportXmlEurofXref()

Dim xmlDoc As DOMDocument, xmlCube As IXMLDOMNode, xmlNode As IXMLDOMNode, xmlNodeTime As IXMLDOMNode

Dim strCur As String, strRate As String, curRate As Currency
Dim strDecCar As String, strThCar As String, strTstFmt As String

strTstFmt = Format(1234.5678, "#,##0.0000")
If Len(strTstFmt) = 10 Then
   strThCar = Mid(strTstFmt, 2, 1)
Else
   strThCar = ""
End If
strDecCar = Mid(strTstFmt, Len(strTstFmt) - 4, 1)

Set xmlDoc = New DOMDocument
' Charge fichier xml
xmlDoc.Load "https://www.ecb.europa.eu/stats/eurofxref/eurofxref-hist-90d.xml?b23f48754f2aee6a789698825f3b7217"

' Attendre que le document soit interprété
While (xmlDoc.parsed = False)
    DoEvents
Wend
 
' Format fichier xml :
' ---------------------------------------------------
'   <Cube>
'       <Cube time="2016-04-18">
'           <Cube currency="USD" rate="1.2555"/>
'           ....
'           <Cube currency="ZAR" rate="13.2079"/>
'       </Cube>
'   </Cube>
 
' Obtenir premier élément "Cube" dans le document
Set xmlCube = xmlDoc.DocumentElement.SelectSingleNode("Cube")

 For Each xmlNodeTime In xmlCube.ChildNodes

' Elément "Cube" de niveau inférieur
'Set xmlNodeTime = xmlCube.SelectSingleNode("Cube")

'Adaptation du format de date pour le retrouver dans le doc xml
 If DateSaisie.Value = formatDate(xmlNodeTime.Attributes.getNamedItem("time").NodeValue, "dd/mm/yyyy") Then
 
' Boucler sur les noeuds inférieurs (<Cube currency="CCC" rate="n.nnnn"/>)
'  et récupérer les attributs "time", "currency" et "rate".
'  Le taux est EUR/DEVISE (1 EUR = n.nnnn CCC)
    For Each xmlNode In xmlNodeTime.ChildNodes
        
        If Devise.Value = xmlNode.Attributes.getNamedItem("currency").NodeValue Then

        
            strCur = xmlNode.Attributes.getNamedItem("currency").NodeValue
            strRate = xmlNode.Attributes.getNamedItem("rate").NodeValue
            strRate = Replace(strRate, ".", strDecCar)
            curRate = CCur(strRate)
            
        
        End If
 
    'Debug.Print "1 EUR = " & curRate & " " & strCur, strRate
 
    ' Rechercher la devise l'insérer dans la textbox



    Next
End If
Next

ENDP:

 
Set xmlCube = Nothing
Set xmlDoc = Nothing
 
End Function