Добрый вечер! Баловался с попыткой вытащить котировки цен на золото в реальном времени, может кому будет интересен результат. Автоматический запрос делать не стал, запускается кнопкой, так как практической ценности не имеет, просто делал для тренировки. Также не стал включать в результаты алюминий и всякие другие вещи, типа урана. На сайте данные обновляются каждые несколько минут. Работает через Internet Explorer, так что его наличие обязательно в системе. Иногда "задумывается" секунд на 15 при открытии страницы.
Скрытый текст
Код
Option Base 1
Dim a(12) As String
Sub ЗаполнениеТекстБоксов()
'aequit 04.03.2020
Dim i As Long
Call ПарсерКотировок
For i = 1 To 12
UserForm1.Controls("TB" & i) = a(i)
If (i = 3 Or i = 4 Or i = 9 Or i = 10) And Left(a(i), 1) = "+" Then
UserForm1.Controls("TB" & i).ForeColor = 5287936
ElseIf (i = 3 Or i = 4 Or i = 9 Or i = 10) And Left(a(i), 1) = ChrW(8722) Then
UserForm1.Controls("TB" & i).ForeColor = 255
End If
Next i
End Sub
Sub ПарсерКотировок()
'Автор: https://excelvba.ru/code/GetHTTPResponse
Dim IExp As Object, addr$, t$, i&
Set IExp = CreateObject("InternetExplorer.Application")
On Error Resume Next
addr$ = "https://www.kitco.com/mining/"
IExp.Navigate addr$
While IExp.Busy Or (IExp.ReadyState <> 4): DoEvents: Wend
t = IExp.Document.body.innerText
IExp.Quit: Set IExp = Nothing
'aequit 03.03.2020
a(1) = RegExRepl(t, "([\s\S]*Gold[\s\S]*?Ask)(\d{1,6}\.\d{2})(\d{1,6}\.\d{2})([\s\S]*?Change[\s\S]*)", 1)
a(2) = RegExRepl(t, "([\s\S]*Gold[\s\S]*?Ask)(\d{1,6}\.\d{2})(\d{1,6}\.\d{2})([\s\S]*?Change[\s\S]*)", 2)
a(3) = RegExRepl(t, "([\s\S]*Gold[\s\S]*?Change)([-+]\d{1,6}\.\d{2})([-+])([\s\S]*?Low[\s\S]*)", 1)
a(4) = RegExRepl(t, "([\s\S]*Gold[\s\S]*?Change)([-+]\d{1,6}\.\d{2})([-+]\d{1,6}\.\d{2}%)([\s\S]*?Low[\s\S]*)", 2)
a(5) = RegExRepl(t, "([\s\S]*Gold[\s\S]*?High)(\d{1,6}\.\d{2})(\d{1,6}\.\d{2})([\s\S]*?Silver[\s\S]*)", 1)
a(6) = RegExRepl(t, "([\s\S]*Gold[\s\S]*?High)(\d{1,6}\.\d{2})(\d{1,6}\.\d{2})([\s\S]*?Silver[\s\S]*)", 2)
a(7) = RegExRepl(t, "([\s\S]*Silver[\s\S]*?Ask)(\d{1,6}\.\d{2})(\d{1,6}\.\d{2})([\s\S]*?Change[\s\S]*)", 1)
a(8) = RegExRepl(t, "([\s\S]*Silver[\s\S]*?Ask)(\d{1,6}\.\d{2})(\d{1,6}\.\d{2})([\s\S]*?Change[\s\S]*)", 2)
a(9) = RegExRepl(t, "([\s\S]*Silver[\s\S]*?Change)([-+]\d{1,6}\.\d{2})([-+])([\s\S]*?Low[\s\S]*)", 1)
a(10) = RegExRepl(t, "([\s\S]*Silver[\s\S]*?Change)([-+]\d{1,6}\.\d{2})([-+]\d{1,6}\.\d{2}%)([\s\S]*?Low[\s\S]*)", 2)
a(11) = RegExRepl(t, "([\s\S]*Silver[\s\S]*?High)(\d{1,6}\.\d{2})(\d{1,6}\.\d{2})([\s\S]*?Prices in[\s\S]*)", 1)
a(12) = RegExRepl(t, "([\s\S]*Silver[\s\S]*?High)(\d{1,6}\.\d{2})(\d{1,6}\.\d{2})([\s\S]*?Prices in[\s\S]*)", 2)
For i = 1 To 12
a(i) = Replace(Replace(Replace(a(i), ".", ","), "%", ChrW(8198) & "%"), "-", ChrW(8722))
Next i
End Sub
Function RegExRepl(sString$, sPattern As String, lItem As Long) As String
'aequit 03.03.2020
Static RegEx As RegExp
Dim objMatches As MatchCollection
If RegEx Is Nothing Then Set RegEx = New RegExp
With RegEx
.Global = False
.MultiLine = True
.IgnoreCase = False
.Pattern = sPattern
End With
If Not RegEx.Test(sString) Then
RegExRepl = ""
Exit Function
End If
Set objMatches = RegEx.Execute(sString)
RegExRepl = RegEx.Execute(sString)(0).SubMatches.Item(lItem)
End Function
Что-то в Вашем файле ни той самой кнопки, ни примера выводимого результата нет. При попытке запустить макрос ничего не происходит у меня.
Я могу ошибаться, так как не вижу результата, но мне кажется, что код Power Query буквально из двух строк- даст примерно тот же результат и без заморочек с браузером.
Код
let
Source = Web.Page(Web.Contents("https://www.kitco.com/mining/")),
Headers = Table.PromoteHeaders(Source{1}[Data], [PromoteAllScalars=true])
in
Headers
Dyroff написал: При попытке запустить макрос ничего не происходит
Макрос запускается из формы, которая, соответственно, запускается из модуля книги при загрузке файла:
Код
Private Sub Workbook_Open()
UserForm1.Show 0
End Sub
Странно, что у Вас форма при открытии файла не запустилась, если макросы разрешены...
Цитата
Dyroff написал: код Power Query буквально из двух строк
Спасибо за вариант, даже не предполагал, что PQ можно использовать для парсинга сайтов, обязательно изучу эту возможность. Я в своём варианте больше практиковался с написанием паттернов регулярных выражений, которые наиболее однозначно вытаскивали нужные группы символов из большого и довольно сложного текста (спарсенного из веб-страницы).
Да и через VBA куда быстрее и проще без IE вытаскивать такую инф-цию:
Код
Function Get_MetallRate()
Dim res, response As String
Dim oXMLHTTP As Object
Dim lp As Long, le As Long
Dim sfnd As String
On Error Resume Next
Set oXMLHTTP = CreateObject("MSXML2.XMLHTTP")
If oXMLHTTP Is Nothing Then
Exit Function
End If
With oXMLHTTP
.Open "GET", "https://www.kitco.com/mining/", False
.send
Do While .readyState <> 4
DoEvents
Loop
response = .responseText
End With
On Error GoTo 0
If Len(response) Then
response = LCase(Trim(Replace(Replace(Replace(response, vbTab, ""), vbNewLine, ""), " ", "")))
lp = InStr(1, response, "<td><h4>Gold</h4></td>", 1)
If lp > 0 Then
sfnd = "<td>Bid/Ask</td><td>"
If lp > 0 Then
lp = InStr(lp, response, sfnd, 1)
le = InStr(lp + Len(sfnd), response, "</td>", 1)
res = Mid(response, lp + Len(sfnd), le - lp - Len(sfnd))
End If
End If
End If
res = Val(Replace(Replace(res, " ", ""), ",", "."))
Get_MetallRate = res
End Function
Change и Low/High можно прям здесь же вытягивать без проблем, как и использовать вместо статичного Gold передаваемый в функцию параметр.
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
Дмитрий(The_Prist) Щербаков, спасибо, забрал вариант решения получения текста сайта из объекта MSXML2.XMLHTTP (командой oXMLHTTP.responseText) "в закрома". Перепробовал множество примеров получения кода html страницы, к сожалению, на многих сайтах спарсенный html не содержит нужных данных, которые можно получить, только сохранив именно текст web-страницы. Найденный единственный пример использовал для сохранения текста открытие в фоне Internet Explorer. Оказывается, можно всё сделать проще.
IE используется именно в тех случаях, когда доступа к HTML коду нет или нужные данные формируются скриптом(в этом случае сформированные данные внутри разметки не отображаются - только текст скрипта). Тогда бывает проще использовать InnerText из IE, чтобы получить именно отображаемый на странице текст, а не текст разметки.
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...