|
リンク先に問題がなければ、「○」が記入されています。
|
|
|
| シートコード |
|
下記のコードを入力してください。
'リンクを取り出しセルに記入する
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
|
|
|
|
|
|
|
|