Sub MyIeXlChibaNp()
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Rem 千葉日報サイト[ニュース]ページ読み込み処理
  Rem 作譜：Hitrock Camellia Shinopy
  Rem 言語：Excel VBA
  Rem 機能...
  Rem   千葉日報サイトの[ニュース]ページを読み込みし、
  Rem   Excelシートに書き込みする。
  Rem 注記...
  Rem   MyIeXlChibaNpを起動して使用｡
  Rem   サイトのページ内容を取り損ねることがあるため、
  Rem   ページを読み込む時に、DoEvents関数で処理を一時停止させる。
  Rem   （これまでの試行により、前のページに戻る時は、不要と思われる。）
  Rem 履歴...
  Rem   第1版：2006/08/04：作成。
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Rem 参照設定する場合...
  Rem   Microsoft Internet Controls
  Rem   Microsoft HTML Object Library
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Dim myIE As Variant ' InternetExplorer
  Dim myDoc As Variant ' MSHTML.HTMLDocument
  Dim myLink As Variant ' MSHTML.HTMLAnchorElement
  '
  Dim myURL As String
  Dim myHref As String
  Dim myLead As String
  '
  Dim myStatusBar As String
  Dim i As Long
  Dim r As Long
  Dim myCount As Long
  Dim myinnerText As String
  Dim myDate As String
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  Rem 千葉日報サイトの[ニュース]ページ
  myURL = "http://www.chibanippo.co.jp/news/index.php"
  '
  Application.CommandBars("Task Pane").Visible = False
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  Set myIE = CreateObject("InternetExplorer.Application")
  '
  With myIE
    .Navigate myURL
    .Visible = False ' True
    Do While .Busy
      DoEvents
    Loop
    Do Until .ReadyState = 4 ' READYSTATE_COMPLETE
    Loop
    myStatusBar = "□千葉日報 ニュース 読み込み開始"
    Application.StatusBar = "MyIeXlChibaNp: " & myStatusBar
    DoEvents
    '
    Set myDoc = .Document
  End With
  '
  myLead = myDoc.Title
  Sheets(1).Activate
  Range("A1").Select
  Range("A1").Value = myDoc.Title
  myDate = myDoc.ActiveElement.innerText
  myDate = Left(myDate, InStr(myDate, " ") - 1)
  myDate = Replace(myDate, vbCrLf, " ")
  Range("B1").Value = myDate
  ActiveSheet.Name = "ニューストップ"
  myLead = myDoc.Title
  myHref = "http://www.chibanippo.co.jp/news/index.php"
  r = 1
  i = 0
  Columns("A:A").ColumnWidth = 30#
  Columns("B:B").ColumnWidth = 80#
  Rows("1").RowHeight = 50#
  '
  Application.ScreenUpdating = False
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  For Each myLink In myDoc.links
    If Len(myLink.innerText) = 0 Then
      If i > 0 Then
        Exit For
      End If
    Else
      Select Case True
        Case myLink.innerText = "すべての記事を読む" ' 記事見出し先行するリンク
          myLead = myLead & "," & myLink.innerText
          myHref = myHref & "," & myLink.href
          i = i + 1
        Case myLink.innerText Like "-*" ' -付き文字列：記事見出しリンク
          myLead = myLead & "," & myLink.innerText
          myHref = myHref & "," & myLink.href
        Case Else ' ニューストップ：分野別見出し
          If i = 0 Then
            r = r + 1
            Cells(r, "A").Select
            Cells(r, "A").Hyperlinks.Add Anchor:=Selection, Address:=myLink.href, TextToDisplay:=myLink.innerText
          End If
      End Select
    End If
    DoEvents
  Next ' myLink
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  If Worksheets.Count < (i + 1) Then
    myCount = (i + 1) - Worksheets.Count
    For i = 1 To myCount
      Worksheets.Add After:=Sheets(Worksheets.Count), Count:=1
    Next ' i
  End If
  Sheets(1).Activate
  Range("A1").Select
  '
  Call MyIeXlChibaNpPage(myLead, myHref, myIE)
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  myIE.Visible = True
  myIE.Quit
  Application.ScreenUpdating = True
  Sheets(1).Activate
  '
  myStatusBar = "処理が終了しました。"
  Application.StatusBar = "MyIeXlChibaNp: " & myStatusBar
  Application.Speech.Speak myStatusBar, False
  Rem MsgBox myStatusBar, vbOKOnly + vbInformation, "MyIeXlChibaNp" & "：終了"
  Application.StatusBar = ""
  '
  Set myIE = Nothing
  Set myDoc = Nothing
End Sub ' MyIeXlChibaNp *----*----*    *----*----*    *----*----*    *----*----*

Sub MyIeXlChibaNpPage(myLead As String, myHref As String, myIE As Variant)
  Dim myDoc As Variant ' MSHTML.HTMLDocument
  Dim myLink As Variant ' MSHTML.HTMLAnchorElement
  '
  Dim i As Long
  Dim r As Long
  Dim myArrayLead As Variant
  Dim myArrayHref As Variant
  Dim myStatusBar As String
  '
  Dim myinnerText As String
  Dim myDate As String
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  myArrayLead = Split(myLead, ",")
  myArrayHref = Split(myHref, ",")
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  For i = 1 To UBound(myArrayLead)
    Select Case True
      Case myArrayLead(i) = "すべての記事を読む" ' 記事見出し先行するリンク
        Range("A1").Select
        ActiveSheet.Next.Activate
        r = 0
        Columns("A:A").ColumnWidth = 30#
        Columns("A:A").WrapText = True
        Columns("B:B").ColumnWidth = 80#
        '
        With myIE
          .Navigate myArrayHref(i) & "index.php"
          .Visible = False ' True
          Do While .Busy
            DoEvents
          Loop
          Do Until .ReadyState = 4 ' READYSTATE_COMPLETE
          Loop
          myStatusBar = "●読み込み中：" & " " & i & "/" & UBound(myArrayLead)
          Application.StatusBar = "MyIeXlChibaNpPage: " & myStatusBar
          '
          Set myDoc = .Document
        End With
        ActiveSheet.Name = Replace(myDoc.Title, "千葉日報｜ニュース｜", "")
        ActiveSheet.Name = Replace(ActiveSheet.Name, "ニュース", "")
      Case myArrayLead(i) Like "-*" ' -付き文字列：記事見出しリンク
        With myIE
          .Navigate myArrayHref(i)
          .Visible = False ' True
          Do While .Busy
            DoEvents
          Loop
          Do Until .ReadyState = 4 ' READYSTATE_COMPLETE
          Loop
          myStatusBar = "●読み込み中：" & ActiveSheet.Name & " " & i & "/" & UBound(myArrayLead)
          Application.StatusBar = "MyIeXlChibaNpPage: " & myStatusBar
          '
          Set myDoc = .Document
        End With
        r = r + 1
        Cells(r, "A").Select
        Cells(r, "A").Value = Replace(myArrayLead(i), "-", "　", 1, 1)
        '
        myinnerText = myDoc.ActiveElement.innerText
        Select Case True
          Case InStr(myinnerText, "ページを表示できません") > 0
            Rem サイトが読み込み不可の場合
            Cells(r, "B").Value = vbLf & myinnerText
          Case InStr(myinnerText, "指定記事は存在しません") > 0
            myinnerText = Replace(myinnerText, vbCrLf, 1, 5)
            Cells(r, "B").Value = vbLf & myinnerText
          Case Else
            myDate = Mid(myinnerText, InStr(myinnerText, "upload" & vbCr) - 11, 10)
            myDate = Replace(myDate, ".", "/")
            myDate = Format(CDate(myDate), "m月d日")
            '
            myinnerText = Mid(myinnerText, InStr(myinnerText, "［ニュース一覧へ］") + 10)
            myinnerText = Mid(myinnerText, InStr(myinnerText, vbCrLf & "　") + 2)
            myinnerText = Left(myinnerText, InStr(myinnerText, vbCrLf & vbCrLf & vbCrLf & vbCrLf))
            Cells(r, "B").Value = vbLf & "　　　　" & myDate & vbLf & myinnerText
        End Select
    End Select
    DoEvents
  Next ' i
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  Range("A1").Select
  Set myDoc = Nothing
End Sub ' MyIeXlChibaNpPage *----*----*    *----*----*    *----*----*    *----*----*