Sub MyXlNtv()
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Rem 日本テレビPDA版サイト[日テレNEWS24]ページ読み込み処理
  Rem （HttpRequest使用）
  Rem 作譜：Hitrock Camellia Shinopy
  Rem 言語：Excel VBA
  Rem 機能...
  Rem   日本テレビPDA版サイトの[日テレNEWS24]ページを読み込みし、
  Rem   Excelシートに書き込みする。
  Rem 注記...
  Rem   1. MyXlNtvを起動して使用｡
  Rem   2. 文字列変数「myIEblank」の値指定は、IEのバージョンによって変更要！
  Rem      「about:blank」と「about:」の対処が、IEのバージョンによって異なるので注意。
  Rem       myHref = myHref & "," & Replace(myLink.href, "about:blank", myHrefFirst, 1, 1) ' IE6以前? MSN版IE7?
  Rem       myHref = myHref & "," & Replace(myLink.href, "about:", myHrefFirst, 1, 1) ' IE7?
  Rem   3. なぜか、IEの「Visible = False」が機能しないので、
  Rem      ExcelのWindowStateの操作で対処。
  Rem   4. サイトのページ内容を取り損ねることがあるため、
  Rem      ページを読み込む時に、DoEvents関数で処理を一時停止させる。
  Rem      （これまでの試行により、前のページに戻る時は、不要と思われる。）
  Rem 履歴...
  Rem   第1版：2006/04/30：作成。
  Rem   第2版：2006/05/06：分野別にExcelシートに書き込みするよう修正。
  Rem   第3版：2006/06/25：区切りとなる文字がない場合に対処。
  Rem   第4版：2006/11/07：IE7に対応：「about:blank」を「about:」に変更した箇所あり
  Rem   第5版：2007/05/06：「myIEblank」の値指定を修正。WindowState操作を追加。
  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 myURL As String
  Dim myHref As String
  Dim myArray As Variant
  Dim myHead As String
  '
  Dim myStatusBar As String
  Dim myinnerText As String
  Dim myLead As String
  Dim myText As String
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  Rem 日本テレビPDA版サイトの[日テレNEWS24]ページ
  myURL = "http://www.ntv.co.jp/pda/news/main.html"
  '
  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 = "□日テレNEWS24 読み込み開始"
    Application.StatusBar = "MyXlNtv: " & myStatusBar
    DoEvents
    Set myDoc = .Document
  End With
  Application.WindowState = xlMinimized
  Application.WindowState = xlNormal
  '
  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, "MyXlNtv"
    GoTo MyXlNtvSubExit
  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, "MyXlNtv"
    GoTo MyXlNtvSubExit
  End If
  '
  myDoc.write StrConv(myHTTP.responseBody, vbUnicode)
  myHead = myDoc.Title
  Sheets(1).Activate
  myinnerText = myDoc.body.innerText
  myinnerText = Left(myinnerText, InStr(myinnerText, "更新") + 2)
  myinnerText = Trim(myinnerText)
  myLead = Trim(Left(myinnerText, InStr(myinnerText, " ") - 1))
  myText = Mid(myinnerText, InStr(myinnerText, " ") + 1)
  myText = Trim(Format(CDate(Replace(myText, "更新", "")), "m月d日 hh時nn分 更新"))
  '
  Columns("A:A").ColumnWidth = 30#
  Columns("B:B").ColumnWidth = 80#
  Rows("1").RowHeight = 50#
  Cells(1, "A").Value = myLead
  Cells(1, "B").Value = myText
  '
  Application.ScreenUpdating = False
  '
  myHead = "日テレNEWS24"
  myHref = myURL
  '
  Call MyXlNtvPage(myHead, myHref, myHTTP, myIE)
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
MyXlNtvSubExit:
  myIE.Visible = True
  myIE.Quit
  Application.ScreenUpdating = True
  Sheets(1).Activate
  '
  myStatusBar = "処理が終了しました。"
  Application.StatusBar = "MyXlNtv: " & myStatusBar & Now()
  Application.Speech.Speak myStatusBar, False
  '
  Set myHTTP = Nothing
  Set myIE = Nothing
  Set myDoc = Nothing
End Sub ' MyXlNtv *----*----*    *----*----*    *----*----*    *----*----*

Sub MyXlNtvPage(myHead As String, myHref As String, myHTTP As Variant, myIE As Variant)
  Dim myDoc As Variant ' MSHTML.HTMLDocument
  Dim myTag As Variant ' HTMLPhraseElement
  Dim myLink As Variant ' MSHTML.HTMLAnchorElement
  '
  Dim myGenre As Variant
  Dim i As Integer
  Dim j As Integer
  Dim myStart As Long
  Dim myFound As Long
  Dim myCount As Integer
  '
  Dim myTitle As Variant
  Dim myHrefFirst As String
  Dim myIEblank As String
  '
  myIEblank = "about:blank" ' IEのバージョンによって変更要！
  ' myIEblank = "about:" ' IEのバージョンによって変更要！
  '
  Set myDoc = myIE.Document
  myHrefFirst = myHref
  myHrefFirst = Replace(myHrefFirst, "main.html", "")
  '
  Rem 太字の文字列を取り出し、記事類の分野名を取得する。
  For Each myTag In myDoc.getElementsByTagName("B") ' 太字 <B>...</B>
    myHead = myHead & "," & myTag.innerText
  Next ' myTag
  myTitle = Split(myHead, ",")
  myGenre = Split(myDoc.body.innerHTML, "<B>")
  Rem 「■」を数えて、分野別の記事数を取得する。
  myGenre(0) = 0
  For i = 1 To UBound(myGenre)
    j = 0
    myStart = 1
    myFound = InStr(myStart, myGenre(i), "■")
    Do While myFound <> 0
      j = j + 1
      myStart = myFound + 1
      myFound = InStr(myStart, myGenre(i), "■")
    Loop
    myGenre(i) = j
    myGenre(0) = myGenre(0) + j
  Next ' i
  '
  For Each myLink In myDoc.Links
    Select Case InStr(myLink.innerText, "TOPへ戻る")
      Case Is > 0
        Rem
      Case Else
        myHref = myHref & "," & Replace(myLink.href, myIEblank, myHrefFirst, 1, 1)
    End Select
  Next ' myLink
  '
  If Worksheets.Count < UBound(myGenre) Then
    myCount = UBound(myGenre) - Worksheets.Count
    For i = 1 To myCount
      Worksheets.Add After:=Sheets(Worksheets.Count), Count:=1
    Next ' i
  End If
  '
  j = 0
  For i = 1 To UBound(myGenre)
    Sheets(i).Activate
    ActiveSheet.Name = myTitle(i)
    '
    Call MyXlNtvBody(j, myGenre(i), myHref, myHTTP, myIE)
    '
    Columns("A:B").Select
    With Selection
      .HorizontalAlignment = xlGeneral
      .VerticalAlignment = xlCenter
      .WrapText = True
      .Orientation = 0
      .AddIndent = False
      .IndentLevel = 0
      .ShrinkToFit = False
      .ReadingOrder = xlContext
      .MergeCells = False
    End With
    Range("A1").Select
  Next ' i
  '
  Set myDoc = Nothing
End Sub ' MyXlNtvPage *----*----*    *----*----*    *----*----*    *----*----*

Sub MyXlNtvBody(c As Integer, myMax As Variant, myHref As String, myHTTP As Variant, myIE As Variant)
  Dim myDoc As Variant ' MSHTML.HTMLDocument
  Dim myArray As Variant
  Dim myStatusBar As String
  Dim i As Integer
  Dim myLine As Integer
  Dim myinnerText As String
  Dim myLead As String
  Dim myText As String
  Dim myDate As String
  '
  Set myDoc = myIE.Document
  myArray = Split(myHref, ",")
  '
  Columns("A:A").ColumnWidth = 30#
  Columns("B:B").ColumnWidth = 80#
  If InStr(ActiveSheet.Name, "トップ") > 0 Then
    myLine = 2
  Else
    myLine = 1
  End If
  '
  For i = 1 To myMax
    c = c + 1
    With myIE
      .Navigate "about:blank"
      .Visible = False ' True
      Do While .Busy
        DoEvents
      Loop
      myStatusBar = ActiveSheet.Name & " " & "■読み込み中：" & c & "/" & UBound(myArray)
      Application.StatusBar = "MyXlNtvBody: " & myStatusBar
      DoEvents
      Set myDoc = .Document
    End With
    '
    Call myHTTP.Open("GET", myArray(c), 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: " & myArray(c)
      MsgBox myStatusBar, vbOKOnly, "MyXlNtv"
      Exit Sub
    End If
    If myHTTP.Status <> 200 Then
      myStatusBar = "接続できません。" & vbCr & myHTTP.statusText & vbCr
      myStatusBar = myStatusBar & "myHTTP.Status: " & myHTTP.Status
      myStatusBar = myStatusBar & "URL: " & myArray(c)
      MsgBox myStatusBar, vbOKOnly, "MyXlNtv"
      Exit Sub
    End If
    '
    myDoc.write StrConv(myHTTP.responseBody, vbUnicode)
    myinnerText = myDoc.body.innerText
    myinnerText = Mid(myinnerText, InStr(myinnerText, "更新 ") + 2)
    myinnerText = Left(myinnerText, InStrRev(myinnerText, vbCrLf & "戻る" & vbCrLf) - 1)
    myinnerText = Replace(myinnerText, vbCrLf & vbCrLf, "", 1, 1)
    myinnerText = Replace(myinnerText, vbLf, vbCr, 1, 1)
    '
    myLead = "　" & Left(myinnerText, InStr(myinnerText, vbCr) - 1)
    myText = Mid(myinnerText, InStr(myinnerText, vbCr) + 1)
    myText = Left(myText, InStrRev(myText, "(") - 1)
    On Error Resume Next ' 区切りとなる文字がない場合に対処。
    myText = Mid(myText, InStr(myText, "　"))
    On Error GoTo 0
    '
    myDate = Mid(myinnerText, InStrRev(myinnerText, "(") + 1)
    myDate = Replace(myDate, ")", "")
    myDate = Format(CDate(myDate), "m月d日 hh時nn分")
    '
    Cells(myLine, "A").Value = myLead
    Cells(myLine, "B").Value = vbLf & myText & "(" & myDate & ")"
    myLine = myLine + 1
  Next ' i
  '
  Set myDoc = Nothing
End Sub ' MyXlNtvBody *----*----*    *----*----*    *----*----*    *----*----*