Добрый день.
на просторах интернета нашел файл с командой подтягивания курса валюты на определенную дату.
при запуске макроса веб сервис подтягивается корректный, но в нужные ячейки курс не подтягивается.
у меня 2016 ексель, разделитель между целыми и дробными запятая.
Подскажите где содержи(а)тся ошибка(и)?
на просторах интернета нашел файл с командой подтягивания курса валюты на определенную дату.
при запуске макроса веб сервис подтягивается корректный, но в нужные ячейки курс не подтягивается.
у меня 2016 ексель, разделитель между целыми и дробными запятая.
Подскажите где содержи(а)тся ошибка(и)?
Код |
---|
Public SelectedDate As String, DefaultDate As StringPublic dt_1 As Date, dt_2 As Date Option Explicit Sub GetRates() Dim sURL As String Dim objHttp As Object Dim sHtmlCode As String Dim varInpDate As Variant Dim WshShell As Object Dim RegValue As String Dim sDay As String, sMonth As String, sYear As String Dim sDollarRate As String, sEuroRate As String, sYuanRate As String, sPoundRate As String 'varInpDate = InputBox("Введите дату в формате ДД.ММ.ГГГГ", "Курсы валют", Date) Form_SelectDate.Show varInpDate = CStr(SelectedDate) If varInpDate = "" Then Exit Sub varInpDate = CDate(varInpDate) sDay = Format(varInpDate, "dd") sMonth = Format(varInpDate, "mm") sYear = Format(varInpDate, "yyyy") sURL = "http://www.nationalbank.kz/rss/get_rates.cfm?fdate=" & _ sDay & "." & sMonth & "." & sYear & "&switch=kazakh" On Error Resume Next Set objHttp = CreateObject("MSXML2.XMLHTTP.3.0") If Err.Number <> 0 Then Err.Clear Set objHttp = CreateObject("MSXML2.XMLHTTP") If Err.Number <> 0 Then Set objHttp = CreateObject("MSXML.XMLHTTPRequest") End If End If If objHttp Is Nothing Then MsgBox "Невозможно создать объект для подключения к интернет!", 48, "Ошибка" Exit Sub End If If objHttp Is Nothing Then Exit Sub objHttp.Open "GET", sURL, False On Error Resume Next objHttp.Send If Err.Number <> 0 Then MsgBox "Отсутствует доступ в интернет!", 48, "Ошибка" Exit Sub End If On Error GoTo 0 sHtmlCode = objHttp.responseText Set objHttp = Nothing On Error Resume Next sDollarRate = Mid(sHtmlCode, InStr(InStr(1, sHtmlCode, "USD"), sHtmlCode, "</td></tr>") - 7, 7) sEuroRate = Mid(sHtmlCode, InStr(InStr(1, sHtmlCode, "EUR"), sHtmlCode, "</td></tr>") - 7, 7) sHtmlCode = "" '------------------------------------------------------------------------------- 'считываем значение ключа реестра 'HKEY_CURRENT_USER\Control Panel\International\\sMonDecimalSep 'чтобы узнать какой знак является разделителем целой и дробной части 'указанной в Панель управления - Язык и региональные стандарты - 'Настройка - Денежная единица - Разделитель целой и дробной части Set WshShell = CreateObject("WScript.Shell") RegValue = WshShell.RegRead("HKEY_CURRENT_USER\Control Panel\International\\sMonDecimalSep") If RegValue = "." Then sDollarRate = CSng(Replace(sDollarRate, ",", ".")) sEuroRate = CSng(Replace(sEuroRate, ",", ".")) End If '------------------------------------------------------------------------------- Application.ScreenUpdating = False [DollarRng] = "" [EuroRng] = "" [DateRng] = varInpDate [DollarRng] = Replace(sDollarRate, ",", ".") [EuroRng] = Replace(sEuroRate, ",", ".") ActiveSheet.Hyperlinks.Add Anchor:=Range("LinkRng"), Address:=sURL, _ ScreenTip:="Перейти на сайт НБ РК", TextToDisplay:="НБ РК" Application.ScreenUpdating = True MsgBox Format(varInpDate, "DD MMMM YYYY") & Chr(13) & Chr(13) _ & "Доллар: " & vbTab & sDollarRate & Chr(13) & "Евро: " & vbTab & sEuroRate & Chr(13) _ & "Отношение: " & Format(sEuroRate / sDollarRate, "0.0000"), 64, "Курсы валют" End Sub |
Код |
---|