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

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

1 голос
/ 13 апреля 2020

Я пытаюсь создать скрипт в 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

Вывод I получаю: 

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

Вывод I w sh для получения: 

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

Как я могу превратить неработающие ссылки в квалифицированные?

1 Ответ

1 голос
/ 13 апреля 2020

Наконец-то я это сделал. Мне пришлось использовать функцию 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
...