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

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
 
    ' в случае если сайт не доступен -- просто
    ' заверши процедуру
    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), "&nbsp;", "")
                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

sub ImportCurrRate_XML
 
 Set Creator = New TCreator
 Set CurrCode = CreateObject("Scripting.Dictionary")
 CurrCode.Add "USD", "USD"
 CurrCode.Add "EUR", "EUR"
 CurrCode.Add "RUB", "RUB"
 CurrCode.Add "PLN", "PLN"
 
 BaseCurrID = gdcBaseManager.GetIDByRUIDString("200010_17")
 
 Set Transaction = Creator.GetObject(null, "TIBTransaction", "")
 Set Transaction.DefaultDatabase = gdcBaseManager.Database
 
 Set ibsql = Creator.GetObject(null, "TIBSQL", "")
 Set ibsql.Transaction = Transaction
 Set ibsqlFind = Creator.GetObject(null, "TIBSQL", "")
 Set ibsqlFind.Transaction = Transaction
 
 Transaction.StartTransaction
 
 ibsql.SQL.Text =_
  "SELECT COUNT(c.code) as CountCode " &_
  "FROM gd_curr c  " &_
  "WHERE c.SHORTNAME = :C "
 
 For Each I in CurrCode
  ibsql.ParamByName("C").AsString = CurrCode.Item(I)
  ibsql.ExecQuery
  if ibsql.FieldByName("CountCode").AsInteger <> 1 then _
    CurrCode.Remove(I)
  ibsql.Close
 Next
 
 FromDate = Date + 1
 ToDate = Date + 1
 
 ibsql.SQL.Text =_
  "SELECT MAX(r.fordate) as MaxForDate " &_
  "FROM gd_currrate r JOIN gd_curr c ON r.fromcurr = c.id " &_
  "WHERE c.SHORTNAME = :FromCurr and r.tocurr = :ToCurr"
 ibsql.ParamByName("ToCurr").AsInteger = BaseCurrID
 
 For Each I in CurrCode
  ibsql.ParamByName("FromCurr").AsString = CurrCode.Item(I)
  ibsql.ExecQuery
  if ibsql.FieldByName("MaxForDate").AsDateTime < FromDate then _
    FromDate = ibsql.FieldByName("MaxForDate").AsDateTime
  ibsql.Close
 Next
 if FromDate <= CDate("01.01.2004") then _
   FromDate = CDate("01.01.2004")
 
 if ToDate < FromDate then _
  exit sub
 
 ibsql.SQL.Text = _
  "INSERT INTO gd_currrate (fromcurr, tocurr, fordate, coeff) " &_
  "SELECT ID, :TC, :FD, :R FROM gd_curr WHERE SHORTNAME = :FC "
 ibsql.ParamByName("TC").AsInteger = BaseCurrID
 
 ibsqlFind.SQL.Text =_
  "SELECT * " &_
  "FROM gd_currrate r JOIN gd_curr c ON r.fromcurr = c.id " &_
  "WHERE c.SHORTNAME = :FC and r.tocurr = :TC AND r.fordate = :FD"
 ibsqlFind.ParamByName("TC").AsInteger = BaseCurrID
 
 Set oXML = CreateObject("MSXML.DomDocument")
 oXML.async = False
 
 For D = FromDate to ToDate Step 1
   ibsqlFind.Close
   ibsqlFind.ParamByName("FD").AsDateTime = D
 
   ibsql.ParamByName("FD").AsDateTime = D
 
   On Error Resume Next
     oXML.Load ("http://www.nbrb.by/Services/XmlExRates.aspx?ondate=" &_
       Month(D) & "/" & Day(D) & "/" & Year(D))
 
     For Each I in CurrCode
 
       ibsqlFind.ParamByName("FC").AsString = CurrCode.Item(I)
       ibsqlFind.ExecQuery
       if ibsqlFind.EOF then
 
         On Error Resume Next
           ibsql.Close
           ibsql.ParamByName("R").AsCurrency = _
             CDbl(Replace(oXML.selectSingleNode("//Currency[CharCode='" & I & _
             "']/Rate").Text, ".", Application.DecimalSeparatorSys))
           ibsql.ParamByName("FC").AsString = CurrCode.Item(I)
           if Err.Number = 0 then
             ibsql.ExecQuery
             ibsql.Close
           end if
         On Error GoTo 0
       end if
       ibsqlFind.Close
     Next
   Transaction.CommitRetaining
   On Error GoTo 0
 Next
 
 Transaction.Commit
end sub