1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62
| Option Compare Database
Option Explicit
Private Type Cotation
Taux As Single
Dte As String
End Type
Private Sub BtnCurrency_Click()
Dim LaValeur As Cotation
Dim SetA As Object
Set SetA = CurrentDb.OpenRecordset("TBLCurrency", dbOpenTable)
With SetA
Do Until .EOF
LaValeur = Rate(!Currency)
.Edit
With LaValeur
![CurrencyToDollar] = .Taux
![CurrencyRateDate] = .Dte
End With
.Update
.MoveNext
Loop
.Close
End With
Set SetA = Nothing
MsgBox "Currency Rates have been updated with success"
End Sub
Function Rate(ByVal Currency_Rate As String) As Cotation
Dim URL As String, Txt As String, TxtRate As String, TxtDate As String
Dim REQ As Object
Dim N As Long
URL = "http://www.google.com/finance?q=" & Currency_Rate
Set REQ = CreateObject("microsoft.xmlhttp")
With REQ
.Open "POST", URL, False
.setRequestHeader "User-Agent", "Mozilla/5.0 (compatible; MSIE 10.0; Windows NT 6.1; WOW64; Trident/6.0)"
.send
Txt = .ResponseText
End With
Set REQ = Nothing
N = InStr(Txt, "1 " & Currency_Rate)
If N > 0 Then
TxtRate = Mid(Txt, N)
TxtRate = Left(TxtRate, InStr(TxtRate, "USD") - 2)
TxtRate = Mid(TxtRate, InStr(TxtRate, ">") + 1)
TxtDate = Mid(Txt, InStr(Txt, "<div class=time id="))
TxtDate = Left(TxtDate, InStr(TxtDate, "GMT") - 2)
TxtDate = Mid(TxtDate, InStr(TxtDate, ">") + 1)
With Rate
.Taux = TxtRate
.Dte = TxtDate
End With
End If
End Function |
Partager