Excelでリンク切れチェックソフトを作ってみよう

Step 10 ラベルリンク先のアンカーの有無をチェック

ラベルのリンクチェックを行わないようようにしていましたが、Htmlの中身を読みアンカーがあるかどうかチェックすることにしました。アンカーとはHTML内の特定の位置に移動させる場合のマークで「A name=」の形式になっています。しかし、Aとnameの間に空白が1個とは限らないので、空白を削除し「aname」で検索するようにしています。手順としては、ラベル文字をHTML文書内から検索し、見つかればその位置から前の100文字を取り出し、空白を削除しその中に、「aname=」+ラベル名があればOKとしています。ラベル名は見つかるまでループします。


Homeへ > Excelでアプリケーションソフト2 > リンク切れチェックソフト



シート画面

#TOP の アンカーへのリンクもチェックしています。
A要素 アンカーリンクのチェック

シートのVBAコード

下記のVBAコードに変更してください。

'リンク先IEオープン
Private Function ExLinkopen(lrow As Long, lcol As Long) As Boolean
    Dim sttime As Long
    Dim passtime As Long
    Dim s1 As String
    Dim s2 As String
    
    ExLinkopen = False
On Error GoTo ErrExit
    Set tIElink = CreateObject("InternetExplorer.application")
    tIElink.navigate Cells(lrow, lcol)
    '読み込みが終わるまで30秒待つ
    Label2.Visible = True
    sttime = Timer
    Do
        '経過時間を算出
        passtime = Timer - sttime
        Label2.Caption = "リンク先をオープンしています。 (" & passtime & ")"
        DoEvents
        If passtime >= 30 Then
            Exit Do
        End If
        '読込み完了
        If tIElink.ReadyState = 4 Then
            Exit Do
        End If
    Loop
    If tIElink.ReadyState = 4 Then
        If LCase(tIElink.document.URL) = LCase(Cells(lrow, lcol)) Then
            Cells(lrow, lcol + 1) = "○"
            Cells(lrow, lcol + 2) = tIElink.document.Title

            If srcLinkPath = Left(LCase(Cells(lrow, lcol)), Len(srcLinkPath)) Then
                If ExDoneSearchUrl(lrow, lcol, s1, s2) = False Then
                    If ExUrlLabelCheck(Cells(lrow, lcol), s1) = False Then
                        ExGetLinkLink lrow, lcol
                    Else
                        If ExSearchLabel(s1, tIElink.document.body.innerHTML) = False Then
                            Cells(lrow, lcol + 1) = "×"
                        End If
                    End If
                End If
            End If
            ExLinkopen = True
        End If
    End If
    If ExLinkopen = False Then
        Cells(lrow, lcol + 1) = "×"
    End If
ErrResume:
On Error Resume Next
    tIElink.Quit
    Set tIElink = Nothing
    Label2.Visible = False
    Exit Function
ErrExit:
    Resume ErrResume
End Function

下記のVBAコードを追加してください。

'アンカーの有無をチェック
Private Function ExSearchLabel(slbl As String, sbody As String) As Boolean
    Dim ln1 As Long
    Dim ln2 As Long
    Dim pos As Long
    Dim s1 As String
    Dim s2 As String
    Dim s3 As String
    
    ExSearchLabel = False
    pos = 1
    Do
        ln1 = InStr(pos, sbody, slbl)
        If ln1 > 0 Then
            n = ln1 - 100
            If n < 1 Then n = 1
            '前の100文字をチェック
            s1 = LCase(Mid(sbody, n, 100 + Len(slbl)))
            'Debug.Print s1
            '空白を削除する
            s3 = ""
            For i = 1 To Len(s1)
                s2 = Mid(s1, i, 1)
                If s2 <> " " And s2 <> " " Then
                    s3 = s3 & s2
                End If
            Next
            
            ln2 = InStr(1, s3, "aname=" & slbl)
            If ln2 > 0 Then
                ExSearchLabel = True
                Exit Do
            End If
            pos = pos + ln1 + 1
        Else
            Exit Do
        End If
    Loop
End Function
Homeへ > Excelでアプリケーションソフト2 > リンク切れチェックソフト

■■■
このサイトの内容を利用して発生した、いかなる問題にも一切責任は負いませんのでご了承下さい
■■■
当ホームページに掲載されているあらゆる内容の無許可転載・転用を禁止します


Copyright (c) Excel-Excel ! All rights reserved