Excel Forum - Porady, Pomoc,  Excel Help, Excel FAQ Strona Główna
 FAQ  RegulaminRegulamin  Szukaj   Użytkownicy   Grupy   Rejestracja   Profil   Twoje wiadomości   Zaloguj 


Poprzedni temat «» Następny temat
ID tematu: 70069 Skopiuj do schowka Sprawdzanie statusu hiperłącza
Autor Wiadomość
Pogodejmon
Świeżak


Wersja: Win Office 2010
Posty: 3
Wysłany: 06-02-2021, 13:21   Sprawdzanie statusu hiperłącza

Cześć,

Czy istnieje jakaś szybka metoda na sprawdzanie czy strona internetowa, do której tworzę hiperłącze się otwiera czy jest nieaktywna (np. błąd serwera).

Oczywiście wykluczam klikanie w każde hiperłącze osobno, gdyż dotyczy to kilku tysięcy stron.

Pozdrawiam
ID posta: 399841 Skopiuj do schowka
 
 
Marecki 
Excel Expert



Wersja: Win Office 2019
Pomógł: 2521 razy
Posty: 8407
Wysłany: 06-02-2021, 13:58   

Przetestuj taką funkcję:
Kod:
Function URLExists(Rng As Range) As Boolean
Dim Request As Object
Dim URL As String

   On Error GoTo URLExists_Error

    If Rng.HasFormula = True Then
        If Rng.Formula Like "?HYPERLINK*" Then
            URL = Split(Rng.Formula, """")(1)
        End If
    Else
        URL = Rng.Value  ' tu można dodać jeszcze sprawdzenie czy link zaczyna się od WWW czy HTTP, choś to nie wszystkie możliwości
    End If

    If VBA.Len(URL) > 0 Then
        Set Request = CreateObject("WinHttp.WinHttpRequest.5.1")
        With Request
            .Open "head", URL, False
            .Send
            URLExists = .StatusText = "OK"
        End With
        Set Request = Nothing
    End If

   On Error GoTo 0
   Exit Function

URLExists_Error:

   URLExists = False
End Function
_________________
Hardware - ta część komputera, którą można kopnąć kiedy software przestanie funkcjonować.

Szkolenia z Excela , FB
Office 2019 Professional Plus , Windows 10 x64
Pozdrawiam, były mkkk23 teraz Marecki.
ID posta: 399843 Skopiuj do schowka
 
 
Pogodejmon
Świeżak


Wersja: Win Office 2010
Posty: 3
Wysłany: 06-02-2021, 17:21   

Ok. Działa. :)

A czy jest możliwe by wyszukiwać konkretne słowo w zawartości tych stron?
ID posta: 399854 Skopiuj do schowka
 
 
Marecki 
Excel Expert



Wersja: Win Office 2019
Pomógł: 2521 razy
Posty: 8407
Wysłany: 06-02-2021, 18:17   

Pokaż jakiś przykład(jakie strony - jakie słowo).
_________________
Hardware - ta część komputera, którą można kopnąć kiedy software przestanie funkcjonować.

Szkolenia z Excela , FB
Office 2019 Professional Plus , Windows 10 x64
Pozdrawiam, były mkkk23 teraz Marecki.
ID posta: 399859 Skopiuj do schowka
 
 
Pogodejmon
Świeżak


Wersja: Win Office 2010
Posty: 3
Wysłany: 06-02-2021, 19:22   

Marecki napisał/a:
Pokaż jakiś przykład(jakie strony - jakie słowo).

'http://icontent.atptour.com/acceptancelist/ECEAS/ECEAS-Report-PZ-Data.asp?TournamentID=2021-398'

Słowo np. "Main"
ID posta: 399866 Skopiuj do schowka
 
 
Marecki 
Excel Expert



Wersja: Win Office 2019
Pomógł: 2521 razy
Posty: 8407
Wysłany: 10-02-2021, 11:06   

Funkcja którą możesz zastosować w arkuszu
Kod:
Function URLExists(Rng As Range) As Boolean
Dim Request As Object
Dim url As String

   On Error GoTo URLExists_Error

    If Rng.HasFormula = True Then
        If Rng.Formula Like "?HYPERLINK*" Then
            url = Split(Rng.Formula, """")(1)
        End If
    Else
        url = Rng.Value  ' tu można dodać jeszcze sprawdzenie czy link zaczyna się od WWW czy HTTP, choś to nie wszystkie możliwości
    End If

    If VBA.Len(url) > 0 Then
        Set Request = CreateObject("WinHttp.WinHttpRequest.5.1")
        With Request
            .Open "Get", url, False
            .Send
            If .StatusText = "OK" Then
            If .responsetext Like "*Main*" Then URLExists = True
            End If
        End With
        Set Request = Nothing
    End If

   On Error GoTo 0
   Exit Function

URLExists_Error:

   URLExists = False
End Function


Lub jeśli chcesz to możesz użyć takiego kodu, który wylistuje Ci linki zawierające słowo "*Main*"
Poniższy kod tyczy się wyłącznie podanej przez Ciebie strony.
Nie można zrobić działającej wyszukiwarki opierając się tylko na tym jednym adresie, nie mówiąc już że stron zawierających dane słowo może być krocie.
Kod:
Sub test()
Dim i As Long, x As Long
Dim url As String
   
    For i = 300 To 1000
    DoEvents
    Application.StatusBar = i
        url = "http://icontent.atptour.com/acceptancelist/ECEAS/ECEAS-Report-PZ-Data.asp?TournamentID=2021-" & i
        If URLExists_str(url) Then
            x = x + 1
            Cells(x, 1).Value = url
        End If
    Next i
    Application.StatusBar = ""
End Sub


Function URLExists_str(url As String) As Boolean
Dim Request As Object

    On Error GoTo URLExists_Error

    Set Request = CreateObject("WinHttp.WinHttpRequest.5.1")
    With Request
        .Open "Get", url, False
        .Send
        If .StatusText = "OK" Then
            If .responsetext Like "*Main*" Then URLExists_str = True
        End If
    End With
    Set Request = Nothing


    On Error GoTo 0
    Exit Function
URLExists_Error:


End Function
_________________
Hardware - ta część komputera, którą można kopnąć kiedy software przestanie funkcjonować.

Szkolenia z Excela , FB
Office 2019 Professional Plus , Windows 10 x64
Pozdrawiam, były mkkk23 teraz Marecki.
ID posta: 400088 Skopiuj do schowka
 
 
Wyświetl posty z ostatnich:   
Odpowiedz do tematu
Nie możesz pisać nowych tematów
Nie możesz odpowiadać w tematach
Nie możesz zmieniać swoich postów
Nie możesz usuwać swoich postów
Nie możesz głosować w ankietach
Nie możesz załączać plików na tym forum
Możesz ściągać załączniki na tym forum
Dodaj temat do Ulubionych
Wersja do druku

Skocz do:  

Powered by phpBB modified by Przemo © 2003 phpBB Group
Theme xandgreen created by spleen& Programosy modified v0.3 by warna
Opieka techniczna www.marketingNET.pl

Archiwum

Strona używa plików cookies.

Kliknij tutaj, żeby dowiedzieć się jaki jest cel używania cookies oraz jak zmienić ustawienia cookie w przeglądarce.
Korzystając ze strony użytkownik wyraża zgodę na używanie plików cookies, zgodnie z bieżącymi ustawieniami przeglądarki.
Sprawdź, w jaki sposób przetwarzamy dane osobowe