Currency Exchange Rate update

[mveijndh]

How can I automaticly update my exchange rates in an Access database. I know there are sites out there that provide current Exchange rates (like XE Currency Converter), bu ti want to automaticly update my current exchange rates so I don't have to type them each time over.
Anyone been there before?:banghead:

 

[Solo712]

How can I automaticly update my exchange rates in an Access database. I know there are sites out there that provide current Exchange rates (like XE Currency Converter), bu ti want to automaticly update my current exchange rates so I don't have to type them each time over.
Anyone been there before?:banghead:

Hi,
first you need to have a text file with the latest currencies (acquired by subscription from a provider) placed in a folder. Then create a vba routine to run when you start the Access app, that will pick up the latest currency exchange data and place them in an Access table.

Best,
Jiri

 

[arnelgp]

put the code below in a module
create a hidden form with timer event.
on timer event of your form call this function:
note that on my example the conversion is Dollar to Philippine Peso.
you can call the function with 3rd parameter as Open, Close, Bid, Ask.
for more info about this function go to:
http://investexcel.net/foreign-exchange-rate-function-in-excel/

Private Sub Form_Timer()
Dim dblCurrency As Double
' kill timer
Me.TimerInterval = 0
dblCurrency = FXRate("USD","PHP","Open")
' Update your Table
Docmd.SetWarnings False
Docmd.RunSQL "Update yourCurrencyTable SET yourCurrencyField = " & dblCurrency & ";"
Docmd.SetWarnings True
' 1 minutes = 60000 milliseconds
' wait for ten minutes to update again
Me.TimerInterval = 600000
End Sub

this one goes to a module:

Public Function FXRate(currency1 As String, currency2 As String, rateType As String) As Double

Dim str As String
Dim temp As String

Dim bidStart As Long
Dim bidEnd As Long
Dim askStart As Long
Dim askEnd As Long
Dim openStart As Long
Dim openEnd As Long
Dim closeStart As Long
Dim closeEnd As Long

Dim bid As Double
Dim ask As Double
Dim ropen As Double
Dim rclose As Double

str = "http://finance.yahoo.com/q?s=" & currency1 & currency2 & "=X"

temp = ExecuteWebRequest(str)

bidStart = InStr(temp, "Bid:")
bidEnd = InStr(bidStart, temp, "</td>")
bid = Mid(temp, bidStart + 65, bidEnd - bidStart - 72)

askStart = InStr(temp, "Ask:")
askEnd = InStr(askStart, temp, "</td>")
ask = Mid(temp, askStart + 65, askEnd - askStart - 72)

openStart = InStr(temp, "Open:")
openEnd = InStr(openStart, temp, "</td>")
ropen = Mid(temp, openStart + 38, openEnd - openStart - 38)

closeStart = InStr(temp, "Prev Close:")
closeEnd = InStr(closeStart, temp, "</td>")
rclose = Mid(temp, closeStart + 44, closeEnd - closeStart - 44)

If rateType = "ask" Then
    FXRate = ask
ElseIf rateType = "bid" Then
    FXRate = bid
ElseIf rateType = "open" Then
    FXRate = ropen
ElseIf rateType = "close" Then
    FXRate = rclose
End If

End Function

Private Function ExecuteWebRequest(ByVal url As String) As String

Dim oXHTTP As Object

If InStr(1, url, "?", 1) <> 0 Then
    url = url & "&cb=" & Timer() * 100
Else
    url = url & "?cb=" & Timer() * 100
End If

Set oXHTTP = CreateObject("MSXML2.XMLHTTP")
oXHTTP.Open "GET", url, False
oXHTTP.Send
ExecuteWebRequest = oXHTTP.ResponseText
Set oXHTTP = Nothing

End Function

 

[mveijndh]

Hi,
I'm speechless.........
Thanks very much for the work, it's well appreciated!!!