Excel VBAでリンク切れをチェックしたい。

Excel VBAでリンク切れをチェックしたい。
図のように、リンク一覧からリンクを調べ、問題なければ「○」を表示し、リンク切れの場合は「×」を表示したいんですが、どんなプログラムを組めばよいですか？
よろしくお願いします。

No.2 ベストアンサー 回答者： WindFaller 回答日時： 2016/04/06 00:54

誰もレスを付けないと思いましたので、こちらでも作りましたのでアップしておきます。

#1の方とは、少し意味が違う部分があるかと思います。

以前、ここの掲示板で出したことがあると思うのですが、もう見つかりません。

一応、今回は、自分用で作ってみました。プロバイダからクレームが付きそうな気がしましたが、実行してしまいました。常識の範囲でお使いください。あまり速くはありませんが、ハングはしませんでした。

リンク先のチェックは、838件を一気にチェックしてしまいましたが、これほどはやらないほうが良いかもしれません。100件やって休むとかしたほうが良いような気がします。

ユーザー定義関数の戻り値は、いくつかあります。ステータス200は、◯ですが、その他は、種類がいろいろありますので、×にせずに数値や文字にしました。基本的に、ステータスコードの200は、全部返しました。

数字については、ステータス・コード表をごらんになってください。
http://www.asahi-net.or.jp/~ax2s-kmtn/ref/status …

例：
404 サイトがなくなっています。
403　アクセス権限がないということですから、ログインしなければ分からないかもしれません。
他にも、いくつか種類が出てきます。
n.a と出るのは、サーバーが受け付けないものだと思います。

アンチウィルスソフトで、禁止区域に入った時は、メッセージが出てきました。しかし、そのままで続いていきます。
このマクロ使用中でも、スクロールは可能です。

場所は標準モジュールです。

''//--
Private Declare Sub Sleep Lib "kernel32.dll" (ByVal dwMilliseconds As Long)
Private objHTTP As Object
Sub Main_URLChecking()
　　Dim c As Range
　　Dim i As Long
　　''Microsoft WinHTTP Service, version 5.1 '参照設定する場合
　　''Set objHTTP=New winHttp.WinHttpRequest '
　　For Each c In Range("B2", Cells(Rows.Count, 2).End(xlUp))
　　　　If LCase(c.Value) Like "http://*" Then
　　　　　　c.Offset(, 1).Value = CheckURL(c.Value)
　　　　　　Sleep 200　　'Wait を掛ける
　　　　　　DoEvents　　　'ESCで離脱できるようにする。
　　　　End If
　　Next
　　 Set objHTTP = Nothing
End Sub
Function CheckURL(ByVal strURL As String) As Variant
　　Dim num As Variant
　　On Error GoTo ErrHandler
　　If objHTTP Is Nothing Then
　　　　 Set objHTTP = CreateObject("WinHttp.WinHttpRequest.5.1")
　　End If
　　objHTTP.Open "GET", strURL, False
　　objHTTP.Send
　　If objHTTP.Status = 200 Then
　　　　CheckURL = "◯"
　　Else
　　　　CheckURL = objHTTP.Status
　　End If
　　Exit Function
ErrHandler:
　　If Err() <> 0 Then
　　　　CheckURL = "n.a"
　　End If
End Function

''//--


なお、今度は、これを、ハイパーリンクのリストに反映しないといけないのかな？

この回答へのお礼

ご回答ありがとうございます。
無事に処理することが出来ました。
マクロ使用中でもスクロール出来るのはすごく良かったです。
大変助かりました。
ありがとうございました。

お礼日時：2016/04/06 15:00

No.1 回答者： momoo 回答日時： 2016/04/06 00:16

できました。

標準モジュールに以下のコードを記載し、
B2セルから下にチェックしたいURLを並べて実行してください。
URLはハイパーリンクでなくても構いません。

Sub test()
Dim req
Dim MyUrl As String
Dim cnt As Long
Dim i As Long
Dim MyRng As Range


Set req = CreateObject("Microsoft.XMLHTTP")
cnt = Cells(2, 2).CurrentRegion.Rows.Count
For i = 1 To cnt
Set MyRng = Range("B2").Cells(i, 1)
MyUrl = MyRng.Value

req.Open "GET", MyUrl, False
req.Send
' Debug.Print req.Status
If Not (req.Status >= 200 And req.Status < 300) Then
MyRng.Cells(1, 2).Value = "×"
Else
MyRng.Cells(1, 2).Value = "◯"
End If
Next i
End Sub


参考にさせていただいたページ
http://www.excel.studio-kazu.jp/kw/2010072916151 …
http://www.excel.studio-kazu.jp/kw/2005092716325 …
http://www.relief.jp/itnote/archives/excel-vba-c …

この回答へのお礼

ご回答ありがとうございます。
無事に処理することが出来ました。
大変助かりました。
ありがとうございました。

お礼日時：2016/04/06 14:58