Excel Forum - Porady, Pomoc, Excel Help, Excel FAQ - Sprawdzanie statusu hiperłącza

Pogodejmon · Świeżak Wersja: Win Office 2010 Posty: 3

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

Marecki · 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

Pogodejmon · Świeżak Wersja: Win Office 2010 Posty: 3

Ok. Działa. :)

A czy jest możliwe by wyszukiwać konkretne słowo w zawartości tych stron?

Marecki · Wysłany: 06-02-2021, 18:17

Pokaż jakiś przykład(jakie strony - jakie słowo).

Pogodejmon · Świeżak Wersja: Win Office 2010 Posty: 3

Marecki · 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