Dim myobj As Object, objIE As Object
Dim fff As String, mycnt
 
Sub エレメント番号()
 
Set myobj = CreateObject("Shell.Application")
mycnt = myobj.Windows.Count
 
fal = "HTMLファイル(*.html),*.html"
fff = Application.GetOpenFilename(fal, , Title:="htmlファイル指定") 'ファイル指定
 
If fff = "False" Then
   MsgBox "ファイルを指定して下さい"
   Exit Sub
End If
 
Worksheets("エレメント番号").Select
    Cells.ClearContents
 
With myobj.Windows
    Shell ("EXPLORER.EXE " & fff)
        Do
            DoEvents
        Loop Until mycnt + 1 <= .Count
    Set objIE = .Item(mycnt)
End With
 
   Do While objIE.ReadyState <> 4 Or objIE.Busy = True
        DoEvents
   Loop
 
   Do While objIE.ReadyState <> 4 Or objIE.Busy = True
        DoEvents
   Loop
 
cnt = 1
For i = 0 To objIE.Document.forms.Length - 1
    For j = 0 To objIE.Document.forms(i).elements.Length - 1
        Cells(cnt, 1) = "forms(" & i & ").elements(" & j & ") ⇒ " & _
            objIE.Document.forms(i).elements(j).outerHTML
            cnt = cnt + 1
        Next
    cnt = cnt + 1
    Next i
objIE.Quit
End Sub

Sub リンク番号()
Dim fal As String, fff As String, objIE As Object
Dim cnt As Integer, i As Integer
 
fal = "HTMLファイル(*.html),*.html"
fff = Application.GetOpenFilename(fal, , Title:="htmlファイル指定") 'ファイル指定
 
If fff = "False" Then
   MsgBox "ファイルを指定して下さい"
   Exit Sub
End If
 
 ・・・・・4-7節「Sub エレメント番号()マクロ」と同じであり省略　・・・・・
 
cnt = 1
    For i = 0 To objIE.Document.Links.Length - 1
        Cells(cnt, 1) = "Links(" & i & ") ⇒ " & _
            objIE.Document.Links(i).outerHTML
        cnt = cnt + 1
    Next i
    objIE.Quit
End Sub

Sub 無人訪問()
Dim cont As Integer, i As Integer
urlcheck = 1
    Call 表示準備
 
行数チェック
   gyousu = UserForm1.web1.Document.Links.Length - 1
 
For cont = 1 To kaisuu
    For i = 0 To gyousu
        With UserForm1
            .txt1 = i + 1
            .txt2 = UserForm1.web1.Document.Links(i).innerHTML
            .txt4 = cont & "/" & kaisuu
        End With
 
        enchk = 0
        UserForm1.web1.Document.Links(i).Click
            Call 読み込み終了確認
            Call 表示時間1
 
        UserForm1.web1.Navigate urle
            Call 読み込み終了確認
            If enchk = 0 Then: Exit Sub
            Call 表示時間2
    Next
Next
With UserForm1
    .txt1 = ""
    .txt2.BackColor = "&H8becff"
    .txt2 = "リンク表の各サイトを" & kaisuu & "回表示終了"
    .txt3 = byou
    .txt4 = kaisuu
End With
 
End Sub

Sub 表示時間1()
UserForm1.txt3 = byou
timck = Timer + byou
tm1 = byou
tm2 = Timer + 1
 
Do
    If Timer > timck Then
        UserForm1.txt3 = 0
        Exit Do
    End If
    If tm2 < Timer Then
        tm1 = tm1 - 1
        UserForm1.txt3 = tm1
        tm2 = Timer + 1
    End If
    DoEvents
Loop
 
End Sub

Sub 連続実行()
Dim gyo As Integer
 
If UserForm1.Visible = False Then
    Call ダイアログ
End If
 
For i = 0 To gyousu
    UserForm1.txt01.Text = i + 1
        DoEvents
    gyo = 200 + (i * 24)
    Ret = SetCursorPos(113, gyo)
            Call タイミング2
        If GetCursor <> 65581 Then
            MsgBox "マウスがハイパーリンク上にありません."
            Exit For
        End If
        Call 左クリック
        DoEvents
        Call タイミング2
    Call 読み込み終了確認
    Call 表示時間1
 
    UserForm1.web1.Navigate urle
    Call 読み込み終了確認
       Call タイミング2
Next
 
UserForm1.Hide
MsgBox "自動実行終了"
 
End Sub

Sub 左クリック()
DoEvents
    mouse_event 2, 0, 0, 0, 0
    mouse_event 4, 0, 0, 0, 0
End Sub

Sub ダイアログ()
    With UserForm1
        .Show 0
        .txt1.SetFocus
    End With
End Sub
----------------------------------------------------------
Sub 検索実行()
urle = "http://www.post.japanpost.jp/zipcode/index.html"
 
ban = UserForm1.txt1.Text & UserForm1.txt2.Text
 
If Len(ban) <> 7 Then
    MsgBox "7桁の郵便番号を入力してく下さい。"
    Exit Sub
End If
 
enchk = 0
UserForm1.web1.Navigate urle
 
Call 読み込み終了確認
UserForm1.web1.Document.all("zip").Value = ban
enchk = 0
Dim objInput As Object
 
    Set objInput = UserForm1.web1.Document.getElementsByTagName("input")
For Each cnt In objInput
    If (LCase(cnt.Type) = "image") And (cnt.alt = "該当地域を検索") Then
        cnt.Click
        Exit For
    End If
Next
 
Call 読み込み終了確認
 
myhtml = UserForm1.web1.Document.Body.innerText
stchc = InStr(1, myhtml, "変更時期", 1)
If stchc = 0 Then
    MsgBox "該当する郵便番号が見つかりませんでした。"
        Exit Sub
End If
enck1 = InStr(stchc, myhtml, "このページの先頭", 1)
mydat1 = Mid(myhtml, stchc + 6, enck1 - stchc)
 
enck2 = InStr(1, mydat1, Chr(13), 1)
mydat2 = Mid(mydat1, 1, 9)
mydat3 = Mid(mydat1, 10, enck2 - 10)
 
UserForm1.txt3.Text = mydat3
 
If kiroku = 1 Then
    Call セルへ記入
End If
kiroku = 0
End Sub
----------------------------------------------------------
Sub セルへ記入()
 
endr = Range("I1000").End(xlUp).Row + 1
Cells(endr, 9).Value = mydat2
    Cells(endr, 9).WrapText = False
 
Cells(endr, 10).Value = mydat3
 
End Sub