Работа с 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")

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

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

'---------------------------------------------------------------------------------------
' 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>,<dl>,<dt>"
 
    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