Подтягивание курса валют в Access и фильтрация по валюте

@Spec_0994 · Регистрация: 01.11.2016

Студворк — интернет-сервис помощи студентам

Всем привет! Нашел форму где вытягиваются все курсы валют, подскажите как сделать, что бы был виден в этой форме только курс доллара код 840, другие не интересуют. Какой фильтр надо в VBA прописать?

@АЕ · 27.06.2018, 10:18

PureBasic
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
Public Function GetCurrencyRate(rDate As Date, cCode As String) As Double
' Êóðñ áåð¸òñÿ ïî àäðåñó http://www.cbr.ru/currency_base/D_print.aspx?date_req=dd.mm.yyyy
' ãäå dd.mm.yyyy - äàòà, íà êîòîðóþ áåð¸ì êóðñ
' Âàëþòû, äîñòóïíûå ñ ýòîãî àäðåñà ïåðå÷èñëåíû íèæå.
' rDate - äàòà, íà êîòîðóþ áåð¸ì êóðñ, cCode - êîä âàëþòû,
' êóðñ êîòîðîé íåîáõîäèìî ïîëó÷èòü, â âèäå ñòðîêè èç 3-õ ñèìâîëîâ
'
' Êîäû âàëþò:
' 36; AUD; 1; Àâñòðàëèéñêèé äîëëàð
' 974; BYR; 1000; Áåëîðóññêèõ ðóáëåé
' 208; DKK; 10; Äàòñêèõ êðîí
' 840; USD; 1; Äîëëàð ÑØÀ
' 978; EUR; 1; Åâðî
' 352; ISK; 100; Èñëàíäñêèõ êðîí
' 398; KZT; 100; Êàçàõñêèõ òåíãå
' 124; CAD; 1; Êàíàäñêèé äîëëàð
' 156; CNY; 10; Êèòàéñêèõ þàíåé Æýíüìèíüáè
' 949; TRY; 1; Íîâàÿ òóðåöêàÿ ëèðà
' 578; NOK; 10; Íîðâåæñêèõ êðîí
' 960; XDR; 1; ÑÄÐ (ñïåöèàëüíûå ïðàâà çàèìñòâîâàíèÿ)
' 702; SGD; 1; Ñèíãàïóðñêèé äîëëàð
' 980; UAH; 10; Óêðàèíñêèõ ãðèâåí
' 826; GBP; 1; Ôóíò ñòåðëèíãîâ Ñîåäèíåííîãî êîðîëåâñòâà
' 752; SEK; 10; Øâåäñêèõ êðîí
' 756; CHF; 1; Øâåéöàðñêèé ôðàíê
' 392; JPY; 100; ßïîíñêèõ èåí
'
 
Dim sURI As String, oHttp As Object, HTMLcode, OutStr As String
Dim d As String, m As String, y As String, divider As Double
Dim foundRate As String, foundCount As String
Dim pLeft As Long, pRight As Long
 
GetCurrencyRate = 0
 
d = Format(rDate, "dd"): m = Format(rDate, "mm"): y = Format(rDate, "yyyy")
 
sURI = "http://www.cbr.ru/scripts/XML_daily.asp?date_req=" & d & "/" & m & "/" & y
      '"http://www.cbr.ru/scripts/XML_daily.asp?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
Exit Function
End If
oHttp.Open "GET", sURI, False
oHttp.Send
HTMLcode = oHttp.responseText:  Set oHttp = Nothing
' îïðåäåëÿåì íà÷àëî ñòðîêè ñ èñêîìûì êîäîì âàëþòû
pLeft = InStr(InStr(1, HTMLcode, UCase(cCode)) + Len(cCode), HTMLcode, "<Nominal>") + Len("<Nominal>")
' âûäåëÿåì ÷èñëî åäåíèö çà êîòîðîå óêàçàíà öåíà
pRight = InStr(pLeft, HTMLcode, "Nominal>")
foundCount = Mid(HTMLcode, pLeft, pRight - pLeft)
' ìåæäó ýòèìè ñêîáêàìè íàõîäèòñÿ öèôðà â âèäå ñòðîêè, êîòîðàÿ ÿâëÿåòñÿ êîëè÷åñòâîì åäèíèö âàëþòû, ïðåîáðàçîâûâàåì â ÷èñëî
divider = Val(foundCount)
' èùåì êóðñ âàëþòû
pLeft = InStr(pRight, HTMLcode, "Value") + Len("/Value")
pRight = InStr(pLeft, HTMLcode, "/Value") - 1
foundRate = Mid(HTMLcode, pLeft, pRight - pLeft)
' áåð¸ì ñèìâîëû êóðñà âàëþòû ìåæäó ýòèõ ãðàíèö, ïðåîáðàçîâûâàåì â òèï Double è äåëèì íà êîëè÷åñòâî åäèíèö âàëþòû
GetCurrencyRate = CDbl(foundRate) / divider
'Íà íåêîòîðûå âàëþòû êóðñ âûñòàâëÿåòñÿ íå êðàòíûé 1, ïîýòîìó äåëèì íà êðàòíîñòü êóðñà
End Function

Добавлено через 20 минут
на сайте цбр есть функция GetCurrencyRate(rDate As Date, cCode As String)
поищите ее

у меня при копировании кракозябры вылезли

@Hugo121 · 27.06.2018, 10:35

Не умеете копировать - нужно сперва раскладку сменить.

@Krapivnik · 27.06.2018, 11:29

Сообщение от Spec_0994

подскажите как сделать, что бы был виден в этой форме только курс доллара код 840, другие не интересуют.

В обработчике нажатия кнопки добавил условие в парсер xml:

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
For iIndex = 0 To nodeList.length - 1
   If InStr(nodeList.Item(iIndex).XML, "R01235") <> 0  
      'получаем копию узла с индексом iIndex из коллекции узлов со всеми дочерними узлами
       Set xmlNode = nodeList.Item(iIndex).cloneNode(True)
       'Заполняем поле "дата курса"
       strS = strS & ";" & xdate
 
      'цикл по всем дочерним узлам выбранного узла
        For i = 0 To xmlNode.childNodes.length - 1
         'значение узла записываем в строку-источник списка
              strS = strS & ";" & xmlNode.childNodes(i).Text
         Next
    End If
Next

R01235 - код валюты доллар в xml от Центробанка

@Krapivnik · 27.06.2018, 11:37

Сообщение от Krapivnik

В обработчике нажатия кнопки добавил условие в парсер xml:

Exit For перед End If еще не помешает

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
For iIndex = 0 To nodeList.length - 1
   If InStr(nodeList.Item(iIndex).XML, "R01235") <> 0  
      'получаем копию узла с индексом iIndex из коллекции узлов со всеми дочерними узлами
       Set xmlNode = nodeList.Item(iIndex).cloneNode(True)
       'Заполняем поле "дата курса"
       strS = strS & ";" & xdate
 
      'цикл по всем дочерним узлам выбранного узла
        For i = 0 To xmlNode.childNodes.length - 1
         'значение узла записываем в строку-источник списка
              strS = strS & ";" & xmlNode.childNodes(i).Text
         Next
     Exit For 
    End If
Next

Новые блоги и статьи Все статьи Все блоги /
SDL3 для Web (WebAssembly): Реализация движения на Box2D v3 - трение и коллизии с повёрнутыми стенами 8Observer8 20.02.2026 Содержание блога Box2D позволяет легко создать главного героя, который не проходит сквозь стены и перемещается с заданным трением о препятствия, которые можно располагать под углом, как верхнее. . .	Конвертировать закладки radiotray-ng в m3u-плейлист damix 19.02.2026 Это можно сделать скриптом для PowerShell. Использование . \СonvertRadiotrayToM3U. ps1 <path_to_bookmarks. json> Рядом с файлом bookmarks. json появится файл bookmarks. m3u с результатом. # Check if. . .	Семь CDC на одном интерфейсе: 5 U[S]ARTов, 1 CAN и 1 SSI Eddy_Em 18.02.2026 Постепенно допиливаю свою "многоинтерфейсную плату". Выглядит вот так: https:/ / www. cyberforum. ru/ blog_attachment. php?attachmentid=11617&stc=1&d=1771445347 Основана на STM32F303RBT6. На борту пять. . .	Камера Toupcam IUA500KMA Eddy_Em 12.02.2026 Т. к. у всяких "хикроботов" слишком уж мелкий пиксель, для подсмотра в ESPriF они вообще плохо годятся: уже 14 величину можно рассмотреть еле-еле лишь на экспозициях под 3 секунды (а то и больше),. . .
И ясному Солнцу zbw 12.02.2026 И ясному Солнцу, и светлой Луне. В мире покоя нет и люди не могут жить в тишине. А жить им немного лет.	«Знание-Сила» zbw 12.02.2026 «Знание-Сила» «Время-Деньги» «Деньги -Пуля»	SDL3 для Web (WebAssembly): Подключение Box2D v3, физика и отрисовка коллайдеров 8Observer8 12.02.2026 Содержание блога Box2D - это библиотека для 2D физики для анимаций и игр. С её помощью можно определять были ли коллизии между конкретными объектами и вызывать обработчики событий столкновения. . . .	SDL3 для Web (WebAssembly): Загрузка PNG с прозрачным фоном с помощью SDL_LoadPNG (без SDL3_image) 8Observer8 11.02.2026 Содержание блога Библиотека SDL3 содержит встроенные инструменты для базовой работы с изображениями - без использования библиотеки SDL3_image. Пошагово создадим проект для загрузки изображения. . .

@Hugo121 6998 / 2896 / 555 Регистрация: 19.10.2012 Сообщений: 8,804
	27.06.2018, 10:35
	Не умеете копировать - нужно сперва раскладку сменить. 0