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

http://www.textcavarle.com

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