【マクロ】リンク切れのURLを自動で発見したい

質問

大量のURLをまとめたExcelのsheetがあり、メンテナンスとして月に1回、リンクが切れていないか調べるツールがほしいのですが、エクセルマクロで出来ますでしょうか？

イメージとしては、添付している写真のようなものです。

表のURLにアクセスして、リンクが切れていれば「リンク切れ」、アクセスできれば「有効」と結果の列に記載し、次のURLに移る。

前回調べた時の結果と今回の結果が違うURLがわかるようにしたいので、添付画像では、毎回結果を残していくようにしましたが、前回との差がわかれば違う形でも構いません。

手動でやっていくには、大変すぎて困っています。助けて頂けると助かります。

回答No.5

HohoPapa · ベストアンサー

>リダイレクトして別のページ（トップページ等）に飛ばすサイト
前回、コーディングしているときに気になりましたが
>>（この仕組みで十分かどうか少々疑わしいです）
として見送りました。

そこで、画像のように区別し、
リダイレクト先を取得してみました。

Option Explicit

Sub Sample()
　Const PutCol1 = 2　 '有効／リンク切れ出力列番号
　Const PutCol2 = 3　 '症状コード出力列番号

　Dim RowNum As Long
　Dim RCode As String

　With ThisWorkbook.Sheets(1)
　　RowNum = 2
　　Do
　　　If .Cells(RowNum, 1).Value = "" Then Exit Sub
　　　RCode = isURL_Live(.Cells(RowNum, 1).Value)
　　　If RCode = "0" Then
　　　　.Cells(RowNum, PutCol1).Value = "有効"
　　　ElseIf IsNumeric(RCode) = False Then
　　　　.Cells(RowNum, PutCol1).Value = "リダイレクト"
　　　　.Cells(RowNum, PutCol2).Value = RCode
　　　Else
　　　　.Cells(RowNum, PutCol1).Value = "リンク切れ"
　　　　.Cells(RowNum, PutCol2).Value = Val(RCode)
　　　End If
　　　RowNum = RowNum + 1
　　Loop
　End With
End Sub

'urlをチェック
Function isURL_Live(MyUrl As String) As String

　'以下を参照設定
　'・Microsoft HTML Object Library
　'・Microsoft Internet Controls
　'参考：https://www.vba-ie.net/library/

　Const WTime = 5　 'IE描写完了までの待ち時間(秒)
　Dim objIE As InternetExplorer
　Dim RowNum As Long

　isURL_Live = "0"

　Set objIE = CreateObject("InternetExplorer.Application")
　objIE.Visible = True
　objIE.navigate MyUrl
　Call IEWait(objIE)　 'IEを待機
　Call WaitFor(WTime)　'描写完了待ち

　If objIE.document.Url <> MyUrl Then
　　isURL_Live = objIE.document.Url
　End If

　RowNum = 2
　With ThisWorkbook.Sheets("IE_NG_Text")
　　Do
　　　If .Cells(RowNum, 1).Value = "" Then Exit Do
　　　If InStr(objIE.document.body.innerText, .Cells(RowNum, 1).Value) > 0 Then
　　　　isURL_Live = Format(RowNum - 1, "0")
　　　　Exit Do
　　　End If
　　　RowNum = RowNum + 1
　　Loop
　End With

　objIE.Quit
　Set objIE = Nothing

End Function

'IE、urlへのアクセス完了を待機---
Function IEWait(ByRef objIE As Object)
　Do While objIE.Busy = True Or objIE.readyState <> 4
　　　DoEvents
　Loop
End Function

'--指定した秒だけ停止---
Function WaitFor(ByVal second As Integer)
　Dim futureTime As Date
　futureTime = DateAdd("s", second, Now)
　While Now < futureTime
　　DoEvents
　Wend
End Function

お礼

リダイレクトしたURLの取得できました！ありがとうございます。ただただ、感嘆しております。本当にありがとうございます。

回答No.4

HohoPapa

>リンクが切れていれば「リンク切れ」、
>アクセスできれば「有効」と結果の列に記載し
と、
>前回調べた時の結果と今回の結果が違うURLがわかるようにしたい
を見落としていました。

また、どのような症状だったかがわかるほうがいいと思い
直してみました。

Option Explicit

Sub Sample()
　Const PutCol1 = 2　 '有効／リンク切れ出力列番号
　Const PutCol2 = 3　 '症状コード出力列番号

　Dim RowNum As Long
　Dim RCode As Long

　With ThisWorkbook.Sheets(1)
　　RowNum = 2
　　Do
　　　If .Cells(RowNum, 1).Value = "" Then Exit Sub
　　　RCode = isURL_Live(.Cells(RowNum, 1).Value)
　　　If RCode = 0 Then
　　　　.Cells(RowNum, PutCol1).Value = "有効"
　　　Else
　　　　.Cells(RowNum, PutCol1).Value = "リンク切れ"
　　　　.Cells(RowNum, PutCol2).Value = RCode
　　　End If
　　　RowNum = RowNum + 1
　　Loop
　End With
End Sub

'urlをチェック
Function isURL_Live(MyUrl As String) As Long

　'以下を参照設定
　'・Microsoft HTML Object Library
　'・Microsoft Internet Controls
　'参考：https://www.vba-ie.net/library/

　Const WTime = 5　 'IE描写完了までの待ち時間(秒)
　Dim objIE As InternetExplorer
　Dim RowNum As Long

　isURL_Live = 0

　Set objIE = CreateObject("InternetExplorer.Application")
　objIE.Visible = True
　objIE.navigate MyUrl
　Call IEWait(objIE)　 'IEを待機
　Call WaitFor(WTime)　'描写完了待ち

　RowNum = 2
　With ThisWorkbook.Sheets("IE_NG_Text")
　　Do
　　　If .Cells(RowNum, 1).Value = "" Then Exit Do
　　　If InStr(objIE.document.body.innerText, .Cells(RowNum, 1).Value) > 0 Then
　　　　isURL_Live = RowNum - 1
　　　　Exit Do
　　　End If
　　　RowNum = RowNum + 1
　　Loop
　End With

　objIE.Quit
　Set objIE = Nothing

End Function

'IE、urlへのアクセス完了を待機---
Function IEWait(ByRef objIE As Object)
　Do While objIE.Busy = True Or objIE.readyState <> 4
　　　DoEvents
　Loop
End Function

'--指定した秒だけ停止---
Function WaitFor(ByVal second As Integer)
　Dim futureTime As Date
　futureTime = DateAdd("s", second, Now)
　While Now < futureTime
　　DoEvents
　Wend
End Function

お礼

できました！作って頂きありがとうございます。助かりました。

補足

ほぼ目的のことができそうなのですが、少し困ったこともわかりました。
存在しないURLにアクセスした場合、リダイレクトして別のページ（トップページ等）に飛ばすサイトがいくつかあります。これも判定状はOKとなります。
素人目にも、リダイレクトを検出してNG判定にするのは難しいのでは、、と思うのですが、HohoPapa 様の見解も同じでしょうか？

回答No.3

HohoPapa

興味本位で作成してみました。

他の方のコメントのとおり、
urlが生きているかどうかの判定は
相手次第で様々な動作が起こり得ることから
一筋縄ではいかないだろうと思います。

そこで、
指定したurlを開き
切れていると判断できそうな文字列を探す仕組みにしてみました。
（この仕組みで十分かどうか少々疑わしいです）

もしよかったら試してみてください。
なお、テスト運用をしながら、
Sheets("IE_NG_Text")を育てる必要があるだろうと思います。
また、参照設定が必要です。
ソースコードのコメントを参照してください。

Option Explicit

Sub Sample()
　Dim RowNum As Long
　With ThisWorkbook.Sheets(1)
　　RowNum = 2
　　Do
　　　If .Cells(RowNum, 1).Value = "" Then Exit Sub
　　　.Cells(RowNum, 2).Value = isURL_Live(.Cells(RowNum, 1).Value)
　　　RowNum = RowNum + 1
　　Loop
　End With
End Sub

'urlをチェック
Function isURL_Live(MyUrl As String)

　'以下を参照設定
　'・Microsoft HTML Object Library
　'・Microsoft Internet Controls
　'参考：https://www.vba-ie.net/library/

　Const WTime = 5　 'IE描写完了までの待ち時間(秒)
　Dim objIE As InternetExplorer
　Dim RowNum As Long

　isURL_Live = "OK"

　Set objIE = CreateObject("InternetExplorer.Application")
　objIE.Visible = True
　objIE.navigate MyUrl
　Call IEWait(objIE)　 'IEを待機
　Call WaitFor(WTime)　'描写完了待ち

　RowNum = 2
　With ThisWorkbook.Sheets("IE_NG_Text")
　　Do
　　　If .Cells(RowNum, 1).Value = "" Then Exit Do
　　　If InStr(objIE.document.body.innerText, .Cells(RowNum, 1).Value) > 0 Then
　　　　isURL_Live = "NG"
　　　　Exit Do
　　　End If
　　　RowNum = RowNum + 1
　　Loop
　End With

　objIE.Quit
　Set objIE = Nothing

End Function

'IE、urlへのアクセス完了を待機---
Function IEWait(ByRef objIE As Object)
　Do While objIE.Busy = True Or objIE.readyState <> 4
　　　DoEvents
　Loop
End Function

'--指定した秒だけ停止---
Function WaitFor(ByVal second As Integer)
　Dim futureTime As Date
　futureTime = DateAdd("s", second, Now)
　While Now < futureTime
　　DoEvents
　Wend
End Function

お礼

ありがとうございます。

回答No.2

ballville

>マクロを書いてもらえると助かります
そういうことなら、「VBA　マクロ　開発依頼」あたりで検索すると、依頼サイトがたくさん見つかります。中には安価なところもあるみたいですよ。

VBAやマクロを勉強したいというなら、当サイトでも助言を得られると思いますが、「書いてほしい」では完全に開発依頼ですよね。

参考URL：

https://www.google.com/search?q=VBA　マクロ　開発依頼

お礼

マクロの開発依頼ができることを初めてしりました。今後の参考にさせていただきます。

回答No.1

hiodraiu

できるかどうかって質問なら、できます。
ただ、リンク切れって言葉ですが、一般的には、サーバーが404のステータスを返してきた場合、サービス自体がなくなっていたり、ホスト自体がなくなっていたりした場合がリンク切れだと思います。それ以外のステータスをサーバーが返した場合や、通信でタイムアウトになった場合もリンク切れって表現ですか。タイムアウトはサービスやホストが無くなった場合だけでなく、トラフィックやサービス、ホストの負荷が高い場合にも発生します。

お礼

回答ありがとうございます

補足

すいません。マクロの記録程度しか使えない初心者なので、マクロを書いてもらえると助かります。
また、通信についてよくわかっていないため、見当違いかもしれませんが、タイムアウトまで待っていると全体が終わるまで時間がかかりすぎるので、すぐにアクセスできなければ、リンク切れ扱いでもいいと思っています。