Невозможно превратить некоторые неработающие ссылки в квалифицированные

Я пытаюсь создать скрипт в vba, который будет искать любую ссылку contact или contact us на любом заданном веб-сайте, чтобы получить квалифицированную/полезную ссылку. Мой текущий скрипт анализирует контактную ссылку, но в большинстве случаев они не подходят для повторного использования позже, что означает неработающие.

Я пробовал до сих пор:

Sub FetchCustomizedLink()
    Dim Http As New XMLHTTP60, Html As New HTMLDocument
    Dim link As Variant, links As Variant, targetlink$

    links = Array( _
        "http://www.innovaprint.com.sg/", _
        "https://www.plexure.com.sg/", _
        "http://www.mount-zion.biz/", _
        "https://stackoverflow.com/" _
    )

    For Each link In links
        targetlink = None

        With Http
            .Open "GET", link, False
            .setRequestHeader "User-Agent", "Mozilla/5.0"
            On Error Resume Next
            .send
            On Error GoTo 0
            Html.body.innerHTML = .responseText
        End With

        With Html.querySelectorAll("a[href]")
            For I = 0 To .Length - 1
                If InStr(1, .item(I).innerText, "contact", 1) > 0 Then
                    targetlink = .item(I).getAttribute("href")
                    Exit For
                End If
            Next I
        End With
        Debug.Print targetlink
    Next link
End Sub

Вывод, который я получаю:

about:/contact.html
https://www.plexure.com.sg/contact
about:contactus.html
https://stackoverflow.com/company/contact

Вывод, который я хочу получить:

http://www.innovaprint.com.sg/contact.html
https://www.plexure.com.sg/contact
http://www.mount-zion.biz/contactus.html
https://stackoverflow.com/company/contact

Как превратить неработающие ссылки в качественные?


html web-scraping vba queryselector
person MITHU    schedule 13.04.2020    source источник
comment
Сделать предположение и взять базовый домен из исходного URL-адреса запроса? то есть все до третьего / ? Кроме того, вам понадобится случай Select, который вы расширяете, чтобы обрабатывать текст в фактическом href, который вы извлекаете, который необходимо заменить, например. о:   -  person QHarr    schedule 13.04.2020
comment
Приятно видеть вас в курсе @QHarr. Да, select case может быть идеальным вариантом. Я пробовал с оператором Like, но мне кажется, что обрабатывать несколько типов шаблонов намного сложнее. То, что вы подумали, кстати, правильно.   -  person MITHU    schedule 13.04.2020
comment
Здравствуйте, не могли бы вы заменить about:/ или about: на элемент с массивом ссылок?   -  person Ryan Wildry    schedule 13.04.2020
comment
Я не возражаю против прохождения любого маршрута, если результат аналогичен ожидаемому.   -  person MITHU    schedule 13.04.2020

Ответы (1)


arrow_upward
1
arrow_downward

Наконец я это сделал. Мне пришлось использовать функцию InStr() внутри функции Left(), чтобы выделить базовый URL-адрес, а затем использовать функцию Replace() вместе с оператором Like для создания квалифицированных ссылок contact.

Sub FetchCustomizedLink()
    Dim Http As New XMLHTTP60, Html As New HTMLDocument
    Dim link As Variant, links As Variant, targetlink$
    Dim base$, refinedportion$, refinedlink$

    links = Array( _
        "http://www.innovaprint.com.sg/", _
        "https://www.plexure.com.sg/", _
        "http://www.mount-zion.biz/", _
        "https://stackoverflow.com/", _
        "https://www.yellowpages.com/" _
    )

    For Each link In links
        targetlink = None

        With Http
            .Open "GET", link, False
            .setRequestHeader "User-Agent", "Mozilla/5.0"
            On Error Resume Next
            .send
            On Error GoTo 0
            Html.body.innerHTML = .responseText
        End With

        With Html.querySelectorAll("a[href]")
            For I = 0 To .Length - 1
                If InStr(1, .item(I).innerText, "contact", 1) > 0 Then
                    targetlink = .item(I).getAttribute("href")
                    Exit For
                End If
            Next I
        End With

        If InStr(link, "http:") > 0 Then
            base = Left(link, InStr(8, link, "/") - 1)
        ElseIf InStr(link, "https:") > 0 Then
            base = Left(link, InStr(9, link, "/") - 1)
        End If

        refinedportion = Replace(targetlink, "about:", "")

        If refinedportion Like "[/]*" Then
            refinedlink = base & refinedportion
        ElseIf refinedportion Like "[h]*" Then
            refinedlink = refinedportion
        Else
            refinedlink = base & "/" & refinedportion
        End If
        Debug.Print refinedlink
    Next link
End Sub

Что он производит:

http://www.innovaprint.com.sg/contact.html
https://www.plexure.com.sg/contact
http://www.mount-zion.biz/contactus.html
https://stackoverflow.com/company/contact
https://www.yellowpages.com/about/contact-us
person MITHU    schedule 13.04.2020