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 *----*----* *----*----* *----*----* *----*----*