|
#TOP の アンカーへのリンクもチェックしています。
|
|
|
| シートコード |
|
下記のコードに変更してください。
'リンク先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
下記のコードを追加してください。
'アンカーの有無をチェック
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
|
|
|
|
|
|
|
|