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

Предложено Леонидом Агафоновым. Предпочтительно использовать именно этот вариант, так как он не зависит визуального оформления, структуры HTML страницы.

option explicit
sub Curr_LoadRates
 
 dim Creator
 Set Creator = New TCreator
 
 ' Коды валют для загрузки в базу данных
 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"
 
 dim BaseCurrID
 BaseCurrID = gdcBaseManager.GetIDByRUIDString("200010_17")
 
 dim Transaction
 Set Transaction = Creator.GetObject(null, "TIBTransaction", "")
 Set Transaction.DefaultDatabase = gdcBaseManager.Database
 
 
 dim ibsql
 Set ibsql = Creator.GetObject(null, "TIBSQL", "")
 Set ibsql.Transaction = Transaction
 
 dim ibsqlFind
 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 "
 
 dim I
 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
 
 dim FromDate, ToDate
 FromDate = Date + 1
 if Weekday(Date) <> 6 then
   ToDate = Date + 1
 else
   ToDate = Date + 3
 end if
 
 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, val, amount) " &_
  "SELECT ID, :TC, :FD, :V, :AMT 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
 
 dim oXML
 Set oXML = CreateObject("MSXML.DomDocument")
 oXML.async = False
 
 dim RateObj, ScaleObj, CodeArr, j , CurRate
 
 dim D
 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
           RateObj = Nothing
           ScaleObj = Nothing
           CodeArr = Split(I, ",")
           for j = 0 to UBound(CodeArr)
             set RateObj = oXML.selectSingleNode("//Currency[CharCode='" & CodeArr(j) & "']/Rate")
             set ScaleObj = oXML.selectSingleNode("//Currency[CharCode='" & CodeArr(j) & "']/Scale")
             if Assigned(RateObj) And Assigned(ScaleObj) then exit for
           next
 
           if Assigned(RateObj) And Assigned(ScaleObj) then
             CurRate = CDbl(Replace(RateObj.Text, ".", Application.DecimalSeparatorSys))
             CurScale = CInt(ScaleObj.Text)
 
             ibsql.Close
             ibsql.ParamByName("V").AsVariant = CurRate
             ibsql.ParamByName("Amt").AsInteger = CurScale
             ibsql.ParamByName("FC").AsString = CurrCode.Item(I)
             if Err.Number = 0 then
               ibsql.ExecQuery
               ibsql.Close
             end if
           end if
         On Error GoTo 0
       end if
       ibsqlFind.Close
     Next
   Transaction.CommitRetaining
   On Error GoTo 0
 Next
 
 Transaction.Commit
 end sub