Функция получения курса валюты ЦБ из интернета за любую дату написанная на VBA для Excel и других приложений MS Office

Вам кода-нибудь хотелось получать курс валюты Центрального Банка прямо из функции в ячейку Excel? Либо вы хотели бы автоматизировать свое приложение написанное на VBA и получать курс валюты автоматически? А ведь это совсем не проблема!

Когда-то мне очень понадобилась такая функция, и теперь я использую ее почти во всех своих приложения написанных на языке VBA. Это очень удобно, курс подтягивается из интернета, с официального сайта ЦБ, по специальной ссылке. И, кстати, структура данных возвращаемых после запроса к данному ресурсу не меняется в течении уже многих лет. Т.е. это стабильный ресурс и его можно использовать. Вы можете адаптировать эту функцию под себя, переписать ее, в общем, пользуйтесь на здоровье.

И да, чуть не забыл, эта функция имеет всего два параметра, т.е. принимает два аргумента : дату и значение валюты в буквенном формате, например, “USD”.

Новая версия функции:

Эту функцию мы разбираем в 15 видеоуроке Углубленного курса по VBA

' Procedure : KursCB
' Author    : Основа - Pavel55, коррекция - Alex_ST: 2010-01-28; модификация SemukovAV: 2016-04-10
' URL       : ROBOTOBOR.PRO
' Date      : 10.04.2016
' Purpose   : запрос заданного курса валюты ЦБ на заданную дату
' Notes     : По умолчанию - текущая дата
'---------------------------------------------------------------------------------------
'//функция возвращает курс ЦБ исходя из входящих параметров(дата и валюта), если дату не задать первым параметром,...
'//...тогда по умолчанию используется текущая дата локальной машины
Public Function KursCB(Optional ByVal dtDate, Optional ByVal txtCurr) As Double   ' query rate ЦБ с сайта ЦБ РФ
    '//объявляем переменные
    Dim query$, otvet$ '//запрос, ответ на запрос, итоговый курс валюта
    Dim oHttp As Object '//объект запроса
 
    If IsMissing(dtDate) Then dtDate = Date '//используем текущую дату локальной машины в случае если дата не определена
    On Error Resume Next
    If Not IsDate(dtDate) Then dtDate = CDate(dtDate) '//проверяем на тип даты
    If Err.Number <> 0 Then Exit Function '//выходим из функции если значение даты не верного типа
 
    query = "http://cbr.ru/currency_base/daily.aspx?date_req=" & dtDate '//формируем запрос, который будем передавать
 
    On Error Resume Next
    Set oHttp = CreateObject("MSXML2.XMLHTTP") '//создаем объект для запроса
    If Err.Number <> 0 Then Set oHttp = CreateObject("MSXML.XMLHTTPRequest") '//если ошибка используем другой объект для запроса
    On Error GoTo ErrorHandler
    If oHttp Is Nothing Then Exit Function '//если не смогли создать объект для запроса, тогда выходим из функции
    Call oHttp.Open("GET", query, False) 'открываем объект для запроса
    oHttp.Send '//отправляем запрос на сервер (сайт)
    otvet = UCase(oHttp.responseText) '//полученные ответ запроса преобразуем в верхний регистр, для дальнейшего парсинга
    Set oHttp = Nothing '//закрываем объект запроса
 
   '//блок кода парсит строку ответа для получения значения курса валюты////////
    Dim startCurr As Integer
    Dim startKolvo As Integer
    Dim endKolvo As Integer
    Dim startKurs As Integer
    Dim endKurs As Integer
    Dim kursCurr As Double
    Dim kolvoCurr As Double
 
    startCurr = InStr(1, otvet, txtCurr, vbTextCompare)
    startKolvo = InStr(startCurr + 3, otvet, "<td>", vbTextCompare) + 4
    endKolvo = InStr(startKolvo + 1, otvet, "</td>", vbTextCompare) - 1
    startKurs = InStr(endKolvo + 12, otvet, "<td>", vbTextCompare) + 4
    endKurs = InStr(startKurs, otvet, "</td>", vbTextCompare) - 1
 
    kursCurr = CDbl(Mid(otvet, startKurs, endKurs - startKurs + 1)) '//получаем курс валюты как на сайте ЦБ
    kolvoCurr = CDbl(Mid(otvet, startKolvo, endKolvo - startKolvo + 1)) '//получаем кол-во ед. валюты как на сайте ЦБ
    '////////////////////////////////////////////////////////////////////////////
 
    KursCB = kursCurr / kolvoCurr '//возвращаем реальный курс валюты за единицу валюты
    Exit Function
 
ErrorHandler: 'Обработчик ошибок получения курса валюты
    KursCB = 0
    Err.Clear
End Function
 
 

Ниже приведена Устаревшая версия функции:

' Procedure : KursCB
' Author    : Основа - Pavel55, коррекция - Alex_ST: 2010-01-28; модификация SemukovAV: 2012-06-27
' URL       : http://www.planetaexcel.ru/forum.php?thread_id=6870&page_forum=2&allnum_forum=34
' Date      : 28.01.2010
' Purpose   : запрос заданного курса валюты ЦБ на заданную дату
' Notes     : По умолчанию - текущая дата
'---------------------------------------------------------------------------------------
'//функция возвращает курс ЦБ исходя из входящих параметров(дата и валюта), если дату не задать первым параметром,...
'//...тогда по умолчанию используется текущая дата локальной машины
Public Function KursCB(Optional ByVal dtDate, Optional ByVal txtCurr) As Double   ' query rate ЦБ с сайта ЦБ РФ
    '//объявляем переменные
    Dim query$, otvet$, rate$ '//запрос, ответ на запрос, итоговый курс валюта
    Dim oHttp As Object '//объект запроса
    Dim day$, month$, year$ '//дата разбитая на три части: день, месяц, год
 
    If IsMissing(dtDate) Then dtDate = Date '//используем текущую дату локальной машины в случае если дата не определена
    On Error Resume Next
    If Not IsDate(dtDate) Then dtDate = CDate(dtDate) '//проверяем на тип даты
    If Err.Number <> 0 Then Exit Function '//выходим из функции если значение даты не верного типа
 
    day = Format(dtDate, "dd") : month = Format(dtDate, "mm") : year = Format(dtDate, "yyyy")
    '//формируем запрос, который будем передавать
    query = "http://cbr.ru/currency_base/daily.aspx?C_month=" & month & "&C_year=" _
             & year & "&date_req=" & day & "%2F" & month & "%2F" & year
    On Error Resume Next
    Set oHttp = CreateObject("MSXML2.XMLHTTP") '//создаем объект для запроса
    If Err.Number <> 0 Then Set oHttp = CreateObject("MSXML.XMLHTTPRequest") '//если ошибка используем другой объект для запроса
    On Error GoTo 0
    If oHttp Is Nothing Then Exit Function '//если не смогли создать объект для запроса, тогда выходим из функции
    Call oHttp.Open("GET", query, False) 'открываем объект для запроса
    oHttp.Send '//отправляем запрос на сервер (сайт)
    otvet = UCase(oHttp.responseText) '//полученные ответ запроса преобразуем в верхний регистр, для дальнейшего парсинга
   '//парсим строку ответа для получения значения курса валюты
    rate = CCur(Mid(otvet, InStr(InStr(1, otvet, txtCurr), otvet, "</TD></TR>") - 7, 7)) '//парсим строку ответа
    Set oHttp = Nothing '//закрываем объект запроса
    KursCB = rate
End Function

No Comments

Post Reply