|
|
| (не показаны 12 промежуточных версий 3 участников) |
| Строка 1: |
Строка 1: |
| − | <pre>
| |
| − | option explicit
| |
| | | | |
| − | ' системные требования: Windows XP SP1, Windows 2000 SP3
| + | * [[Загрузка курсов валют с сайта НБРБ (XML)]] |
| − | ' Windows 2003 Server
| + | * [[Загрузка курсов валют с сайта НБРБ (HTML)]] |
| − | '
| + | |
| − | sub Curr_LoadRates
| + | |
| − | | + | |
| − | Dim Creator
| + | |
| − | Set Creator = New TCreator
| + | |
| − | | + | |
| − | ' словарь CurrCode нужен нам для двух целей:
| + | |
| − | ' во-первых, в нем задается список валют, курсы
| + | |
| − | ' которых мы будем загружать с сайта
| + | |
| − | ' во-вторых, в нем мы устанавливаем соответствие
| + | |
| − | ' между кодом (буквенной аббревиатурой) валюты
| + | |
| − | ' используемой на сайте (Key) и кодом валюты
| + | |
| − | ' используемым в нашей базе данных (Item). Очевидно,
| + | |
| − | ' что они могут как совпадать, так и различаться
| + | |
| − | ' например, доллар США на сайте может обозначаться
| + | |
| − | ' как USD, а у нас в базе он будет проходить как
| + | |
| − | ' USD NBRB, что означает курс доллара США, установленный
| + | |
| − | ' Национальным банком Республики Беларусь.
| + | |
| − | ' Обратите внимание, что коды валют могут меняться во времени
| + | |
| − | ' например в одно время сайт может вернуть курс польского злотого
| + | |
| − | ' под кодом PLZ, а в другое -- PLN
| + | |
| − | ' в таком случае, все коды одной и той же валюты, которые
| + | |
| − | ' могут использоваться на сайте, должны быть перечислены
| + | |
| − | ' через запятую
| + | |
| − | Dim CurrCode
| + | |
| − | Set CurrCode = CreateObject("Scripting.Dictionary")
| + | |
| − | CurrCode.Add "USD", "USD"
| + | |
| − | CurrCode.Add "EUR", "EUR"
| + | |
| − | CurrCode.Add "RUB,RUR", "RUB"
| + | |
| − | CurrCode.Add "PLN,PLZ", "PLN"
| + | |
| − | CurrCode.Add "UAH", "UAH"
| + | |
| − | CurrCode.Add "LTL", "LTL"
| + | |
| − | CurrCode.Add "LVL", "LVL"
| + | |
| − | CurrCode.Add "GBP", "GBP"
| + | |
| − | | + | |
| − | ' идентификатор записи валюты, относительно которой
| + | |
| − | ' задаются курсы валют на сайте
| + | |
| − | ' в данном случае -- это наш родной белорусский рубль
| + | |
| − | Dim BaseCurrID
| + | |
| − | BaseCurrID = gdcBaseManager.GetIDByRUIDString("200010_17")
| + | |
| − | | + | |
| − | ' даты: с какой и по какую загружать курсы валют с сайта
| + | |
| − | ' по какую -- возьмем текущую системную дату
| + | |
| − | ' с какой -- определим следующим образом: будем искать в нашей
| + | |
| − | ' базе для каждой из заданных валют самую последнюю
| + | |
| − | ' дату курса. из всех найденных дат возьмем наиболее раньнюю.
| + | |
| − | Dim FromDate, ToDate
| + | |
| − | ToDate = Date
| + | |
| − | FromDate = ToDate
| + | |
| − | | + | |
| − | Dim q, qFind, Tr
| + | |
| − | Set Tr = Creator.GetObject(Application, "TIBTransaction", "")
| + | |
| − | Set q = Creator.GetObject(Application, "TIBSQL", "")
| + | |
| − | Set qFind = Creator.GetObject(Application, "TIBSQL", "")
| + | |
| − | | + | |
| − | Set Tr.DefaultDatabase = gdcBaseManager.Database
| + | |
| − | Set q.Transaction = Tr
| + | |
| − | Set qFind.Transaction = Tr
| + | |
| − | | + | |
| − | Tr.StartTransaction
| + | |
| − | | + | |
| − | ' уберем коды валют которых нет нашей базе или
| + | |
| − | ' которые встречаются более одного раза
| + | |
| − | q.SQL.Text =_
| + | |
| − | "SELECT COUNT(c.code) " &_
| + | |
| − | "FROM gd_curr c " &_
| + | |
| − | "WHERE c.code = :C "
| + | |
| − | | + | |
| − | Dim I
| + | |
| − | For Each I in CurrCode
| + | |
| − | q.ParamByName("C").AsString = CurrCode.Item(I)
| + | |
| − | q.ExecQuery
| + | |
| − | if q.Fields(0).AsInteger <> 1 then _
| + | |
| − | CurrCode.Remove(I)
| + | |
| − | q.Close
| + | |
| − | Next
| + | |
| − | | + | |
| − | q.SQL.Text =_
| + | |
| − | "SELECT MAX(r.fordate) " &_
| + | |
| − | "FROM gd_currrate r JOIN gd_curr c ON r.fromcurr = c.id " &_
| + | |
| − | "WHERE c.code = :FC and r.tocurr = :TC"
| + | |
| − | q.ParamByName("TC").AsInteger = BaseCurrID
| + | |
| − | | + | |
| − | For Each I in CurrCode
| + | |
| − | q.ParamByName("FC").AsString = CurrCode.Item(I)
| + | |
| − | q.ExecQuery
| + | |
| − | if Int(q.Fields(0).AsDateTime) < FromDate then _
| + | |
| − | FromDate = Int(q.Fields(0).AsDateTime)
| + | |
| − | q.Close
| + | |
| − | Next
| + | |
| − | | + | |
| − | ' проверим, может в базе уже есть все курсы
| + | |
| − | if ToDate < FromDate then _
| + | |
| − | exit sub
| + | |
| − | | + | |
| − | ' если интервал слишком большой -- ограничим его
| + | |
| − | if (ToDate - FromDate) > (365 * 1) then _
| + | |
| − | FromDate = ToDate - 365 * 1
| + | |
| − | | + | |
| − | ' подготовим запрос для вставки курса валюты
| + | |
| − | q.SQL.Text = _
| + | |
| − | "INSERT INTO gd_currrate (fromcurr, tocurr, fordate, coeff) " &_
| + | |
| − | "SELECT ID, :TC, :FD, :R FROM gd_curr WHERE code = :FC "
| + | |
| − | q.ParamByName("TC").AsInteger = BaseCurrID
| + | |
| − | | + | |
| − | ' подготовим запрос для поиска курса валюты на указанную дату
| + | |
| − | qFind.SQL.Text =_
| + | |
| − | "SELECT * " &_
| + | |
| − | "FROM gd_currrate r JOIN gd_curr c ON r.fromcurr = c.id " &_
| + | |
| − | "WHERE c.code = :FC and r.tocurr = :TC AND r.fordate = :FD"
| + | |
| − | qFind.ParamByName("TC").AsInteger = BaseCurrID
| + | |
| − |
| + | |
| − | Dim strResult
| + | |
| − | Dim WinHttpReq
| + | |
| − | Dim strURL
| + | |
| − | | + | |
| − | ' если объект не удается создать (например, неподходящая
| + | |
| − | ' версия Windows), то просто завершаем выполнение
| + | |
| − | On Error Resume Next
| + | |
| − | Set WinHttpReq = CreateObject("WinHttp.WinHttpRequest.5.1")
| + | |
| − | if Err.Number <> 0 then _
| + | |
| − | Exit Sub
| + | |
| − | On Error GoTo 0
| + | |
| − | | + | |
| − | ' если используется прокси для выхода в интернет
| + | |
| − | ' откоментируйте следующую строку и укажите адрес прокси
| + | |
| − | ' последний параметр, указывает адреса, к которым подключение
| + | |
| − | ' будет происходить минуя прокси
| + | |
| − | ' WinHttpReq.SetProxy 2, "proxy_server:80", "*.domain.com"
| + | |
| − | | + | |
| − | Dim D, K, J, E, SS, Mo, Da, Arr, A
| + | |
| − | For D = FromDate to ToDate Step 1
| + | |
| − | qFind.Close
| + | |
| − | qFind.ParamByName("FD").AsDateTime = D
| + | |
| − | | + | |
| − | q.ParamByName("FD").AsDateTime = D
| + | |
| − |
| + | |
| − | if Month(D) < 10 then
| + | |
| − | Mo = "0" & Month(D)
| + | |
| − | else
| + | |
| − | Mo = Month(D)
| + | |
| − | end if
| + | |
| − | | + | |
| − | if Day(D) < 10 then
| + | |
| − | Da = "0" & Day(D)
| + | |
| − | else
| + | |
| − | Da = Day(D)
| + | |
| − | end if
| + | |
| − | | + | |
| − | strURL = "http://www.nbrb.by/statistics/rates/RatesDaily.asp?fromDate=" &_
| + | |
| − | Year(D) & "-" & Mo & "-" & Da
| + | |
| − |
| + | |
| − | 'strUrl = "http://localhost/nbrb/ratesdaily.asp.htm"
| + | |
| − | | + | |
| − | ' в случае если сайт не доступен -- просто
| + | |
| − | ' заверши процедуру
| + | |
| − | On Error Resume Next
| + | |
| − |
| + | |
| − | WinHttpReq.Open "GET", strURL, false
| + | |
| − | WinHttpReq.Send
| + | |
| − | strResult = WinHttpReq.ResponseText
| + | |
| − |
| + | |
| − | if Err.Number <> 0 then _
| + | |
| − | Exit Sub
| + | |
| − |
| + | |
| − | On Error GoTo 0
| + | |
| − | | + | |
| − | For Each I in CurrCode
| + | |
| − | ' для каждой валюты проверим: нет ли в базе курса на
| + | |
| − | ' указанную дату. если есть, то пропускаем эту валюту
| + | |
| − | qFind.ParamByName("FC").AsString = CurrCode.Item(I)
| + | |
| − | qFind.ExecQuery
| + | |
| − |
| + | |
| − | if qFind.EOF then
| + | |
| − | Arr = Split(I, ",")
| + | |
| − |
| + | |
| − | For Each A in Arr
| + | |
| − | K = InStr(strResult, ">" & A & "</td>")
| + | |
| − |
| + | |
| − | if K > 0 then
| + | |
| − | For J = 1 to 4
| + | |
| − | K = InStr(K + 1, strResult, ">")
| + | |
| − | if K = 0 then _
| + | |
| − | Exit For
| + | |
| − | Next
| + | |
| − |
| + | |
| − | if K > 0 then
| + | |
| − | K = K + 1
| + | |
| − | E = InStr(K, strResult, "<")
| + | |
| − | | + | |
| − | if E > 0 then
| + | |
| − | SS = Replace(Mid(strResult, K, E - K), " ", "")
| + | |
| − | SS = Replace(SS, " ", "")
| + | |
| − | SS = Replace(SS, Chr(160), "")
| + | |
| − | | + | |
| − | ' на сайте используется точка в качестве десятичного
| + | |
| − | ' разделителя. Заменим ее на разделитель, использующийся в нашей
| + | |
| − | ' системе
| + | |
| − | SS = Replace(SS, ".", Application.DecimalSeparatorSys)
| + | |
| − | | + | |
| − | if SS > "" then
| + | |
| − | ' в случае если строку не удается перевести в число
| + | |
| − | ' или возникнет ошибка при добавлении записи --
| + | |
| − | ' проигнорируем их
| + | |
| − | On Error Resume Next
| + | |
| − |
| + | |
| − | q.ParamByName("R").AsCurrency = CCur(SS)
| + | |
| − | q.ParamByName("FC").AsString = CurrCode.Item(I)
| + | |
| − |
| + | |
| − | if Err.Number = 0 then _
| + | |
| − | q.ExecQuery
| + | |
| − |
| + | |
| − | On Error GoTo 0
| + | |
| − | end if
| + | |
| − | end if
| + | |
| − | end if
| + | |
| − | end if
| + | |
| − | Next
| + | |
| − | end if
| + | |
| − | | + | |
| − | qFind.Close
| + | |
| − | Next
| + | |
| − | | + | |
| − | Next
| + | |
| − | | + | |
| − | ' подтверждаем запись в базу данных, только если все прошло успешно
| + | |
| − | ' и не возникало ошибок
| + | |
| − | Tr.Commit
| + | |
| − | | + | |
| − | end sub
| + | |
| − | </pre>
| + | |
