Ниже приведен код модуля макроса, отвечающего за взятие курсов евро и доллара с cbr.ru
Вызывается напрямую с листа, куда затем и выгружает курсы. Сегодня перестал работать, подозреваю, что мог смениться интерфейс сайта, но не уверен.
Сам никогда XMLHTTP не использовал и вообще не силён в VBA.
Вызывается напрямую с листа, куда затем и выгружает курсы. Сегодня перестал работать, подозреваю, что мог смениться интерфейс сайта, но не уверен.
Сам никогда 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 '--------------------------------------------------------------------------- '--------------------------------------------------------------------------- '--------------------------------------------------------------------------- '--------------------------------------------------------------------------- |