Sub MyXlNhk()
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Rem NHKサイト[ニュース]ページ取り込み処理(HttpRequest使用)
  Rem 作譜:Hitrock Camellia Shinopy
  Rem 言語:Excel VBA
  Rem 機能...
  Rem   NHKサイトの[ニュース]ページを読み込みし、
  Rem   Excelシートに書き込みする。
  Rem 注記...
  Rem   MyXlNhkを起動して使用。
  Rem   サイトのページ内容を取り損ねることがあるため、
  Rem   ページを読み込む時に、DoEvents関数で処理を一時停止させる。
  Rem   (これまでの試行により、前のページに戻る時は、不要と思われる。)
  Rem 履歴...
  Rem   第1版:2006/04/25:作成。
  Rem   第2版:2006/07/20:特設情報メニューに対応。
  Rem   第3版:2006/09/20:[もっと詳しく]の取り込みを追加。
  Rem   第4版:2006/11/07:IE7に対応:「about:blank」を「about:」に変更した箇所あり。
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Rem 参照設定する場合...
  Rem   Microsoft Internet Controls
  Rem   Microsoft HTML Object Library
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Dim myHTTP As Variant ' IXMLHTTPRequest
  Dim myIE As Variant ' InternetExplorer
  Dim myDoc As Variant ' MSHTML.HTMLDocument
  Dim myLink As Variant ' MSHTML.HTMLAnchorElement
  '
  Dim myTags As Variant ' DispHTMLElementCollection
  Dim myTag As Variant ' HTMLHeaderElement
  '
  Dim mySubTags As Variant ' DispHTMLElementCollection
  Dim mySubTag As Variant ' HTMLHeaderElement
  '
  Dim c As Long
  Dim i As Long
  Dim r As Long
  Dim rr As Variant
  Dim myCount As Long
  Dim myString As String
  Dim myString1 As String
  Dim myString2 As String
  '
  Dim myURL As String
  Dim myURLweb As String
  Dim myPage As String
  Dim myHref As String
  Dim myArrPage As Variant
  Dim myArrHref As Variant
  Dim myStatusBar As String
  '
  Dim myAns  As Long
  Dim myCbox(1) As Boolean
  Dim myinnerText As String
  Dim myText As String
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  Assistant.Visible = True
  With Assistant.NewBalloon
    .Animation = msoAnimationIdle
    .Icon = msoIconAlertQuery
    .Button = msoButtonSetCancel
    .Heading = vbCr & "NHKサイト" & vbCr _
      & "[ニュース]ページ" & vbCr & "取り込み処理"
    .Text = "処理を実行しますか?"
    .Labels(1).Text = "[実行]"
    .CheckBoxes(1).Checked = False
    .CheckBoxes(1).Text = "{cf 253}" & "[もっと詳しく]"
    myAns = .Show
    myCbox(0) = .CheckBoxes(1).Checked
  End With
  Assistant.Visible = False
  If myAns = msoBalloonButtonCancel Then Exit Sub
  '
  Rem NHKサイトの[ニュース]ページ
  myURL = "http://k.nhk.jp/knews/"
  myURLweb = "http://www.nhk.or.jp/"
  '
  Sheets(1).Activate
  Application.CommandBars("Task Pane").Visible = False
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  Set myHTTP = CreateObject("MSXML2.XMLHTTP") ' ("Microsoft.XMLHTTP")
  Set myIE = CreateObject("InternetExplorer.Application")
  '
  With myIE
    .Navigate "about:blank"
    .Visible = False ' True
    Do While .Busy
      DoEvents
    Loop
    myStatusBar = "□NHKニュース 読み込み開始"
    Application.StatusBar = "MyXlNhk: " & myStatusBar
    DoEvents
    Set myDoc = .Document
  End With
  '
  Call myHTTP.Open("GET", myURL, False)
  Call myHTTP.Send
  If myHTTP.readyState <> 4 Then ' 4:READYSTATE_COMPLETE
    myStatusBar = "接続できません。" & vbCr & myHTTP.statusText & vbCr
    myStatusBar = myStatusBar & "myHTTP.readyState: " & myHTTP.readyState & vbCr
    myStatusBar = myStatusBar & "URL: " & myURL
    MsgBox myStatusBar, vbOKOnly, "MyXlNhk"
    Exit Sub
  End If
  If myHTTP.Status <> 200 Then
    myStatusBar = "接続できません。" & vbCr & myHTTP.statusText & vbCr
    myStatusBar = myStatusBar & "myHTTP.Status: " & myHTTP.Status & vbCr
    myStatusBar = myStatusBar & "URL: " & myURL
    MsgBox myStatusBar, vbOKOnly, "MyXlNhk"
    Exit Sub
  End If
  '
  myText = StrConv(myHTTP.responseBody, vbUnicode)
  myString = "<a href=" & Chr(34) & "../"
  myText = Replace(myText, myString, "<a Zzzhref=" & Chr(34) & "../")
  myDoc.write myText
  '
  myinnerText = myDoc.body.innerText
  myinnerText = Left(myinnerText, InStr(myinnerText, "更新") + 2)
  myText = Mid(myinnerText, InStr(myinnerText, vbCrLf & vbCrLf) + 2)
  myText = Format(CDate(Replace(myText, "更新", "")), "yyyy年m月d日 hh時nn分 更新")
  '
  Columns("A:A").ColumnWidth = 30#
  Columns("B:B").ColumnWidth = 80#
  Columns("C:C").ColumnWidth = 80#
  ActiveWindow.Zoom = 75
  '
  Rows("1").RowHeight = 50#
  Cells(1, "A").Value = myDoc.Title
  Cells(1, "B").Value = myText
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  Rem トップページ処理
  r = 1
  myHref = myURL
  myPage = "■トップ"
  ActiveSheet.Name = myPage
  '
  Application.StatusBar = "MyXlNhk: " & myStatusBar
  '
  Application.ScreenUpdating = True
  '
  c = 0
  For Each myLink In myDoc.Links
    c = c + 1
    myStatusBar = "□NHKニュース 読み込み開始:"
    myStatusBar = myStatusBar & ActiveSheet.Name & c & "/" & myDoc.Links.Length
    Application.StatusBar = "MyXlNhk: " & myStatusBar
    Select Case Left(myLink.innerText, 1)
      Case "■"
        myPage = myPage & "," & myLink.innerText
        ' myHref = myHref & "," & Replace(myLink.href, "about:blank", myURL, 1, 1) ' IE6以前
        myHref = myHref & "," & Replace(myLink.href, "about:", myURL, 1, 1)
      Case "●"
        r = r + 1
        Cells(r, "A").Value = myLink.innerText
        ' Cells(r, "B").Value = Replace(myLink.href, "about:blank", myURL, 1, 1) ' IE6以前
        Cells(r, "B").Value = Replace(myLink.href, "about:", myURL, 1, 1)
        ' myString = Replace(myLink.href, "about:blank", myURLweb, 1, 1) ' IE6以前
        myString = Replace(myLink.href, "about:", myURLweb, 1, 1)
        myString1 = Left(myString, InStrRev(myString, "/t") - 1)
        myString2 = Replace(myString, "/t", "/d", InStrRev(myString, "/t"), 1)
        Cells(r, "C").Value = myString1 & myString2
        Cells(r, "A").Select
        Cells(r, "A").Hyperlinks.Add Anchor:=Selection, Address:=Cells(r, "C").Value, _
                                                        TextToDisplay:=Cells(r, "A").Text
        If myCbox(0) = False Then
          Cells(r, "C").Value = ""
        End If
      Case Else
        Rem 特設情報メニューと判断する。
        r = r + 1
        Cells(r, "A").Select
        ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=myLink.href, _
                                                      TextToDisplay:=myLink.innerText
        ' Cells(r, "B").Value = Replace(myLink.href, "about:blank", myURL, 1, 1) ' IE6以前
        Cells(r, "B").Value = Replace(myLink.href, "about:", myURL, 1, 1)
    End Select
    DoEvents
  Next ' myDoc.links
  '
  myArrPage = Split(myPage, ",")
  myArrHref = Split(myHref, ",")
  '
  If Worksheets.Count < UBound(myArrPage) + 1 Then
    myCount = UBound(myArrPage) + 1 - Worksheets.Count
    For i = 1 To myCount
      Worksheets.Add After:=Sheets(Worksheets.Count), Count:=1
    Next ' i
  End If
  '
  ReDim rr(UBound(myArrPage) + 1)
  For i = 0 To UBound(myArrPage) + 1
    rr(i) = 0
  Next ' i
  rr(1) = r
  rr(0) = r
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  Rem 分野別処理
  For i = 1 To UBound(myArrPage)
    Sheets(i + 1).Activate
    ActiveSheet.Name = myArrPage(i)
    Columns("A:A").ColumnWidth = 30#
    Columns("B:B").ColumnWidth = 80#
    Columns("C:C").ColumnWidth = 80#
    ActiveWindow.Zoom = 75
    '
    With myIE
      .Navigate "about:blank"
      .Visible = False ' True
      Do While .Busy
        DoEvents
      Loop
      myStatusBar = "□NHKニュース 読み込み開始:"
      myStatusBar = myStatusBar & myArrPage(i) & i & "/" & UBound(myArrPage)
      Application.StatusBar = "MyXlNhk: " & myStatusBar
      DoEvents
      Set myDoc = .Document
    End With
    '
    myURL = myArrHref(i)
    Call myHTTP.Open("GET", myArrHref(i), False)
    Call myHTTP.Send
    If myHTTP.readyState <> 4 Then ' 4:READYSTATE_COMPLETE
      myStatusBar = "接続できません。" & vbCr & myHTTP.statusText & vbCr
      myStatusBar = myStatusBar & "myHTTP.readyState: " & myHTTP.readyState & vbCr
      myStatusBar = myStatusBar & "URL: " & myArrHref(i)
      MsgBox myStatusBar, vbOKOnly, "MyXlNhk"
      Exit Sub
    End If
    If myHTTP.Status <> 200 Then
      myStatusBar = "接続できません。" & vbCr & myHTTP.statusText & vbCr
      myStatusBar = myStatusBar & "myHTTP.Status: " & myHTTP.Status & vbCr
      myStatusBar = myStatusBar & "URL: " & myArrHref(i)
      MsgBox myStatusBar, vbOKOnly, "MyXlNhk"
      Exit Sub
    End If
    '
    myText = StrConv(myHTTP.responseBody, vbUnicode)
    myString = "<a href=" & Chr(34) & "../"
    myText = Replace(myText, myString, "<a Zzzhref=" & Chr(34) & "../")
    myDoc.write myText
    '
    r = 1
    c = 0
    myURL = Left(myURL, InStrRev(myURL, "genre") - 1)
    For Each myLink In myDoc.Links
      c = c + 1
      myStatusBar = "□NHKニュース 読み込み開始:"
      myStatusBar = myStatusBar & myArrPage(i) & c & "/" & myDoc.Links.Length
      Application.StatusBar = "MyXlNhk: " & myStatusBar
      Select Case Left(myLink.innerText, 1)
        Case "■"
          Rem
        Case "●"
          r = r + 1
          Cells(r, "A").Value = myLink.innerText
          ' Cells(r, "B").Value = Replace(myLink.href, "about:blank", myURL, 1, 1) ' IE6以前
          Cells(r, "B").Value = Replace(myLink.href, "about:", myURL, 1, 1)
          myString = Mid(myURL, InStr(myURL, "/news/") + 1)
          ' Cells(r, "C").Value = myURLweb & myString & Replace(myLink.href, "about:blankk", "d") ' IE6以前
          Cells(r, "C").Value = myURLweb & myString & Replace(myLink.href, "about:k", "d")
          Cells(r, "A").Select
          Cells(r, "A").Hyperlinks.Add Anchor:=Selection, Address:=Cells(r, "C").Value, _
                                                          TextToDisplay:=Cells(r, "A").Text
          If myCbox(0) = False Then
            Cells(r, "C").Value = ""
          End If
      End Select
      DoEvents
    Next ' myDoc.links
    Cells(1, "A").Select
    rr(i + 1) = r
    rr(0) = rr(0) + r
    DoEvents
  Next ' i
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  Sheets(1).Activate
  ActiveSheet.Range("A1").Select
  c = 0
  If myCbox(0) = True Then
    rr(0) = rr(0) * 2
  End If
  '
  Application.ScreenUpdating = False ' True
  For i = 0 To UBound(myArrPage)
    myStatusBar = "●読み込み中:" & ActiveSheet.Name & " " & i + 1 & "/" & UBound(myArrPage)
    Application.StatusBar = "MyXlNhk: " & myStatusBar
    Sheets(i + 1).Activate
    Call MyXlNhkPage(i, c, rr, myHTTP, myIE)
  Next ' i
  '
  If myCbox(0) = True Then
    For i = 0 To UBound(myArrPage)
      myStatusBar = "●読み込み中:" & ActiveSheet.Name & " " & i + 1 & "/" & UBound(myArrPage)
      Application.StatusBar = "MyXlNhk: " & myStatusBar
      Sheets(i + 1).Activate
      Call MyXlNhkDetl(i, c, rr, myHTTP, myIE)
    Next ' i
  End If
  Application.ScreenUpdating = True
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
MyXlNhkSubExit:
  myIE.Visible = True
  myIE.Quit
  Application.ScreenUpdating = True
  Sheets(1).Activate
  ActiveSheet.Range("B1").Select
  '
  myStatusBar = "処理が終了しました。"
  Application.StatusBar = "MyXlNhk: " & myStatusBar & Now()
  Application.Speech.Speak myStatusBar, False
  Beep
  '
  Set myHTTP = Nothing
  Set myIE = Nothing
  Set myDoc = Nothing
End Sub ' MyXlNhk *----*----*    *----*----*    *----*----*    *----*----*

Sub MyXlNhkPage(i As Long, c As Long, rr As Variant, myHTTP As Variant, myIE As Variant)
  Dim myDoc As Variant ' MSHTML.HTMLDocument
  Dim r As Long
  Dim myURL As String
  Dim myinnerText As String
  Dim myStatusBar As String
  Dim myLead As String
  Dim myText As String
  Dim myDate As String
  '
  c = c + 1
  For r = 2 To rr(i + 1)
    c = c + 1
    If Len(Cells(r, "B").Value) <> 0 Then
      With myIE
        .Navigate "about:blank"
        .Visible = False ' True
        Do While .Busy
          DoEvents
        Loop
        myStatusBar = "●読み込み中:" & c * 100 \ rr(0) & "% "
        myStatusBar = myStatusBar & ActiveSheet.Name & " "
        myStatusBar = myStatusBar & r & "/" & rr(i + 1) & "行 "
        myStatusBar = myStatusBar & i + 1 & "/" & UBound(rr) & "頁"
        Application.StatusBar = "MyXlNhkPage: " & myStatusBar
        DoEvents
        Set myDoc = .Document
      End With
      '
      myURL = Cells(r, "B").Value
      Call myHTTP.Open("GET", myURL, False)
      myHTTP.Send
      If myHTTP.readyState <> 4 Then ' 4:READYSTATE_COMPLETE
        myStatusBar = "接続できません。" & vbCr & myHTTP.statusText & vbCr
        myStatusBar = myStatusBar & "myHTTP.readyState: " & myHTTP.readyState & vbCr
        myStatusBar = myStatusBar & "URL: " & myURL
        MsgBox myStatusBar, vbOKOnly, "MyXlNhkPage"
        Exit Sub
      End If
      If myHTTP.Status <> 200 Then
        myStatusBar = "接続できません。" & vbCr & myHTTP.statusText & vbCr
        myStatusBar = myStatusBar & "myHTTP.Status: " & myHTTP.Status & vbCr
        myStatusBar = myStatusBar & "URL: " & myURL
        MsgBox myStatusBar, vbOKOnly, "MyXlNhkPage"
        Exit Sub
      End If
      '
      myDoc.write StrConv(myHTTP.responseBody, vbUnicode)
      myinnerText = myDoc.body.innerText
      Select Case True
        Case InStrRev(myinnerText, vbCrLf & "前へ") > 0
          myinnerText = Left(myinnerText, InStrRev(myinnerText, vbCrLf & "前へ"))
        Case InStrRev(myinnerText, vbCrLf & "次へ") > 0
          myinnerText = Left(myinnerText, InStrRev(myinnerText, vbCrLf & "次へ"))
        Case InStrRev(myinnerText, vbCrLf & "ニューストップ") > 0
          myinnerText = Left(myinnerText, InStrRev(myinnerText, vbCrLf & "ニューストップ"))
      End Select
      '
      myinnerText = Replace(myinnerText, vbCrLf, vbLf, 1, 1)
      myLead = " " & Left(myinnerText, InStr(myinnerText, vbCr) - 1)
      myText = Replace(myinnerText, vbCrLf & vbCrLf, "")
      '
      Cells(r, "A").Value = myLead ' 記事の見出し
      Cells(r, "B").Value = " " & myText & vbLf ' 記事の本文
    End If
    DoEvents
  Next ' r
  '
  ActiveSheet.Range("B1").Select
  Set myDoc = Nothing
End Sub ' MyXlNhkPage *----*----*    *----*----*    *----*----*    *----*----*

Sub MyXlNhkDetl(i As Long, c As Long, rr As Variant, myHTTP As Variant, myIE As Variant)
  Dim myDoc As Variant ' MSHTML.HTMLDocument
  Dim j As Long
  Dim r As Long
  Dim myURL As String
  Dim myinnerText As String
  Dim myStatusBar As String
  Dim myLead As String
  Dim myText As String
  Dim myString As String
  '
  Dim myTags As Variant ' DispHTMLElementCollection
  Dim myTag As Variant ' HTMLDivElement
  '
  c = c + 1
  For r = 2 To rr(i + 1)
    c = c + 1
    If Len(Cells(r, "C").Value) <> 0 Then
      With myIE
        .Navigate "about:blank"
        .Visible = False ' True
        Do While .Busy
          DoEvents
        Loop
        myStatusBar = "●読み込み中:" & c * 100 \ rr(0) & "% "
        myStatusBar = myStatusBar & ActiveSheet.Name & " "
        myStatusBar = myStatusBar & r & "/" & rr(i + 1) & "行 "
        myStatusBar = myStatusBar & i + 1 & "/" & UBound(rr) & "頁"
        Application.StatusBar = "MyXlNhkDetl: " & myStatusBar
        DoEvents
        Set myDoc = .Document
      End With
      '
      myURL = Cells(r, "C").Value
      Call myHTTP.Open("GET", myURL, False)
      On Error Resume Next
      myHTTP.Send
      If myHTTP.readyState <> 4 Then ' 4:READYSTATE_COMPLETE
        myStatusBar = "接続できません。" & vbCr & myHTTP.statusText & vbCr
        myStatusBar = myStatusBar & "myHTTP.readyState: " & myHTTP.readyState & vbCr
        myStatusBar = myStatusBar & "URL: " & myURL
        MsgBox myStatusBar, vbOKOnly, "MyXlNhkDetl"
        Exit Sub
      End If
      Cells(r, "C").Select
      If myHTTP.Status <> 200 Then
        'myStatusBar = "接続できません。" & vbCr & myHTTP.statusText & vbCr
        'myStatusBar = myStatusBar & "myHTTP.Status: " & myHTTP.Status & vbCr
        'myStatusBar = myStatusBar & "URL: " & myURL
        'MsgBox myStatusBar, vbOKOnly, "MyXlNhkDetl"
        'Exit Sub
        Rem myText = "ページを表示できませんでした。" ' 記事がない場合(記事が未入力)
        myText = "●" & Cells(r, "B").Text
        Cells(r, "C").Value = myText & vbLf
        '
        Cells(r, "A").Select
        Selection.Hyperlinks(1).Address = Replace(myURL, "/d", "/k")
      Else
        myText = StrConv(myHTTP.responseBody, vbUnicode)
        myText = Replace(myText, " src=", " Zzzsrc=")
        myText = Replace(myText, "<script", "<!-- script")
        myDoc.write myText
        '
        Set myTags = myDoc.getElementsByTagName("div")
        If myTags.Length = 3 Then
          j = 0
        Else
          j = 1
        End If
        myText = Cells(r, "A").Text & vbLf ' 記事の見出し
        myText = myText & myTags.Item(j).innerText & vbLf ' 記事の本文
        myText = myText & "(" & myTags.Item(j + 1).innerText & ")" ' 記事の日付
        Cells(r, "C").Value = myText & vbLf
      End If
      On Error GoTo 0
    End If
    DoEvents
  Next ' r
  '
  ActiveSheet.Range("B1").Select
  Set myDoc = Nothing
End Sub ' MyXlNhkDetl *----*----*    *----*----*    *----*----*    *----*----*
inserted by FC2 system