1 Тема от The gray Cardinal

  • The gray Cardinal
  • Разработчик
  • Неактивен

Тема: VBScript: получение курса валюты из Интернета

Небольшой скрипт для получения курса американского доллара с сайта Центробанка на указанную пользователем дату:

Dim sURI 
Dim oHttp 
Dim htmlcode, outstr,doldat
Dim inpdate 
Dim d, m, y 

inpdate = CDate(InputBox("Для получения курса американского доллара введите дату в формате ДД.ММ.ГГГГ",  "Ввод дата", Date))
d = Mid(inpdate,1,2)
m = Mid(inpdate,4,2)
y = Mid(inpdate,7,4)
sURI = "http://cbr.ru/currency_base/daily.asp?C_month= " & _
        m & "&C_year=" & y & "&date_req=" & d & "%2F" & _
        m & "%2F" & y
On Error Resume Next
Set oHttp = CreateObject("MSXML2.XMLHTTP")
If Err.Number <> 0 Then
    Set oHttp = CreateObject("MSXML.XMLHTTPRequest")
End If
On Error GoTo 0
If oHttp Is Nothing Then
End If
oHttp.Open "GET", sURI, False
oHttp.Send
htmlcode = oHttp.responseText
outstr = Mid(htmlcode, InStr(1, htmlcode, "USD") + 85, 7)
Set oHttp = Nothing
doldat=InputBox("Курс американского доллара на " & inpdate & " составляет:","Курс доллара",outstr & " рублей")

Автор скрипта - Alexbootch.

Тема в Коллекции по связанной тематике: AutoIt: Просмотр курса валют и конвертации [Валюта] <-> [Рубль]

Предложения в русском языке начинаются с большой буквы и заканчиваются точкой.
В названии ветки всегда должен быть указан язык программирования или среда исполнения скрипта, если это возможно.

2 Ответ от The gray Cardinal

  • The gray Cardinal
  • Разработчик
  • Неактивен

Re: VBScript: получение курса валюты из Интернета

То же, что и предыдущее, но курс евро:

Dim sURI 
Dim oHttp 
Dim htmlcode, outstr,doldat
Dim inpdate 
Dim d, m, y 

inpdate = CDate(InputBox("Для получения курса Евро введите дату в формате ДД.ММ.ГГГГ",  "Ввод даты", Date))
d = Mid(inpdate,1,2)
m = Mid(inpdate,4,2)
y = Mid(inpdate,7,4)
sURI = "http://cbr.ru/currency_base/daily.asp?C_month= " & _
        m & "&C_year=" & y & "&date_req=" & d & "%2F" & _
        m & "%2F" & y
On Error Resume Next
Set oHttp = CreateObject("MSXML2.XMLHTTP")
If Err.Number <> 0 Then
    Set oHttp = CreateObject("MSXML.XMLHTTPRequest")
End If
On Error GoTo 0
If oHttp Is Nothing Then
End If
oHttp.Open "GET", sURI, False
oHttp.Send
htmlcode = oHttp.responseText
outstr = Mid(htmlcode, InStr(1, htmlcode, "EUR") + 82, 7)
Set oHttp = Nothing
doldat=InputBox("Курс Евро на " & inpdate & " составляет:","Курс Евро",outstr & " рублей")

Автор скрипта - Alexbootch.

Предложения в русском языке начинаются с большой буквы и заканчиваются точкой.
В названии ветки всегда должен быть указан язык программирования или среда исполнения скрипта, если это возможно.

3 Ответ от alexii

  • alexii
  • Разработчик
  • Неактивен

Re: VBScript: получение курса валюты из Интернета

В связи с изменением формата страницы Банка России с курсами валют, вышеуказанные скрипты некорректно извлекают данные. simba_max прислал исправленный вариант с возможностью указания вида валюты:

Dim inpdate, bkCode, kol, nazvanie
Dim d, m, y, i, x1, x2

bkCode  = UCase(CStr(InputBox("Введите код валюты, одно из:" & vbCrLf & vbCrLf & _
    "EUR USD BYR DKK ISK AUD KZT CAD CNY NOK XDR SGD TRY UAH GBP SEK CHF JPY," & vbCrLf & vbCrLf & _
    "например, EUR или USD:", "Ввод кода валюты", "EUR")))
inpdate = CDate(InputBox("Для получения курса " & bkCode & " введите дату в формате ДД.ММ.ГГГГ", _
    "Ввод даты", Date))

d = Mid(inpdate,1,2)
m = Mid(inpdate,4,2)
y = Mid(inpdate,7,4)

sURI = "http://cbr.ru/currency_base/daily.aspx?C_month= " & _
    m & "&C_year=" & y & "&date_req=" & d & "%2F" & _
    m & "%2F" & y
'WScript.Echo sURI

On Error Resume Next
Set oHttp = CreateObject("MSXML2.XMLHTTP")

If Err.Number <> 0 Then
    Set oHttp = CreateObject("MSXML.XMLHTTPRequest")
End If
On Error GoTo 0

If oHttp Is Nothing Then
    WScript.Quit 1
End If

oHttp.Open "GET", sURI, False
oHttp.Send
htmlcode = oHttp.responseText

Do
    Select Case bkCode
        Case "EUR","USD","BYR","DKK","ISK","AUD","KZT","CAD","CNY","NOK","XDR","SGD","TRY","UAH","GBP","SEK","CHF","JPY"
            
        Case Else
            bkCode = "EUR"
    End Select
    
    Exit Do
Loop

x1 = InStr(htmlcode, bkCode)

For i = 1 To 2
    x1 = InStr(x1 + 1, htmlcode, ">")
Next

x2 = InStr(x1, htmlcode, "<") - x1 -1
kol = Mid(htmlcode, x1 + 1, x2)

For i = 1 To 2
    x1 = InStr(x1 + 1, htmlcode, ">")
Next

x2 = InStr(x1, htmlcode, "<") - x1 - 1
nazvanie = Replace(Mid(htmlcode, x1 + 1, x2), "&nbsp;", "")

For i=1 To 2
    x1 = InStr(x1 + 1, htmlcode, ">")
Next

x2 = InStr(x1, htmlcode, "<") - x1 - 1
outstr = Mid(htmlcode, x1 + 1, x2)

Set oHttp = Nothing
'WScript.Echo Mid(htmlcode, x1+1, x2)

doldat = InputBox(kol & " " & nazvanie & " на " & inpdate & " составляет:", _
    "Курс " & bkCode, outstr & " рублей")