Страницы: 1
RSS
Макрос, который берет курсы евалют с cbr.ru, перестал работать
 
Ниже приведен код модуля макроса, отвечающего за взятие курсов евро и доллара с cbr.ru
Вызывается напрямую с листа, куда затем и выгружает курсы. Сегодня перестал работать, подозреваю, что мог смениться интерфейс сайта, но не уверен.
Сам никогда XMLHTTP не использовал и вообще не силён в VBA.
Код
'---------------------------------------------------------------------------
' getCurs Data
' Ver$ 0.3
' 11.10.2011
'---------------------------------------------------------------------------

'- Public Names -----------------------
Public WBwork As String                             ' WorkbookName
' Public worksheetname As String                    ' Sheet Name
'---------------------------------------------------------------------------


'---------------------------------------------------------------------------
Private Sub getCurs()
'---------------------------------------------------------------------------
Dim ErrorNumber As String

Dim sURI As String
Dim oHttp As Object
Dim htmlcode As String
Dim outUSD As String
Dim outEURO As String
    
Dim posEuro As String
Dim posUSD As String
Dim posData As String

Dim curentDate As Date

Dim curerntYear As Integer
Dim curerntMonth As Integer
Dim curerntDay As Integer

Dim RequestDate As String
'---------------------------------------------------------------------------
    Application.ScreenUpdating = False
    
    posEuro = "K1"
    posUSD = "I1"
    posData = "P1"
    
    WBwork = ActiveWorkbook.NAME
    worksheetname = ActiveSheet.NAME
    
    If ActiveWorkbook Is Nothing Then
        MsgBox "Откройте и заполните расчётный файл"
         GoTo errorException
    End If

    On Error GoTo errorException
    
    If isWorksheetExists(WorkBookName:=WBwork, worksheetname:=worksheetname) = False Then
        GoTo errorException
    End If

' check header
    curentDate = Range(posData).Value

    If (curentDate < "01.07.1992" Or curentDate > Date) Then
        curentDate = Format(Date, "dd.mm.yy")
    End If

    
    
    sURI = "http://www.cbr.ru/currency_base/daily/?date_req=" & curentDate

    Set oHttp = CreateObject("MSXML2.XMLHTTP")
    
    If Err.Number <> 0 Then
        Set oHttp = CreateObject("MSXML.XMLHTTPRequest")
    End If

    If oHttp Is Nothing Then
        GoTo errorException
    End If
       
    oHttp.Open "GET", sURI, False
    oHttp.Send
    
    htmlcode = oHttp.responseText

    
    outEURO = Mid(htmlcode, InStr(1, htmlcode, "EUR") + 41, 7)
    outUSD = Mid(htmlcode, InStr(1, htmlcode, "USD") + 47, 7)
     
    If decsep = "." Then
        outEURO = Replace(outEURO, ",", ".")
        outUSD = Replace(outUSD, ",", ".")
    End If
    
    If Not IsNumeric(outEURO) And IsNumeric(outUSD) Then
        MsgBox "Error numeric data!", 48, "Ошибка"
        GoTo errorException
    End If

    Set oHttp = Nothing

' past Data into Table
    For Each cnSheet In Worksheets
    
        If cnSheet.NAME = worksheetname Then
        
            With cnSheet
                .Range(posEuro).Formula = CDbl(outEURO)
                .Range(posData).Value = curentDate
                .Range(posUSD).Formula = CDbl(outUSD)
            End With
        
        End If
    Next cnSheet

errorException:
    ErrorNumber = Err.Number
     
    Application.ScreenUpdating = True
    Exit Sub

End Sub


'---------------------------------------------------------------------------
'---------------------------------------------------------------------------
'---------------------------------------------------------------------------
'---------------------------------------------------------------------------
 
Ну что за название? Какой макрос? Что он должен делать?.. Неужели нельзя в названии темы немного конкретики?
Недавно это спрашивали здесь.
 
Добрый день.
Извиняюсь, если оформил неверно. "Немного конкретики" привёл в описании, а не в самой теме..
По ссылке: пробовал сделать так, как там указано, в коде выше уже добавлено "www.", всё равно не отрабатывает. Способ загрузки тоже менял. Возможно, что-то не так сделал, я не компетентен, к сожалению.
Изменено: Tosser - 06.06.2018 15:42:31 (Орфография)
 
Да, что-то поменялось - в переменной htmlcode теперь это:
"<!DOCTYPE HTML PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
<!-- © Art. Lebedev Studio | http://www.artlebedev.ru/ --"

Но выход есть - тяните по адресу
Код
    sURI = "http://www.cbr.ru/scripts/XML_daily.asp?date_req=" & curentDate

но там искать нужно в других местах, можно искать по коду.
См. http://www.cbr.ru/scripts/XML_daily.asp?date_req=06.06.2018
Работает
Код
    outEURO = Mid(htmlcode, InStr(1, htmlcode, "EUR") + 58, 7)
    outUSD = Mid(htmlcode, InStr(1, htmlcode, "USD") + 64, 7)
Изменено: Hugo - 06.06.2018 15:31:50
 
Цитата
Tosser написал:
мог смениться интерфейс сайта
И, вполне вероятно, будет меняться еще. У ЦБ РФ есть специальные интерфейсы для прикладных программ. Возьмите, например, макрос Игоря.
Изменено: sokol92 - 06.06.2018 15:33:58
Владимир
 
Да и этот работает с коррекцией трёх строк - см.выше.
Но предупреждаю - такой подход не совершенен/корректен - если вдруг курс перевалит за 100 будет косячить. Ну или может если упадёт менее 10...
Тоже советую брать макрос Игоря (ссылка выше).
Изменено: Hugo - 06.06.2018 16:49:39
 
Цитата
Hugo написал: выход есть...
Огромное Вам Спасибо!
Именно с Большой Буквы :)
Начал копаться в этих смещениях, но сам бы еще долго "доходил".
Страницы: 1
Читают тему
Наверх