Страницы: 1
RSS
Макрос, который берет курсы евалют с cbr.ru, перестал работать
 
Ниже приведен код модуля макроса, отвечающего за взятие курсов евро и доллара с cbr.ru
Вызывается напрямую с листа, куда затем и выгружает курсы. Сегодня перестал работать, подозреваю, что мог смениться интерфейс сайта, но не уверен.
Сам никогда XMLHTTP не использовал и вообще не силён в VBA.
Код
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
'---------------------------------------------------------------------------
' 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
 
     
     
 
    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/ --"

Но выход есть - тяните по адресу
Код

но там искать нужно в других местах, можно искать по коду.
См. http://www.cbr.ru/scripts/XML_daily.asp?date_req=06.06.2018
Работает
Код
1
2
    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
Читают тему
Loading...