mail mail
Нужен макрос для Excel?
Сделайте заказ прямо сейчас!
Ищете готовое решение?
Выбирайте и покупайте!
У вас есть интернет-магазин?
Настроим парсер под любой сайт!

Работа с HTML: поиск тегов (RegExp) и преобразование HTML в текст

В данной статье приведён код 2 функций, которые позволят вам найти на веб-странице нужные HTML теги,
и преобразовать HTML в текст

Особенность этого кода, - использование регулярных выражений (Regexp) для поиска в HTML

Эти функции лежат в основе моей надстройки «Парсер сайтов»

Пример использования:

' в переменной txt находится исходный код веб-страницы (целиком, или его часть)

' ищем div id="mod-lists", и берем его начинку (innerHTML)
' Индекс 1 после innerHTML означает, что если будет найдено несколько таких тегов, - макрос возьмет только первый
res = GetTags(txt, "div", "id", "mod-lists", "innerHTML 1")
 
 
' ищем ВСЕ теги span класса product (функция вернёт массив значений в переменную arr)
arr = Split(GetTags(txt, "span", "class", "product", "outerHTML"), ARSEP)
 
 
' ищем гиперссылку (тег a класса blue-link), и возвращаем атрибут href
link$ = GetTags(txt, "a", "class", "blue-link", "href")
 
 
' ищем ЛЮБОЙ ТЕГ класса price, и берем последний найденный (last), преобразовав его в текст (ConvertToText)
price = GetTags(txt, "any tag", "class", "price", "ConvertToText last")

Есть возможность удалять теги из HTML (параметр DeleteTags), а также использовать подстановочный символ * до или после значения атрибута.
Можно также выполнять поиск по маске для атрибутов:

' в переменной txt находится исходный код веб-страницы (целиком, или его часть)

' удаляем все div, где имя класса начинается с old
txt = GetTags(txt, "div", "class", "old*", "DeleteTags")
 
 
' ищем ВСЕ гиперссылки по маске /item/
links_array = Split(GetTags(txt, "a", "AttributesPattern", "*/item/*", "href"), ARSEP)

Функцией преобразования HTML в текст (ConvertHTMLtoText) можно воспользоваться отдельно (без функции GetTags)

Весь приведённый ниже код, скопируйте в отдельный стандартный модуль

'---------------------------------------------------------------------------------------
' Module        : modHTML                          excelvba.ru/programmes/Parser
' Author        : Igor Vakhnenko                   Date: 21.02.2016
' info @ excelvba.ru                               Skype: ExcelVBA.ru
'---------------------------------------------------------------------------------------

Public Const ARSEP$ = "%~$"
 
Function REGEXP()
    On Error Resume Next
    Static REGEXP_ As Object
    If REGEXP_ Is Nothing Then Set REGEXP_ = CreateObject("VBScript.RegExp"): REGEXP_.Global = True
    Set REGEXP = REGEXP_
End Function
 
Function GetTags(ByVal txt$, ByVal TagName$, Optional ByVal AttrName$, Optional ByVal AttrValue$, Optional ByVal Result$ = "outerHTML") As String
    ' функция выполняет поиск заданного HTML-тега (или атрибута тега) в HTML коде
    On Error Resume Next
    Dim res$, Pattern$, SelfClosing As Boolean, NeedContent As Boolean, ResultType$, ResultIndex$, ResultsCount&, ind&
    Dim PatternPrefix$, PatternSuffix$, AttrValuePattern$, Add_URL_Prefix$
    Const SelfClosingTags = ",area,base,basefont,br,col,frame,hr,img,input,isindex,link,meta,param,embed,"
    Const ASTERISK_PATTERN = "[A-Za-z0-9_-]*"
    AttrName$ = Trim(AttrName$): AttrValue$ = Trim(AttrValue$): TagName$ = Trim(TagName$)
    If TagName$ = "Any Tag" Then TagName$ = "[a-zA-Z1-6]+"
    If TagName$ = "" Then GetTags = "GetTags ERROR: 'TagName' parameter is blank": Exit Function
 
    If InStr(1, AttrValue$, "*") Then
        If AttrValue$ Like "[*]*" Then AttrValue$ = ASTERISK_PATTERN & Mid(AttrValue$, 2)
        If AttrValue$ Like "*[A-Za-z0-9_-][*]" Then AttrValue$ = Left(AttrValue$, Len(AttrValue$) - 1) & ASTERISK_PATTERN
    End If
    PatternPrefix$ = "<(" & TagName$ & ")\b"
    PatternSuffix$ = "[^>]*>"
    Select Case True
        Case AttrName$ & AttrValue$ = ""        ' поиск заданных тегов
            Pattern$ = PatternPrefix$ & PatternSuffix$
 
        Case AttrName$ = "AttributesPattern"        ' поиск тега по шаблону regexp для его заголовка
            If InStr(1, AttrValue$, ">") + InStr(1, AttrValue$, "<") Then _
               GetTags = "GetTags ERROR: 'AttributeValue' parameter contains unacceptable symbols ('<' or '>')": Exit Function
            Pattern$ = PatternPrefix$ & "[^>]*" & AttrValue$ & PatternSuffix$
 
        Case Else        ' поиск тегов по атрибуту name / id / class
            AttrValuePattern$ = "(?:(?:" & AttrValue$ & "\b)|(?:['""](|[^<>'""]* )\b" & AttrValue$ & "\b(| [^<>'""]*)['""]))"
            Pattern$ = PatternPrefix$ & "[^>]*\b" & AttrName$ & "\s*=\s*" & AttrValuePattern$ & PatternSuffix$
    End Select
 
    Result$ = Application.Trim(Result$): If Result$ = "" Then GetTags = "GetTags ERROR: 'Result' parameter is blank": Exit Function
    ResultType$ = Split(Result$)(0)
    ResultIndex$ = Split(Result$, , 2)(1)
 
 
    SelfClosing = SelfClosingTags Like "*," & TagName$ & ",*"
    NeedContent = InStr(1, "|innerHTML|outerHTML|ConvertToText|DeleteTags|", "|" & ResultType$ & "|") > 0
 
    Dim v, content$, cnt&, i&, TextAfterHeader$, TagHeader$, attr$, txtlen&, NN&
    With REGEXP
        .IgnoreCase = True: .Pattern = Pattern$
StartSearching:
        If .test(txt) Then
            For Each v In .Execute(txt)
                DoEvents
                TagHeader$ = "": TagHeader$ = v.Value
 
                If NeedContent And Not SelfClosing Then
                    TagName$ = v.submatches.Item(0)
                    TextAfterHeader$ = "": TextAfterHeader$ = Mid(txt, v.FirstIndex + Len(TagHeader$) + 1)
                    content$ = GetTagInnerHTML(TextAfterHeader$, TagName$)
                    If (ResultType$ = "outerHTML") Or (ResultType$ = "DeleteTags") Then
                        content$ = TagHeader$ & content$ & "</" & TagName$ & ">"
                    End If
                Else
                    content$ = TagHeader$
                End If
                Select Case ResultType$
                    Case "innerHTML", "outerHTML", "TagHeaderOnly"        ' do nothing
                    Case "DeleteTags"
                        txtlen& = Len(txt): txt = Replace(txt, content$, "")
                         ' защита от зацикливания, - если замена не выполнилась, то больше не пытаемся
                       content$ = "": If Len(txt) < txtlen& Then GoTo StartSearching
                    Case "ConvertToText"        ' convert to text
                        content$ = ConvertHTMLtoText(content$)
                    Case Else        ' get attribute value
                        attr$ = "": content$ = Split(content$, ">")(0)
                        content$ = Replace(Replace(content$, "= ", "="), " =", "=")
                        attr$ = Trim(Split(content$, " " & ResultType$ & "=", 2)(1))
                        Select Case Mid(attr$, 1, 1)
                            Case """", "'": attr$ = Split(attr$, Mid(attr$, 1, 1))(1)
                            Case Else: attr$ = Split(attr$, " ")(0)
                        End Select
                        content$ = ConvertHTMLtoText(attr$)        ' для замены  &amp; на & (и подобных других замен)
                       
                End Select
 
                If Len(content$) Then
                    ResultsCount& = ResultsCount& + 1
                    GetTags = GetTags & IIf(Len(GetTags), ARSEP, "") & content$
                    If Val(ResultIndex$) Then If Val(ResultIndex$) = ResultsCount& Then GetTags = content$: Exit Function
                End If
            Next
        End If
    End With
 
    If ResultType$ = "DeleteTags" Then GetTags = txt: Exit Function
 
    If ResultIndex$ = "join" Then GetTags = Replace(GetTags, ARSEP, vbNewLine): Exit Function
 
    If Len(ResultIndex$) * Len(GetTags) Then        ' если указан номер элемента массива
        If InStr(1, ResultIndex$, "last", vbTextCompare) > 0 Then
            ind& = UBound(Split(GetTags, ARSEP)) + Val(Split(ResultIndex$, "last")(1))
        Else
            ind& = Fix(Val(ResultIndex$)) - 1
        End If
 
        If ind& >= 0 And ind& <= UBound(Split(GetTags, ARSEP)) Then
            GetTags = Split(GetTags, ARSEP)(ind&)
        Else
            GetTags = ""
        End If
    End If
End Function
Function GetTagInnerHTML(ByVal txt$, ByVal TagName$) As String
    On Error Resume Next
    Dim ClosingTag$, arr, i&, nOPENING&
    ClosingTag$ = "</" & TagName$ & ">"
    If InStr(1, txt, ClosingTag$, vbTextCompare) = 0 Then Exit Function
    arr = Split(txt, ClosingTag$, , vbTextCompare)
    For i = LBound(arr) To UBound(arr) - 1        ' если убрать -1, то будет выводить и содержимое незакрытого тега (до конца текста в txt$)
        If Len(arr(i)) Then
            nOPENING& = nOPENING& + UBound(Split(arr(i), "<" & TagName$ & ">")) + UBound(Split(arr(i), "<" & TagName$ & " "))
        End If
        GetTagInnerHTML = GetTagInnerHTML & arr(i) & IIf(nOPENING& <> i, ClosingTag$, "")
        If nOPENING& = i Then Exit Function
    Next i
    GetTagInnerHTML = ""
End Function
Function ConvertHTMLtoText(ByVal txt$, Optional RemoveExtraLF As Boolean = False) As String
    ' Функция преобразует HTML в текст без использования DOM
    ' Создание функции было обусловлено утечками памяти при использовании библиотеки MSHTML
    On Error Resume Next
    Const HTML_SP$ = "nbsp=32;pound=163;euro=8364;para=182;sect=167;copy=169;reg=174;trade=8482;deg=176;plusmn=177;frac14=188;frac12=189;" & _
          "frac34=190;times=215;divide=247;fnof=402;Alpha=913;Beta=914;Gamma=915;Delta=916;Epsilon=917;Zeta=918;Eta=919;Theta=920;" & _
          "Iota=921;Kappa=922;Lambda=923;Mu=924;Nu=925;Xi=926;Omicron=927;Pi=928;Rho=929;Sigma=931;Tau=932;Upsilon=933;Phi=934;" & _
          "Chi=935;Psi=936;Omega=937;alpha=945;beta=946;gamma=947;delta=948;epsilon=949;zeta=950;eta=951;theta=952;iota=953;kappa=954;" & _
          "lambda=955;mu=956;nu=957;xi=958;omicron=959;pi=960;rho=961;sigma=963;tau=964;upsilon=965;phi=966;chi=967;psi=968;omega=969;" & _
          "sigmaf=962;larr=8592;uarr=8593;rarr=8594;darr=8595;harr=8596;spades=9824;clubs=9827;hearts=9829;" & _
          "diams=9830;quot=34;amp=38;lt=60;gt=62;hellip=8230;prime=8242;ndash=8211;mdash=8212;lsquo=8216;rsquo=8217;sbquo=8218;" & _
          "ldquo=8220;rdquo=8221;bdquo=8222;laquo=171;raquo=187;ensp=8194;emsp=8195;shy=173;ordm=186;ordf=170;permil=8240;brvbar=166;" & _
          "micro=181;oline=8254;acute=180;sup1=185;sup2=178;sup3=179;not=172;frasl=8260;minus=8722;le=8804;ge=8805;asymp=8776;ne=8800;" & _
          "equiv=8801;radic=8730;infin=8734;sum=8721;prod=8719;part=8706;int=8747;forall=8704;exist=8707;empty=8709;Oslash=216;" & _
          "isin=8712;notin=8713;ni=8727;sub=8834;sup=8835;nsub=8836;sube=8838;supe=8839;oplus=8853;otimes=8855;perp=8869;ang=8736;" & _
          "and=8743;or=8744;cap=8745;cup=8746;cent=162;current=164;yen=165;bull=8226;middot=183;loz=9674;crarr=8629"
 
    Const ADD_TAB$ = "</th><th>,</td><td>"
    Const ADD_NL$ = "<div>,<p>,<table>,</table>,<img>,<h1>,<h2>,<h3>,<h4>,<h5>,<h6>,<br>,<hr>,</tr>,</li>"
 
    Dim Tag, char, arr, cnt&, i&
    With REGEXP
 
        ' удаляем все комменты из HTML
        If txt$ Like "*<!--*-->*" Then
            arr = "": arr = Split(txt, "<!--")
            For i = LBound(arr) + 1 To UBound(arr)
                cnt& = 0: cnt& = UBound(Split(arr(i), "-->"))
                If cnt& = 0 Then arr(i) = "" Else arr(i) = Split(arr(i), "-->")(cnt&)
            Next i
            txt = Join(arr, "")
        End If
        txt$ = CloseUnclosedTags(txt$)
        ' очистка тегов
        .Pattern = "(<[A-Za-z1-6]+)[^<>]*(>)"
        txt$ = .Replace(txt$, "$1$2")        ' удаляем все атрибуты у тегов
        .Pattern = ">\s*<"
        txt$ = .Replace(txt$, "><")        ' удаляем пробелы и переводы строк между тегами

        ' удаляем все скрипты
        If txt$ Like "*<script>*</script>*" Then
            arr = "": arr = Split(txt, "<script>")
            For i = LBound(arr) + 1 To UBound(arr)
                cnt& = 0: cnt& = UBound(Split(arr(i), "</script>"))
                If cnt& = 0 Then arr(i) = "" Else arr(i) = Split(arr(i), "</script>")(cnt&)
            Next i
            txt = Join(arr, "")
        End If
 
        ' берём содержимое тега <body>
        If txt Like "*<body>*" Then txt = Split(txt, "<body>")(1)
 
        txt = Replace(txt, vbNewLine, vbLf): txt = Replace(txt, vbLf, vbNewLine)
        MultiReplace txt, "<br>" & vbNewLine, "<br>"
        MultiReplace txt, vbNewLine & "<br>", "<br>"
 
        ' добавляем переводы строк и табуляцию между ячейками таблиц
        For Each Tag In Split(ADD_NL$, ",")
            txt = Replace(txt, Tag, vbNewLine, , , vbTextCompare)
        Next Tag
        For Each Tag In Split(ADD_TAB$, ",")
            txt = Replace(txt, Tag, vbTab, , , vbTextCompare)
        Next Tag
 
        ' удаляем оставшиеся теги
        .Pattern = "<[^<>]+>"
        txt$ = .Replace(txt$, "")
        ' заменяем коды спецсимволов на сами символы
        For Each char In Split(HTML_SP$, ";")        ' сначала - символы, которые имеют названия типа &сopy; и &nbsр;
            If InStr(1, txt$, Split(char, "=")(0), vbBinaryCompare) Then
                txt$ = Replace(txt$, "&" & Split(char, "=")(0) & ";", ChrW(Val(Split(char, "=")(1))), , , vbBinaryCompare)
            End If
        Next char
        .Pattern = "&#(\d{2,5});"        ' а теперь - спецсимволы, представленные кодами вида &#84l0;
        If .test(txt$) Then
            For Each char In .Execute(txt)
                txt$ = Replace(txt$, char.Value, ChrW(Val(char.submatches.Item(0))))
            Next
        End If
 
        ' убираем лишние переводы строк, пробелы и табуляторы
        MultiReplace txt, " " & vbTab, vbTab: MultiReplace txt, vbTab & " ", vbTab
        MultiReplace txt, vbTab & vbNewLine, vbNewLine: MultiReplace txt, vbNewLine & vbTab, vbNewLine
        MultiReplace txt$, vbNewLine & vbNewLine & vbNewLine, vbNewLine & vbNewLine
        MultiReplace txt, vbNewLine & " " & vbNewLine, vbNewLine
        MultiReplace txt, " " & vbNewLine, vbNewLine
 
        If RemoveExtraLF Then MultiReplace txt$, vbNewLine & vbNewLine, vbNewLine
 
        While txt$ Like "*" & vbNewLine: txt = Left(txt, Len(txt) - Len(vbNewLine)): Wend
        While txt$ Like vbNewLine & "*": txt = Mid(txt, Len(vbNewLine) + 1): Wend
 
    End With
    Erase arr: Err.Clear
    ConvertHTMLtoText = txt$
End Function
Sub MultiReplace(ByRef txt$, ByVal Find$, ByVal Replacement$)
    On Error Resume Next: Dim n&
    If InStr(1, Replacement$, Find$, vbBinaryCompare) Then Exit Sub        ' чтобы избежать зацикливания и переполнения
    While (InStr(1, txt$, Find$, vbBinaryCompare) > 0) And (n < 100)
        n = n + 1: txt$ = Replace(txt$, Find$, Replacement$)
    Wend
End Sub
 
Function CloseUnclosedTags(ByVal txt$) As String
    On Error Resume Next: CloseUnclosedTags = txt$: Dim char
    With REGEXP
        .Pattern = "(<[A-Za-z1-6]+\b[^<>]*)(<[A-Za-z1-6]+\b)"
        If .test(txt$) Then CloseUnclosedTags = .Replace(txt$, "$1>$2")
    End With
End Function

Комментарии

Настройки просмотра комментариев

Выберите нужный метод показа комментариев и нажмите "Сохранить установки".

Елена, при помощи VBA можно сделать что угодно
«Клик по кнопке» можно сделать 2 способами:
1) используя браузер (IE), найти элемент, и вызвать для него функцию .Click
2) без браузера, - посмотреть в коде страницы, что за запрос отправляется на сервер при нажатии на кнопку, и выполнить этот запрос макросом.

Я не готов вам помогать с макросами по этой теме, - у меня есть готовая программа (парсер сайтов), которая всё это умеет.
Сидеть же писать отдельные макросы, только потому что «мощный софт» вам не нужен, мне лень.

А возможно ли по примощи vba сделать клик по спрайт кнопке? например: "icon sprite inline love sprite-button-love"

<html class="no-touch">
                <div class="icon sprite inline love sprite-button-love"> 
                </div>
</html>

и клик по ссылке

<html>
 <body class="oldShare">
               <div class="action-item favorite-recording">
                <a class="action-btn" href="javascript://">Favorite</a>
               </div>
 </body>
</html>

для примера структура страницы:
urlS="https://www.smule.com/p/1061154754_1232830398"

мне пока ещё сложна для понимания "смесь" HTML и VBA, но очень хочется разобраться :)
спасибо, за помощь!

Игорь, спасибо, но такой мощный софт мне не нужен/
пришлось немного импровизировать и вроде получилось, сели текст скрипта сплитовать
[vba]

Sub SmuleSing() ' пример использования
Application.ScreenUpdating = False
On Error Resume Next
txt = GetHTTPResponse("https://www.smule.com/listen/new/9")
txt = Replace(txt, ThisWorkbook.Sheets("element").Cells(1, 4), "")
For strElement = 1 To ThisWorkbook.Sheets("element").Cells(Rows.Count, 1).End(xlUp).Row
elementND = ThisWorkbook.Sheets("element").Cells(strElement, 1)
For cc = 1 To 26
If Split(Split(txt, elementND)(cc - 1), """")(0) = "" Then
ThisWorkbook.Sheets("#out").Cells(ThisWorkbook.Sheets("#out").Cells(Rows.Count, strElement).End(xlUp).Row + 1, strElement) = "Null"
Else
ThisWorkbook.Sheets("#out").Cells(ThisWorkbook.Sheets("#out").Cells(Rows.Count, strElement).End(xlUp).Row + 1, strElement) = Split(Split(txt, elementND)(cc - 1), """")(0)
End If
Next
Next strElement
ThisWorkbook.Sheets("#out").Range("$A$1:$D$" & ThisWorkbook.Sheets("#out").Cells(Rows.Count, 1).End(xlUp).Row).RemoveDuplicates Columns:=Array(1, 2, 3, 4), Header:=xlYes

ThisWorkbook.Sheets("#out").Cells(1, strElement + 1) = "-> " & ThisWorkbook.Sheets("#out").Cells(Rows.Count, 1).End(xlUp).Row - 1

Application.ScreenUpdating = True

End Sub
[/vba]
элементы на листе "element"
[a1]= "performance_key":"
[a2]= "ensemble_type":"
[a3]= "city":"
[a4]= "country":"
список записей выводится на лист "#out"

Елена, да, это возможно
Как настраивать (какие действия нужны) — показал на скриншоте:

Добрый день
подскажите пожалуйста, возможно ли функцией GetTags получить из
URLS = "https://www.smule.com/listen/new/9"
содержание
а именно из DataStore.Pages.Listen
Там при запросе 25 записей
нужны только значения всех этих элементов:
performance_key
ensemble_type
country

через innerHTML и content не получается

Получилось, большое спасибо

Попробуйте такой код:

Sub test()
    URL$ = "http://ExcelVBA.ru/"
 
    With CreateObject("MSXML2.XMLHTTP")    ' загружаем страницу
        .Open "GET", URL$, False: .send: txt = .responseText
    End With
 
    Title$ = GetTags(txt, "title", "", "", "innerHTML 1")
    MsgBox Title$, vbInformation, "title"
 
    Description$ = GetTags(txt, "meta", "name", "description", "content 1")
    MsgBox Description$, vbInformation, "meta description"
End Sub

title можно вытащить так - ie.document.title
вопрос с meta description остался нерешенным

Добрай день
Подскажите пожалуйста, можно ли функцию GetTags с этой страницы использовать для получения со страницы тайтлов и метатегов
GetTags(txt, "title", "", "", "innerHTML 1") - вот так не получилось

Отправить комментарий

Содержание этого поля является приватным и не предназначено к показу.
CAPTCHA
Подтвердите, пожалуйста, что вы - человек:
  _____   _             _  __  _____       _ 
| ____| | | __ _ __ | |/ / | ___| __| |
| _| | |/ / | '__| | ' / | |_ / _` |
| |___ | < | | | . \ | _| | (_| |
|_____| |_|\_\ |_| |_|\_\ |_| \__,_|
Введите код, изображенный в стиле ASCII-арт.

Не получается применить макрос? Не удаётся изменить код под свои нужды?

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