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

Step 5 リンク先のリンク一覧を取得する

リンク一覧から、1行名のリンクを調べ問題なければ「○」を表示し、つながらない場合は「×」を表示します。OKの場合、さらにそこからのリンク一覧を取得し、セルに記入していきます。記入の方法は、始めにリンク数を取得し、その数だけ行を挿入します。次に、行挿入された空白行にリンク先一覧を記入していきます。以降ここまでの流れを繰り返し、総当りでリンク切れを調べていきます。

Homeへ > アプリケーションソフト > リンク切れチェックソフト > Step5 リンク先のリンク一覧を取得する

スポンサードリンク



シート画面

リンク先に問題がなければ、「○」が記入されています。
リンク先のリンク一覧を表示

スポンサードリンク



シートコード

下記のコードを入力してください。

'リンクを取り出しセルに記入する
Private Function ExGetLinkLink(lrow As Long, lcol As Long) As Long
    Dim i As Integer
    Dim s1 As String
    Dim coun As Long
    
    coun = 0
    For i = 0 To tIEobj.document.Links.Length - 1
        If Left(tIEobj.document.Links(i).href, 4) = "http" Then
            coun = coun + 1
        End If
    Next
    
    'リンク数分を行の挿入
    Range(Cells(lrow + 1, lcol), Cells(lrow + coun, lcol)).Select
    Selection.EntireRow.Insert
    
    For i = 0 To tIEobj.document.Links.Length - 1
        If Left(tIEobj.document.Links(i).href, 4) = "http" Then
            'セルに記入
            Cells(lrow + i + 1, lcol) = tIEobj.document.Links(i).href
        End If
    Next
    
    ExGetLinkLink = coun
End Function


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

'リンク先IEオープン
Private Function ExLinkopen(lrow As Long, lcol As Long) As Boolean
    Dim sttime As Long
    Dim passtime As Long
    Dim tIElink As Object
    
    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) = "○"
            ExGetLinkLink lrow, lcol
            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

スポンサードリンク





Homeへ > アプリケーションソフト > リンク切れチェックソフト > Step5 リンク先のリンク一覧を取得する

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


関連コンテンツ

Copyright (c) Excel-Excel ! All rights reserved