Страницы: 1
RSS
Извлечение ссылок на картинки, Извлечь со страницы все ссылки на саму картинку из определенного контейнера html
 
добрый день.
необходимо подредактировать макрос, чтобы он вытягивал ссылки на все картинки из определенного контейнера html
код html (тэг "а" с атрибутом "data-fancybox-group" ) - <a data-fancybox-group...>
если такого контейнера нет, то другие ссылки на картинки не извлекать.
и возможно ли если таких контейнеров 2 и более, то из каждого вытянуть ссылку на картинку и поместить в одну ячейку через запятую ","

сейчас макрос вытягивает только первую ссылку на картинку по шаблону, но такой шаблон присутствует и в не нужном контейнере
Скрытый текст

насколько я понимаю в функцию "dann" нужно добавить еще один паттерн ("<a data-fancybox-group ") и сделать вложенные условия через цикл (по количеству найденных контейнеров).

что то вроде следующего

Скрытый текст

 
Lex396, добрый день!

Что-то вроде этого?
Возвращаете функцией коллекцию со ссылками и далее работаете с листом.
Код
     Set REGEXP = CreateObject("VBScript.RegExp")
     REGEXP.IgnoreCase = True
     REGEXP.Global = True
     REGEXP.MultiLine = True
     REGEXP.Pattern = "data-fancybox-group=(.*?) href=""(.*?)"""
     If REGEXP.Test(t) Then
        Set Matches = REGEXP.Execute(t)
        Set List = CreateObject("Scripting.Dictionary")
        For Each m In Matches
            List.Add m.SubMatches(1), Nothing
        Next
     End If
 
в VBA не то что не силен, а вообще никакой

в основном теле добавил переменную типа коллекция
этой переменной передаю коллекцию из функции dann
и циклом For Each перебираем коллекцию и содержимое помещаем в ячейку

Код
Sub Avtolev()
    Dim t$, URL$, i As Long, Cl As Collection
    For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
        URL = URLEncode(Cells(i, "F"))
    With CreateObject("msxml2.xmlhttp")
        .Open "GET", URL, False
        .send
        Do: DoEvents: Loop Until .readyState = 4
        t = .responseText
        Set Cl = dann(t)
        For Each c In Cl
            Cells(i, "G") = c
        Next
        If Cells(i, "G") = "" Then
           Cells(i, "G") = "нет картинки"
        End If
    End With
    Next
End Sub


дебагер ругается на строчку

Set Cl = dann(t)

а вот почему пока понять не могу...
Изменено: Lex396 - 08.08.2019 17:35:25
 
Lex396, упростим, избавимся от коллекций(я там немного не то написал) и будем использовать массив для ссылок.

Поправим метод, ссылки будут добавляться в новых столбцах
Код
        With CreateObject("msxml2.xmlhttp")
            .Open "GET", URL, True
            .send
            Do: DoEvents: Loop Until .readyState = 4
            t = .responseText
            arr = dann(t)
            If Not IsEmpty(arr) Then
                For j = 0 To UBound(arr)
                    Cells(i, 7 + j) = "http:" & arr(j)
                Next
            Else
                Cells(i, 7) = "нет картинки"
            End If
        End With
Функция
Код
    With CreateObject("VBScript.RegExp")
        .IgnoreCase = True
        .Global = True
        .MultiLine = True
        .Pattern = "data-fancybox-group=(.*?) href=""(.*?)"""
        If .Test(t) Then
            Set Matches = .Execute(t)
            ReDim arr(Matches.Count - 1)
            For i = 0 To Matches.Count - 1
                arr(i) = Matches(i).SubMatches(1)
            Next
            dann = arr
            Set Matches = Nothing
        End If
    End With
 
большое спасибо за помощь.
Страницы: 1
Наверх