Excel это не сложно
Добро пожаловать, Гость. Пожалуйста, войдите или зарегистрируйтесь.
28.03.2024, 17:44:06

Войти
Добавляйтесь в нашу группу ВКонтакте - будьте в курсе всех новых событий сайта, узнавайте первым обо всех акциях и новых статьях!
33 233 Сообщений в 5 454 Тем от 6 750 Пользователей
Последний пользователь: Alex1210
*
Перейти на сайт Хитрости Надстройка MulTEx Обучающие тренинги Наша группа ВКонтакте
Правила форума Начало Помощь Поиск Календарь Войти Регистрация Выйти
+  Excel это не сложно
|-+  Основные форумы
| |-+  Вопросы по Excel и VBA
| | |-+  Получение метаданных с web-страницы по ссылке (ссылкам)
Страниц: [1]   Вниз
Печать
Автор Тема: Получение метаданных с web-страницы по ссылке (ссылкам)  (Прочитано 2307 раз)
0 Пользователей и 1 Гость смотрят эту тему.
user5555
Новичок
*

Репутация: +0/-0
Офлайн Офлайн

Сообщений: 6


Просмотр профиля
« : 04.04.2022, 15:22:47 »

Здравствуйте!

Прошу помощи в доведении до ума скрипта, который получает по web-ссылке определенные метаданные с web-страницы (если они там есть).

Есть страница вида https://www.elibrary.ru/item.asp?id= (например - https://www.elibrary.ru/item.asp?id=47557347).
Данные которые требуются: DOI: 10.17308/lic.2021.4/3805

Разумеется, для каждой страницы https://www.elibrary.ru/item.asp?id= сам id будет разный.
Эти данные присутствуют не на каждой странице.

Есть вот такой скрипт:
Код: (vb)

Sub getMetaData()
Dim ie As New InternetExplorer
Dim myLink As String
Dim wks As Worksheet

Set wks = Sheets("LS")
myLink = wks.Range("A1").Value
ie.Visible = True

ie.navigate myLink

Do
DoEvents
Loop Until ie.readyState = READYSTATE_COMPLETE

Const meta_tag As String = "meta"
Const meta_name As String = "doi"
Dim Doc As HTMLDocument
Dim metaElements As Object
Dim element As Object
Dim keywd As String

Set Doc = ie.document
Set metaElements = Doc.all.tags(meta_tag)

For Each element In metaElements
If element.Name = meta_name Then
keywd = element.Content
End If
Next

Range("B1").Value = keywd
Columns("B").AutoFit

End Sub


Скрипт получает данные только по 1 ссылке (в A1) и оставляет результат в B1.
В реальности же, в первом столбике (A) будет много ссылок - от 1 до 100 или больше.
Во втором столбике, соответственно, должны быть получены искомые значения (если есть), а когда этих значений на странице нет - тогда в строке напротив хотелось бы увидеть "нет данных".

p.s. Хотелось бы, чтобы при получении данных, эксель не "бомбил бы" сайт в целях избежания бана (нужен небольшой/вменяемый таймаут перебора страниц).

p.p.s. За "1 заход" требуется получить "пакет данных" с нескольких страниц, на которые можно выйти по ссылке (например) https://www.elibrary.ru/contents.asp?id=47557346&selid=47557347 (журнал). Внутри неё находятся ссылки вида https://www.elibrary.ru/item.asp?id= у которых меняется только id (статья).
А если уж можно сразу указать ссылку журнала, по которой эксель сможет автоматически пройти на каждую статью и выгрузить значения, - это будет "высший пилотаж". Буду рад любым методическим указаниям.
« Последнее редактирование: 04.04.2022, 15:33:33 от user5555 » Записан
Дмитрий Щербаков(The_Prist)
Администратор
Ветеран
*****

Репутация: +485/-0
Офлайн Офлайн

Сообщений: 5 828



Просмотр профиля WWW
« Ответ #1 : 04.04.2022, 15:33:23 »

По сути простой цикл решит проблема сканирования всех ссылок:
Код: (vb)
Sub getMetaData()
    Dim ie As New InternetExplorer
    Dim myLink As String
    Dim wks As Worksheet
   
    Const meta_tag As String = "meta"
    Const meta_name As String = "doi"
    Dim Doc As HTMLDocument
    Dim metaElements As Object
    Dim element As Object
    Dim keywd As String
    Dim lr As Long, llastr As Long
     
    Set wks = Sheets("LS")
    'получаем последнюю заполненную строку в столбце А
    llastr = wks.Cells(wks.Rows.Count, 1).End(xlUp).Row
    'цикл от первой строки до последней заполненной
    For lr = 1 To llastr
        myLink = wks.Range("A" & lr).Value
        ie.Visible = True
        ie.navigate myLink
        Do
            DoEvents
        Loop Until ie.readyState = READYSTATE_COMPLETE

        Set Doc = ie.document
        Set metaElements = Doc.all.tags(meta_tag)
        For Each element In metaElements
            If element.Name = meta_name Then
                keywd = element.Content
            End If
        Next
        Range("B" & lr).Value = keywd
    Next
    Columns("B").AutoFit
End Sub

Хотелось бы, чтобы при получении данных, эксель не "бомбил бы" сайт
нельзя получить данные, не зайдя на сайт. Т.е. бомбить в любом случае придется. Или что-то другое подразумевалось под "бомбил"?
Записан

Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
Пункты приёма Спасибов:    -41001332272872  -R298726502453
user5555
Новичок
*

Репутация: +0/-0
Офлайн Офлайн

Сообщений: 6


Просмотр профиля
« Ответ #2 : 04.04.2022, 15:37:08 »

Ухх! Класс!
То что нужно!
Спасибо огромное, так выручили!


Да, имел в виду под "бомбить" - частоту обращений на сайт.
Если можно это отрегулировать таймаутом, несколько секунд (имитация человеческой активности, просто на всякий случай), то будет вообще здорово.
С сайтом приходится работать, и не хотелось бы, чтобы в процессе работы система отправила во временный бан.
Записан
Дмитрий Щербаков(The_Prist)
Администратор
Ветеран
*****

Репутация: +485/-0
Офлайн Офлайн

Сообщений: 5 828



Просмотр профиля WWW
« Ответ #3 : 04.04.2022, 16:21:50 »

имитация человеческой активности
таймаут не гарантирует того, что сайт Вас в бан не отправит. Все зависит от того, как сам сайт настроен. Простой тайм-аут можно сделать так - после строки:
Код: (vb)
Range("B" & lr).Value = keywd

пишите такую:
Код: (vb)
    Dim iTimer
    iTimer = Timer
    Do While Format((Timer - iTimer) / 86400, "Long time") < "0:00:10" 'задержка в 10 секунд
        DoEvents
    Loop

нужное кол-во секунд выставляете и все.
Записан

Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
Пункты приёма Спасибов:    -41001332272872  -R298726502453
user5555
Новичок
*

Репутация: +0/-0
Офлайн Офлайн

Сообщений: 6


Просмотр профиля
« Ответ #4 : 05.04.2022, 11:47:02 »

Большое спасибо, с таймером - то что нужно!
Записан
user5555
Новичок
*

Репутация: +0/-0
Офлайн Офлайн

Сообщений: 6


Просмотр профиля
« Ответ #5 : 05.04.2022, 17:14:15 »

Извиняюсь, еще небольшой нюанс.

Как в этот скрипт вставить проверку на пустоту, типа вот такого:
Код: (vb)

If wks.Range("A" & lr).Value = "" Then
wks.Range("B" & lr).Value = "empty"
End If

Если в "A" пусто, то в "B" будет "empty".
Пустых ячеек в "A" может быть несколько.
Записан
user5555
Новичок
*

Репутация: +0/-0
Офлайн Офлайн

Сообщений: 6


Просмотр профиля
« Ответ #6 : 11.04.2022, 14:18:09 »

del
« Последнее редактирование: 11.04.2022, 14:24:15 от user5555 » Записан
Дмитрий Щербаков(The_Prist)
Администратор
Ветеран
*****

Репутация: +485/-0
Офлайн Офлайн

Сообщений: 5 828



Просмотр профиля WWW
« Ответ #7 : 12.04.2022, 12:20:39 »

Если в "A" пусто, то в "B" будет "empty"
просто уберите кавычки у "empty" и все:
Код: (vb)
wks.Range("B" & lr).Value = empty
Записан

Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
Пункты приёма Спасибов:    -41001332272872  -R298726502453
user5555
Новичок
*

Репутация: +0/-0
Офлайн Офлайн

Сообщений: 6


Просмотр профиля
« Ответ #8 : 22.04.2022, 14:01:54 »

Добрый день!

Кому интересен конечный вариант, вот (со статусбаром внизу листа):

Код: (vb)
    Sub getMetaDataDOI()

        'вывод в статусбар информации о начале процесса
        Application.StatusBar = "Работаю, ждите..."

        Dim ie As New InternetExplorer
        Dim myLink As String
        Dim wks As Worksheet
          
        Const meta_tag As String = "meta"
        Const meta_name As String = "doi"
        Dim Doc As HTMLDocument
        Dim metaElements As Object
        Dim element As Object
        Dim keywd As String
        Dim lr As Long, llastr As Long
            
        Set wks = ActiveSheet
        
        'получаем последнюю заполненную строку в столбце А
        llastr = wks.Cells(wks.Rows.Count, 1).End(xlUp).Row

        'сколько квадратов выводить в статусбаре
        Const lMaxQuad As Long = 30
        
        'цикл от первой строки до последней заполненной
        For lr = 1 To llastr
            myLink = wks.Range("A" & lr).Value
            
            'если ячейка в столбике "A" пустая
            If myLink = "" Then
            wks.Range("B" & lr).Value = "DOI: отсутствует"
            'если не пустая
            Else
            
              'ie.Visible = True
              ie.Visible = False
              ie.navigate myLink
              Do
                  DoEvents
              Loop Until ie.readyState = READYSTATE_COMPLETE
        
              Set Doc = ie.document
              Set metaElements = Doc.all.tags(meta_tag)
              For Each element In metaElements
                  If element.Name = meta_name Then
                      keywd = element.Content
                      Range("B" & lr).Value = "DOI:" & keywd
                      
                        'таймер - задержка 5 секунд
                        Dim iTimer
                         iTimer = Timer
                         Do While Format((Timer - iTimer) / 86400, "Long time") < "0:00:05"
                         DoEvents
                         Loop
                      
                      'значения на web-странице нет
                      Else: Range("B" & lr).Value = "no DOI on page"
                  End If
              Next

        Columns("B").AutoFit
        
        End If

        'процесс выполнения в статусбаре
        Application.StatusBar = "Выполнено: " & Int(100 * lr / llastr) & "%" & String(CLng(lMaxQuad * lr / llastr), ChrW(9632)) & String(lMaxQuad - CLng(lMaxQuad * lr / llastr), ChrW(9633))
        DoEvents 'чтобы форма перерисовывалась
        
        Next

        'очистка статусбара
        Application.StatusBar = False

        'результат
        MsgBox "Значения DOI получены"
        
    End Sub


« Последнее редактирование: 22.04.2022, 14:05:17 от user5555 » Записан
Страниц: [1]   Вверх
Печать
Перейти в:  

Powered by MySQL Powered by PHP Powered by SMF 1.1.21 | SMF © 2006-2011, Simple Machines Valid XHTML 1.0! Valid CSS!
Яндекс.Метрика Рейтинг@Mail.ru