'---------------------------------------------------------------------------------------
' Procedure : LeeExchangeRateProc .......... NO FORMS involved..............
' Author : Jack
' Date : 27-06-2012
' Purpose : To get the daily exchange rates from the European Central Bank
' at http://www.ecb.int/stats/eurofxref/eurofxref-daily.xml
' These currency/rate pairs show the value of 1 euro in this related currency on this date
'
' From a learning view, this is sending an XMLHTTP request and getting a Response and
' using the DOMDocument amd related objects to extract the required data
' from the xml response. This approach seems cleaner and more consistent than using
' vba functions to search and parse strings within the response.
'---------------------------------------------------------------------------------------
' Last Modified:
'
' Inputs: N/A
' Dependency:
' **********This requires a reference to Microsoft XML, v6.0 **************
'--------------------------------------------------------------------------
'
Sub LeeExchangeRateProc()
Dim Resp As New DOMDocument
Dim Req As New XMLHTTP
Dim objNodeList As IXMLDOMNodeList
Dim objNode As IXMLDOMNode
Dim objAttribute As IXMLDOMAttribute
Dim mCurrency As String
Dim mRate As String
Dim x As Integer
On Error GoTo LeeExchangeRateProc_Error
Req.Open "GET", "http://www.ecb.int/stats/eurofxref/eurofxref-daily.xml", False
Req.send
Resp.loadXML Req.responseText
' uncomment the next line to see the response
' Debug.Print "XML Response is " & vbCrLf & "~~~~~~~~~~~~~~~~~" & vbCrLf & Req.responseText
x = Resp.getElementsByTagName("Cube").Length
Debug.Print "The number of <Cube nodes is " & x
'
' Get all Cube nodes.
'
Set objNodeList = Resp.getElementsByTagName("Cube")
'
' For each cube node if it has attributes currency and rate then display the values.
' One Cube row has no attributes and one has only a time attribute.
'
For Each objNode In objNodeList
If (objNode.Attributes.Length > 0) Then
' Get the "time" attribute for the date to which these exchange rates apply
Set objAttribute = objNode.Attributes.getNamedItem("time")
If (Not objAttribute Is Nothing) Then
Debug.Print "Exchange Rates from European Central Bank as at " & objAttribute.text & vbCrLf _
& vbCrLf & "**Read these as 1 euro = **" & vbCrLf
End If
' Get the "currency" attribute
Set objAttribute = objNode.Attributes.getNamedItem("currency")
If (Not objAttribute Is Nothing) Then
mCurrency = objAttribute.text
End If
' Get the associated "rate" attribute
Set objAttribute = objNode.Attributes.getNamedItem("rate")
If (Not objAttribute Is Nothing) Then
mRate = objAttribute.text
End If
'Put the data in my variables for display
If mCurrency > " " And mRate > " " Then
Debug.Print mCurrency & " " & mRate
End If
End If
Next objNode
On Error GoTo 0
Exit Sub
LeeExchangeRateProc_Error:
MsgBox "Error " & Err.number & " (" & Err.Description & ") in procedure LeeExchangeRateProc of Module xmlhttp_etc"
End Sub
