Курсы валют и XML-запросы

[Revengencer]

Здравствуйте.
Хотел бы попросить помощи с функцией возврата курса валюты: http://www.excel-vba.ru/chto-umeet-excel/poluchit-kurs-valyut-ot-sberbanka/
Дело в том, что я хочу сделать такой же, но с курсами Нацбанка Беларуси.
Но... я не могу понять того, что начинается со строки №23. Точнее: как вообще пишется XML-запрос?
Может, кто-нибудь ссылкой поделится о принципах построения таких запросов? Сам я гуглом не нашел (наверно, неправильно гуглил).
Или, может, прокомментируете строчки, начиная с 23-ей?
Буду очень благодарен.

[doober]

Сам я гуглом не нашел (наверно, неправильно гуглил)

Это точно.
Немного поправил макрос под вашу задачу

Код (vb) Выделить Развернуть

Function КурсЦБР(Optional ТипВалюты As String, Optional ByVal Дата As String) As Double
' Коды валют можно посмотреть здесь  http://www.nbrb.by/Services/XmlExRatesRef.aspx
    'раскомментировать, если необходимо обновление при любом изменении на листе
    'Application.Volatile True
    Dim sReqRes, oHttp
    If IsMissing(ТипВалюты) Or ТипВалюты = "" Then ТипВалюты = "145"
    If IsMissing(Дата) Or Дата = "" Then Дата = Now
    If Not IsDate(Дата) Then Дата = CDate(Дата)
    sStart = Format(Дата, "MM/dd/yyyy")
    sRequest = "http://www.nbrb.by/Services/XmlExRatesDyn.aspx?curId=" & ТипВалюты & _
             "&fromDate=" & sStart & "&toDate=" & sStart
    On Error Resume Next
    Set oHttp = CreateObject("MSXML2.XMLHTTP")
    If Err <> 0 Then
        Set oHttp = CreateObject("MSXML.XMLHTTPRequest")
    End If
    If oHttp Is Nothing Then Exit Function
    oHttp.Open "GET", sRequest, False
    oHttp.Send
  Set sReqRes = oHttp.responseXml.SelectSingleNode("//Rate")
If Not sReqRes Is Nothing Then
КурсЦБР = Val(Replace(sReqRes.Text, ",", "."))
End If
End Function

[TheBestOfTheBest]

у меня работает такой код

Код (vb) Выделить Развернуть

Function КурсЦБР(Optional ТипВалюты As String, Optional ByVal Дата As String) As Double
' Коды валют можно посмотреть здесь  http://www.nbrb.by/Services/XmlExRatesRef.aspx
   'раскомментировать, если необходимо обновление при любом изменении на листе
   'Application.Volatile True
   Dim sReqRes, oHttp
   If IsMissing(ТипВалюты) Or ТипВалюты = "" Then ТипВалюты = "145"
   If IsMissing(Дата) Or Дата = "" Then Дата = Now
   If Not IsDate(Дата) Then Дата = CDate(Дата)
   sStart = Format(Дата, "MM/dd/yyyy")
   sRequest = "http://www.nbrb.by/Services/XmlExRatesDyn.aspx?curId=" & ТипВалюты & _
            "&fromDate=" & Replace(Format(sStart, "mm/dd/yyyy"), ".", "/") & "&toDate=" & Replace(Format(sStart, "mm/dd/yyyy"), ".", "/")
   On Error Resume Next
   Set oHttp = CreateObject("MSXML2.XMLHTTP")
   If Err <> 0 Then
       Set oHttp = CreateObject("MSXML.XMLHTTPRequest")
   End If
   If oHttp Is Nothing Then Exit Function
   oHttp.Open "GET", sRequest, False
   oHttp.Send
 Set sReqRes = oHttp.responseXml.SelectSingleNode("//Rate")
If Not sReqRes Is Nothing Then
КурсЦБР = Val(Replace(sReqRes.Text, ",", "."))
End If
End Function

[sv2015]

Добрый день,  у меня работает почему-то только  функция от ThePrist КУРСЦБР,вариант от Doober  КУРСЦБР1
выдает ошибку и вариант от TheBestOfTheBest КУРСЦБР2 выдает ошибку.

[sv2015]

Уточню, выдают такие результаты 17683 и 15446(видимо это курс белорусского рубля) соответственно.

[doober]

http://www.nbrb.by

[Revengencer]

Уточню, выдают такие результаты 17683 и 15446(видимо это курс белорусского рубля) соответственно.

Дело в том, что у doober'a ввод даты подстроен под день/месяц/год, а у TheBestOfTheBest - месяц/день/год, поэтому "07.09.2015" в двух случаях - разная дата, и курс, соответственно, разный.

doober, TheBestOfTheBest, спасибо вам за коды. Я вчера и сам написал, но та часть, где функция ищет и извлекает значение курса у меня получилась немного длиннее и сложнее (по аналогии с оригиналом считал символы).
Плюс еще пришлось через Select Case сопоставлять цифровые коды с буквенными, чтобы вводить именно буквенные (USD и т.д.). Но, правда, я не понял, как ваш метод SelectSingleNode находит значение курса.

И может кто-нибудь еще кратко прокомментировать строки, начиная с Set oHttp ... до oHttp.Send? (т.е. что это за объекты - MSXML2.XMLHTTP и т.д.)
Хотелось бы знать, что означает каждая строчка у меня в кодах, а не просто некоторые строки копировать и вставлять )

[doober]

Дело в том, что у doober'a ввод даты подстроен под день/месяц/год,

Не согласен.

Код (vb) Выделить Развернуть

sStart = Format(Дата, "MM/dd/yyyy") 
В спецификации на сайте формат месяц/ день/ год
Ищите в гугле по словам xpath xml vba
можно и  selectSingleNode

[Revengencer]

Не согласен.
sStart = Format(Дата, "MM/dd/yyyy")

Однако при вводе, скажем, "01.09.2015" ваш код понимает это как 1 сентября 2015, а код TheBestOfTheBest - как 9 января 2015.
Как я понял, в вашей функции входную дату типа день/месяц/год функция меняет в месяц/день/год. А функция TheBestofTheBest сначала делает то же самое, а потом обратно меняет месяц и день (повторно format в sRequest), поэтому так и получается то, что в варианте TheBestOftheBest при вводе 1 сентября получаем 9 января.

[TheBestOfTheBest]

Похоже, что сайт понимает mm/dd/yyyy, именно так, если смотреть на текущий курс на первой странице. К тому же, переменная sStart имеет тип Variant, поэтому эксель ее наровит её преобразовать и "/" заменяет на "." в строке запроса.

Код (vb) Выделить Развернуть

   sStart = Replace(Format(sStart, "mm/dd/yyyy"), ".", "/")
   sRequest = "http://www.nbrb.by/Services/XmlExRatesDyn.aspx?curId=" & ТипВалюты & _  
            "&fromDate=" & sStart & "&toDate=" & sStart
И назвать эту функцию следует КурсЦББ

[doober]

Что-то я  протупил.
Так надо делать

Код (vb) Выделить Развернуть

  sStart = Format(CDate(Дата) - 10, "mm\/dd\/yyyy")
        sEnd = Format(CDate(Дата), "mm\/dd\/yyyy")
строка запроса ='http://www.nbrb.by/Services/XmlExRatesDyn.aspx?curId=145&fromDate=08/28/2015&toDate=09/07/2015'

Ответ
[spoiler]

Код (vb) Выделить Развернуть

<?xml version="1.0"?>
<Currency Id="145" fromDate="08/28/2015" toDate="09/07/2015">
    <Record Date="08/28/2015">
        <Rate>17667</Rate>
    </Record>
    <Record Date="08/29/2015">
        <Rate>17539</Rate>
    </Record>
    <Record Date="08/30/2015">
        <Rate>17539</Rate>
    </Record>
    <Record Date="08/31/2015">
        <Rate>17539</Rate>
    </Record>
    <Record Date="09/01/2015">
        <Rate>17452</Rate>
    </Record>
    <Record Date="09/02/2015">
        <Rate>17399</Rate>
    </Record>
    <Record Date="09/03/2015">
        <Rate>17491</Rate>
    </Record>
    <Record Date="09/04/2015">
        <Rate>17573</Rate>
    </Record>
    <Record Date="09/05/2015">
        <Rate>17683</Rate>
    </Record>
    <Record Date="09/06/2015">
        <Rate>17683</Rate>
    </Record>
    <Record Date="09/07/2015">
        <Rate>17683</Rate>
    </Record>
</Currency>[/spoiler]

[osip]

Добрый день.
А как бы приспособить всё это дело под Казахстан? Может кто подскажет?

[McConst]

Тема старая, но в связи с изменением Нацбанком Республики Беларусь работы API обновления курсов валют я решил эту тему немного освежить. Нацбанк в 2023 году изменил адреса серверов API.
У Нацбанка есть две технологии обращения к курсу валют. Одна через GET-запрос, вторая через отправку XML методом POST.
С учетом текущих изменений оба способа реализованы в функциях ниже.

Функция для скачивания курса валюты методом отправки XML. Второй аргумент - символьная запись валюты. На листе вызвать функцию для получения курса доллара можно так =NBRBCourse("18.07.2023";"USD")

Код (vb) Выделить Развернуть


Public Function NBRBCourse(MyDate As Date, CurrType As String) As Single
'Пользовательская функция, возвращает курс выбранной валюты на указанный день
'Коды ошибок:
' -1    такой валюты за такую дату не найдено
' -2    сайт Нацбанка загрузился с ошибкой

Dim http As Object 'Объект для выполнения запроса через XMLHttpRequest
Dim XML As Variant 'Объект DOMDocument для получения XML
Dim Curr As Object 'Переменная с данными о валюте
Dim PostBody As String 'Запрос к веб-сервису в строковом виде
Dim res 'Ответ запроса XMLHttpRequest


Set http = CreateObject("MSXML2.XMLHttp")
Set XML = CreateObject("MSXML2.DOMDocument")

'Формируем запрос по шаблону с сайта Нацбанка http://www.nbrb.by/Services/ExRates.asmx?op=ExRatesDaily2
'Примеры написания запроса есть на форуме http://www.sql.ru/forum/22867/eshhe-raz-sql-xml?mid=128536#128536
PostBody = "<?xml version='1.0' encoding='utf-8'?>" & _
"<soap:Envelope xmlns:xsi='http://www.w3.org/2001/XMLSchema-instance' xmlns:xsd='http://www.w3.org/2001/XMLSchema' xmlns:soap='http://schemas.xmlsoap.org/soap/envelope/'>" & _
 "<soap:Body>" & _
   "<ExRatesDaily2 xmlns='https://www.nbrb.by/'>" & _
     "<onDate>" & Format(MyDate, "YYYY-MM-DD") & "</onDate>" & _
   "</ExRatesDaily2>" & _
 "</soap:Body>" & _
"</soap:Envelope>"

'Преобразуем строковый запрос в XML
XML.LoadXML (PostBody)


'Создаем POST-запрос для сайта нацбанка.
'Структура заголовков расписана тут https://www.nbrb.by/Services/ExRates.asmx?op=ExRatesDaily2
http.Open "POST", "https://services.nbrb.by/ExRates.asmx", False 'False - синхронное соединение
http.setRequestHeader "Host", "services.nbrb.by" 'Задаем значение заголовка Host
http.setRequestHeader "Content-Type", "text/xml; charset=utf-8"
On Error Resume Next
res = http.Send(XML)

If http.Status <> 200 Then
'Ответ на запрос получен с ошибкой
   NBRBCourse = -2
End If
Set XML = http.ResponseXML.getElementsByTagName("DailyExRatesOnDate") 'Получаем список валют нацбанка

For Each Curr In XML 'Проходим по всем валютам, загруженным в документе
   If Curr.ChildNodes(4).nodetypedvalue = CurrType Then
   'Валюта найдена
       NBRBCourse = CSng(Replace(Curr.ChildNodes(2).text, ".", ","))
       Exit Function
   End If
Next
NBRBCourse = -1 'Валюта не найдена

End Function



Вариант получения курса доллара методом отправки GET-запроса:

Код (vb) Выделить Развернуть


Public Function NBRBCourse2(MyDate As Date)
'Пользовательская функция, возвращает курс выбранной валюты на указанный день
'Коды ошибок:
' -1    такой валюты за такую дату не найдено
' -2    сайт Нацбанка загрузился с ошибкой

Dim http As Object 'Объект для выполнения запроса через XMLHttpRequest
Dim text As Variant 'Получаемый текст со страницы
Dim pos As Long, lngth As Long 'Позиция в тексте при парсинге
Dim URL As String
Dim res

URL = "https://api.nbrb.by/exrates/rates/431?ondate=" & Format(MyDate, "YYYY-MM-DD") '431 - код доллара на сайте Нацбанка
   
On Error Resume Next
Set http = CreateObject("MSXML2.XMLHttp")
If err <> 0 Then
   Set http = CreateObject("MSXML.XMLHTTPRequest")
End If
http.Open "GET", URL, False 'False - синхронное соединение
http.setRequestHeader "Accept", "text/html,application/xhtml+xml,application/xml;q=0.9,image/avif,image/webp,image/apng,*/*;q=0.8,application/signed-exchange;v=b3;q=0.9"
http.setRequestHeader "If-Modified-Since", "Sat, 1 Jan 2000 00:00:00 GMT" 'Сбрасываю кэш
http.setRequestHeader "Accept-Encoding", "gzip, deflate, br"
http.setRequestHeader "Sec-Fetch-User", "?1"
http.setRequestHeader "Sec-Fetch-Dest", "document"
http.setRequestHeader "Sec-Fetch-Mode", "navigate"
http.setRequestHeader "Sec-Fetch-Site", "none"
http.Send
   
   
If http.Status <> 200 Then
'Ответ на запрос получен с ошибкой
   NBRBCourse2 = -2
End If
text = http.ResponseText
   
pos = InStrRev(text, ":") + 1
If pos = 0 Then
   NBRBCourse2 = -1 'Валюта не найдена
   Exit Function
End If
   
lngth = Len(text) - pos
If lngth < 1 Then
   NBRBCourse2 = -1 'Валюта не найдена
   Exit Function
End If
   
NBRBCourse2 = CDbl(Replace(Mid(text, pos, lngth), ".", ","))
End Function