у меня вот так это получилось:
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.
63.
64.
65.
66.
67.
68.
69.
Public Function GetCurrencyExchangeRate()
Dim rst As DAO.Recordset
Dim strSQL As String
strSQL = "SELECT Max(tblCurrencyRates.LastUpdate) AS MaxOfLastUpdate FROM tblCurrencyRates;"
Set rst = CurrentDb.OpenRecordset(strSQL, dbOpenSnapshot)
If Not (rst.BOF And rst.EOF) Then
If rst!MaxOfLastUpdate = Date Then Exit Function
End If
DoCmd.Hourglass True
Dim objIE As Object
Dim objDoc As Object
Dim a As Object
Dim TDs As Object
Dim curUSD As Currency, curEUR As Currency
Dim i As Long
Dim varReturn As Variant
Set objIE = CreateObject( "InternetExplorer.Application" )
objIE.Visible = False
objIE.Silent = False
objIE.Navigate "http://www.rbc.ru/"
i = 1
varReturn = SysCmd(acSysCmdInitMeter, "Updating Currency Exchage Rates from www.rbc.ru :" , 50000 )
While CBool(objIE.Busy)
i = i + 1
varReturn = SysCmd(acSysCmdUpdateMeter, i)
If i > 50000 Then
DoCmd.Hourglass False
varReturn = SysCmd(acSysCmdClearStatus)
Exit Function
End If
DoEvents
Wend
varReturn = SysCmd(acSysCmdClearStatus)
Set objDoc = objIE.Document
For Each a In objDoc.all.tags( "A" )
If InStr( 1 , a.href, "/USD.rus.shtml" ) Then
Set TDs = a.parentElement.parentElement.childNodes
curUSD = CCur(TDs( 3 ).innerText)
strSQL = "INSERT INTO tblCurrencyRates ([Currency], RateDate, Rate, LastUpdate) " & _
"VALUES ('R', #" & DateValue(TDs( 2 ).innerText & _
"/" & Year(Date)) & "#, " & curUSD & ", #" & Date & "#)"
CurrentDb.Execute strSQL
End If
If InStr( 1 , a.href, "/EUR.rus.shtml" ) Then
Set TDs = a.parentElement.parentElement.childNodes
curEUR = curUSD / CCur(TDs( 3 ).innerText)
strSQL = "INSERT INTO tblCurrencyRates ([Currency], RateDate, Rate, LastUpdate) " & _
"VALUES ('" & Chr(128) & "', #" & DateValue(TDs( 2 ).innerText & _
"/" & Year(Date)) & "#, " & curEUR & ", #" & Date & "#)"
CurrentDb.Execute strSQL
Exit For
End If
Next
objIE.Quit
Set objIE = Nothing
DoCmd.Hourglass False
End Function
Таблица с полями : RateID, Currency, RateDate, Rate, LastUpdate - для истории.
Первый кто в контору приходит, запускает базу и эта функция скачивает курс. При втором запуске в тот же день, если на этот день курс уже есть, функция ни куда больше не лезет.
Правда мы ведём всё в долларах и, поэтому нам интересен курс доллара к рублю и доллара к евро. Будте аккуратны.
