リンク切れチェックを行うマクロ

URLを貼ったExcelファイルがあるのですが
そのリンクが有効かチェックするマクロを組みたいです。
Excel、Libre office、Open Officeどれかで実行できればいいです。

URLは、開くとPDFファイルがダウンロードできるものがほとんどです。HTMLもあったかも？とにかくすべてのタイプのURLをチェックしたいです。

以下のマクロを作ってみました。
チェックしたいファイルのパスを入力すると、URLをすべてチェックして表に◯か×を書く仕様です。


Rem Attribute VBA_ModuleType=VBAModule
Option VBASupport 1

Sub LinkChecker()

Dim ToolBook As Object
ToolBook = ThisWorkbook.sheets(1)

'■対象ファイルのURL記載位置を取得
Dim URLRange As String
URLRange = ToolBook.Range("G4")

'■ファイルパス開始位置を指定
Dim r As Long
Dim l As Long
Dim objURL As String

r = 13
l = 2

ActiveWindow.WindowState = xlMinimized 'ツールを最小化

Do While ToolBook.Cells(r, l) <> "" 'ファイルパス（B列）が空欄になるまで処理をループ

Dim objFile As String
objFile = ToolBook.Cells(r, l)

Workbooks.Open objFile

Dim wb As Workbook 'ブック格納
Dim sh As Worksheet
Dim countSh As Long
countSh = ActiveWorkbook.Sheets.Count 'シートの総数を取得

Dim bookName As String
bookName = ActiveWorkbook.Name '開いたファイル名を取得

ActiveWindow.WindowState = xlMinimized '対象ファイルも邪魔なので最小化

Dim a As Long
a = 1

Do While a > countSh

Dim objSh As Object
objSh = ActiveWorkbook.Sheets(a)

objURL = objSh.Range(URLRange)

Dim isURL As Long
isURL = InStr(1, objURL, "http")

If isURL > 0 Then

ThisWorkbook.Activate
l = l + 1
ToolBook.Cells(r, l) = objURL

If GetWebStatus(objURL) = "200" Then

'■リンク切れ確認処理

'---IE起動
Dim objIE As InternetExplorer 'IEを用意
Set objIE = CreateObject("Internetexplorer.Application")
objIE.Visible = True

objIE.navigate objURL
Call IEWait(objIE)

Dim htmlDoc As HTMLDocument
Set htmlDoc = objIE.document.all(0).outerHTML 'htmlをすべて取得

Dim cannotFind As Long
Dim cannnotDes As Long
Dim cannotView As Long

cannotFind = InStr(1, htmlDoc, "見つかりませ")
cannnotDes = InStr(1, htmlDoc, "表示できませ")
cannotView = InStr(1, htmlDoc, "見られませ")

If cannotFind + cannnotDes + cannotView >0 Then

ThisWorkbook.Activate
ToolBook.Cells(r+1, l) = "×"
Call Act(wb, bookName)

Else

ThisWorkbook.Activate
ToolBook.Cells(r+1, l) = "〇"
Call Act(wb, bookName)

End If

objIE.Quit

Else

ThisWorkbook.Activate
ToolBook.Cells(r+1, l) = "×"
Call Act(wb, bookName)

End If

End If

a = a + 1
Call Act(wb, bookName)

Loop

call Act(wb, bookName)
ActiveWorkbook.Close

l = 2
r = r + 2
ThisWorkbook.Activate

Loop

MsgBox ("チェックが完了しました")


End Sub

'---------------------------------------------------------------------------------------------------
Function IEWait(objIE As InternetExplorer)

Do While objIE.Busy = True

DoEvents

Loop

End Function

'---------------------------------------------------------------------------------------------------
Function Act(wb As Workbook, bName As String)

For Each wb In Workbooks

If wb.Name = bName Then

wb.Activate

End If

Next

End Function

'---------------------------------------------------------------------------------------------------

Function GetWebStatus(URL As String) As String


Dim WinHttp As Object

'"WinHttp.WinHttpRequest.5.1"ではうまくいかなかったため

'"MSXML2.XMLHTTP"を利用

'Set WinHttp = CreateObject("WinHttp.WinHttpRequest.5.1")

Set WinHttp = CreateObject("MSXML2.XMLHTTP")

On Error GoTo INVALID

WinHttp.Open "GET", URL, False

WinHttp.send 'GETリクエストを送信

GetWebStatus = WinHttp.Status 'ステータスコードをセット

Set WinHttp = Nothing

Exit Function

INVALID:

GetWebStatus = "Invalid URL"

Set WinHttp = Nothing

End Function



'--------------------------------------------<End of Code>-------------------------------------



しかしLibreで実行すると以下のエラーでURLを開けません。



BASIC ランタイムエラー.
'1'
Type: com.sun.star.lang.IllegalArgumentException
Message: Unsupported URL <>: "from LoadEnv::initializeLoading"


PDFのURLだから？エラーをググってみてもよくわかりません…。
どこが間違っているか教えていただきたいです。

No.1 回答者： WindFaller 回答日時： 2017/03/30 01:26

以下は、昔作ったものを、多少、手を手を入れてみました。

Windows、Excel用のマクロコードです。

WinHTTP Servoces. version 5.1
は、ふつう、C:\WINDOWS\system32\winhttpcom.dll
として入ってますが、同様に使えるなら他のものでも可能です。

　A列に入れてお試しください。
　
以下は、ゲイト式やダミーページを間に入れているサイトでは、この方法では取れません。

'//
Sub TestURlChecker()
For Each c In Range("A1", Cells(Rows.Count, "A").End(xlUp))
If c.Value <> "" Then
　 If c.Offset(, 1).Value = "" Then
　 buf = URLExists(c.Value)
　 c.Offset(, 1).Value = buf
　 DoEvents
　 End If
End If
Next c
End Sub

Function URLExists(URL As String)
　　Dim Request As Object
　　Dim ff As Long
　　Dim ii As Long
　　Dim rc As Variant
　　On Error GoTo EndNow
　　Set Request = CreateObject("WinHttp.WinHttpRequest.5.1")

　　With Request
　　　.Open "GET", URL, False
　　　.send
　　　ii = InStr(1, Request.responseText, "charset=""", vbTextCompare)
　　　rc = .StatusText
　　End With
　　Set Request = Nothing
　　If ii = 0 And rc = "OK" Then
　　　 URLExists = True
　　ElseIf ii > 0 And rc = "OK" Then
　　　 URLExists = "??"
　　Else
　　　 URLExists = False
　　End If
　　Exit Function
EndNow:
End Function