Загрузка курсов валют с сайта НБРБ

option explicit

' системные требования: Windows XP SP1, Windows 2000 SP3 ' Windows 2003 Server ' 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