Sub MyXlKanaloco() Rem *----*----* *----*----* *----*----* *----*----* Rem 神奈川新聞サイト[カナロコトップ]ページ取り込み処理(HttpRequest使用) Rem 作譜:Hitrock Camellia Shinopy Rem 言語:Excel VBA Rem 機能... Rem 神奈川新聞サイトのページを取り込みし、 Rem Excelシートに書き込みする。 Rem 注記... Rem 1. MyXlKanalocoを起動して使用。 Rem 2. 「カナガワ事件簿」「デイリーベイスターズ」「カナロコJリーグ」は会員専用。(取り込みしない。) Rem 3. シート(1)から書き込みする。 Rem 履歴... Rem 第1版:2006/08/27:作成。 Rem 第2版:2006/09/10:処理が重複した箇所を修正。 Rem 第3版:2006/11/11:IE7に対応:「about:blank」を「about:」に変更した箇所あり。 Rem 第4版:2007/01/25:Excel2007に対応:バルーン表示を廃止、ポップアップメニューに変更。 Rem 第5版:2007/02/01:コメントの取り込みを追加。 Rem 第6版:2007/05/20:ハイパーリンク不具合・セル幅設定を修正。 Rem 第7版:2007/05/23:ツールバー処理を別モジュールに修正。通信エラー処理をセル値設定に変更。 Rem 第8版:2008/08/23:FaceIdの指定を変更。「459」=>「964」(Excel2007に対応)。 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 myDivMax As Long Dim myCount As Long Dim myText As String Dim myString As String ' Dim myURL As String Dim myHref As String Dim myStatusBar As String ' Dim myTitle As String Dim i As Long Dim myAns As Long Dim myCbox As Boolean Rem *----*----* *----*----* *----*----* *----*----* ' myTitle = "MyXlKanaloco" Call MyXlKanalocoCmmdBar(myTitle) ' Select Case CommandBars(myTitle).Controls(1).FaceId Case 964 myAns = vbOK Case 330 myAns = vbCancel End Select ' If CommandBars(myTitle).Controls(2).FaceId = 220 Then myCbox = True Else myCbox = False End If ' If myAns = vbCancel Then GoTo MyXlKanalocoSubExit End If Rem *----*----* *----*----* *----*----* *----*----* ' Rem 神奈川新聞サイト[カナロコトップ]ページ myURL = "http://www.kanaloco.jp/top/index.html" ' "http://www.kanaloco.jp/" myDivMax = 5 Dim rr(5) As Long For i = 0 To UBound(rr) rr(i) = 0 Next ' i ' Sheets(1).Activate ActiveSheet.Range("A1").Select Application.CommandBars("Task Pane").Visible = False Rem *----*----* *----*----* *----*----* *----*----* ' Set myHTTP = CreateObject("MSXML2.XMLHTTP") ' ("Microsoft.XMLHTTP") Set myIE = CreateObject("InternetExplorer.Application") ' With myIE .Navigate "about:blank" '.Document.Charset = "unicode" .Visible = False ' True Do While .Busy DoEvents Loop myStatusBar = "□神奈川新聞サイト[カナロコトップ]ページ 取り込み開始" If myCbox = True Then myStatusBar = myStatusBar & "(見出し・本文とも取り込み)" Else myStatusBar = myStatusBar & "(見出しのみ取り込み)" End If Application.StatusBar = myTitle & ": " & 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 = "接続できません。" & " readyState <> 4" & vbLf & myHTTP.statusText & vbLf myStatusBar = myStatusBar & "readyState: " & myHTTP.readyState & vbLf myStatusBar = myStatusBar & "URL: " & myURL ActiveCell.Value = myStatusBar ActiveCell.ColumnWidth = 70# GoTo MyXlKanalocoSubExit End If If myHTTP.Status <> 200 Then myStatusBar = "接続できません。" & " Status <> 200" & vbLf & myHTTP.statusText & vbLf myStatusBar = myStatusBar & "readyState: " & myHTTP.readyState & vbLf myStatusBar = myStatusBar & "URL: " & myURL ActiveCell.Value = myStatusBar ActiveCell.ColumnWidth = 70# GoTo MyXlKanalocoSubExit End If ' myString = "<div id=" & Chr(34) & "partOfficeblog" & Chr(34) & ">" myText = Replace(myHTTP.responseText, "<div class=" & Chr(34) & "partOfficeblog" & Chr(34) & ">", myString) myText = Replace(myText, "<script ", "<!-- script ") myText = Replace(myText, " src=", " Zzzsrc=") ' myDoc.write myText myDoc.Title = myURL Rem *----*----* *----*----* *----*----* *----*----* ' If Worksheets.Count < myDivMax Then myCount = myDivMax - Worksheets.Count For i = 1 To myCount Worksheets.Add After:=Sheets(Worksheets.Count), Count:=1 Next ' i End If Rem *----*----* *----*----* *----*----* *----*----* ' Application.ScreenUpdating = False Sheets(1).Activate ActiveSheet.Range("A1").Select ' Call MyXlKanalocoPage(rr, myDoc) Rem *----*----* *----*----* *----*----* *----*----* ' Sheets(1).Activate ActiveSheet.Range("A1").Select Rem ニュース本文の取り込み If myCbox = True Then Call MyXlKanalocoBody(rr, myHTTP, myIE) End If Rem *----*----* *----*----* *----*----* *----*----* ' MyXlKanalocoSubExit: On Error Resume Next Application.ScreenUpdating = True Sheets(1).Activate ' Rem myIE.Visible = True myIE.Quit CommandBars(myTitle).Delete Set myHTTP = Nothing Set myIE = Nothing Set myDoc = Nothing On Error GoTo 0 ' If myAns = vbCancel Then Exit Sub myStatusBar = "処理が終了しました。" Application.StatusBar = myTitle & ": " & myStatusBar & Now() Application.Speech.Speak myStatusBar, False Beep End Sub ' MyXlKanaloco *----*----* *----*----* *----*----* *----*----* Sub MyXlKanalocoPage(rr As Variant, myDoc As Variant) Dim myTagDivs As Variant ' DispHTMLElementCollection Dim myTagDiv As Variant ' HTMLDivElement Dim mySubTags As Variant ' DispHTMLElementCollection Dim mySubTag As Variant ' HTMLHeaderElement ' Dim myText As String Dim myString As String ' Dim myURL As String Dim myHref As String Dim myStatusBar As String ' Dim i As Long Rem *----*----* *----*----* *----*----* *----*----* ' myURL = myDoc.Title ' Set myTagDivs = myDoc.getElementsByTagName("div") For Each myTagDiv In myTagDivs myStatusBar = "□神奈川新聞サイト[カナロコトップ]ページ 取り込み中:" & myTagDiv.ID Application.StatusBar = "MyXlKanaloco: " & myStatusBar myTagDiv.Title = myURL ' Select Case myTagDiv.ID Case "naviNews", "naviSports", "naviLocal", "naviUninet", "naviLive", "naviCommodity" myTagDiv.Title = Replace(myURL, "top/index.html", "") rr(0) = 1 i = rr(0) Sheets(i).Activate If rr(i) = 0 Then ActiveSheet.Range("A1").Select ActiveSheet.Name = "主要コンテンツ" End If ' Call MyXlKanalocoTags("h3", "li", rr, myTagDiv) ' *----*----* *----*----* *----*----* *----*----* Case "partTopnews", "partPhotonews" rr(0) = 2 i = rr(0) Sheets(i).Activate If rr(i) = 0 Then ActiveSheet.Range("A1").Select ActiveSheet.Name = "ニュース(1段目)" End If ' Call MyXlKanalocoTags("h3", "h4", rr, myTagDiv) ' *----*----* *----*----* *----*----* *----*----* Case "subPartSocial", "subPartPolitics", "subPartUSForce", "subPartEconomics", _ "subPartCulture", "subPartEducation", "subPartLife" rr(0) = 3 i = rr(0) Sheets(i).Activate If rr(i) = 0 Then ActiveSheet.Range("A1").Select ActiveSheet.Name = "ニュース(2段目)" End If ' Call MyXlKanalocoTags("h4", "li", rr, myTagDiv) ' *----*----* *----*----* *----*----* *----*----* Case "partSportsnews", "partCasefiles" rr(0) = 2 i = rr(0) Sheets(i).Activate If rr(i) = 0 Then ActiveSheet.Range("A1").Select ActiveSheet.Name = "ニュース(2段目)" End If ' Call MyXlKanalocoTags("h3", "li", rr, myTagDiv) ' *----*----* *----*----* *----*----* *----*----* Case "partSerial" rr(0) = 4 i = rr(0) Sheets(i).Activate If rr(i) = 0 Then ActiveSheet.Range("A1").Select End If ' Call MyXlKanalocoTags("h3", "li", rr, myTagDiv) ' *----*----* *----*----* *----*----* *----*----* Case "partOfficeblog" rr(0) = 5 i = rr(0) Sheets(i).Activate If rr(i) = 0 Then ActiveSheet.Range("A1").Select End If ' Call MyXlKanalocoTags("h3", "li", rr, myTagDiv) ' *----*----* *----*----* *----*----* *----*----* Case "naviToday" rr(0) = 1 i = rr(0) Sheets(i).Activate If rr(i) = 0 Then ActiveSheet.Range("A1").Select ActiveSheet.Name = "主要コンテンツへのリンク" End If ' Set mySubTags = myTagDiv.getElementsByTagName("h2") Cells(1, "A").Value = "神奈川新聞社" Cells(1, "B").Value = myTagDiv.innerText ' *----*----* *----*----* *----*----* *----*----* Case "partWeatherReport" rr(0) = 2 i = rr(0) Sheets(i).Activate If rr(i) = 0 Then ActiveSheet.Range("A1").Select ActiveSheet.Name = ActiveSheet.Name = "ニュース(1段目)" End If ' Call MyXlKanalocoTags("h3", "", rr, myTagDiv) ' *----*----* *----*----* *----*----* *----*----* End Select ' ActiveWindow.SmallScroll up:=rr(i) ActiveSheet.Range("A1").Select Columns("A:A").ColumnWidth = 50# Columns("B:B").ColumnWidth = 70# Columns("C:C").ColumnWidth = 100# Columns("A:C").WrapText = True DoEvents Next ' myTagDiv End Sub ' MyXlKanalocoPage *----*----* *----*----* *----*----* *----*----* Sub MyXlKanalocoTags(myTag1 As String, myTag2 As String, rr As Variant, myTagDiv As Variant) Dim mySubTags As Variant ' DispHTMLElementCollection Dim mySubTag As Variant ' HTMLHeaderElement ' Dim myText As String Dim myString As String ' Dim myURL As String Dim myHref As String Dim myStatusBar As String Dim myIEblank As String Dim i As Long Rem *----*----* *----*----* *----*----* *----*----* ' myIEblank = "about:blank/" Rem myIEblank = "about:/" ???? ' myURL = myTagDiv.Title i = rr(0) ' Set mySubTags = myTagDiv.getElementsByTagName(myTag1) Select Case myTagDiv.ID Case "naviToday" Rem Case Else rr(i) = rr(i) + 2 Cells(rr(i), "A").Interior.ColorIndex = 34 ' 薄い水色 End Select ' Select Case myTagDiv.ID Case "naviToday" Rem Case "partTopnews", "partPhotonews" Cells(rr(i), "A").Value = " ○" & " " & mySubTags.Item(0).childNodes.Item(0).alt Case "partWeatherReport" Cells(rr(i), "A").Value = " ○" & " " & myTagDiv.childNodes.Item(0).innerText Case "partSerial" ActiveSheet.Name = mySubTags.Item(0).childNodes.Item(0).alt ActiveSheet.Name = Replace(ActiveSheet.Name, "神奈川新聞の", "") Cells(rr(i), "A").Value = " ○" & " " & mySubTags.Item(0).childNodes.Item(0).alt Case "partOfficeblog" ActiveSheet.Name = mySubTags.Item(0).innerText ActiveSheet.Name = Replace(ActiveSheet.Name, "カナロコ", "") Cells(rr(i), "A").Value = " ○" & " " & mySubTags.Item(0).innerText Case Else Cells(rr(i), "A").Value = " ○" & " " & mySubTags.Item(0).innerText End Select Rem *----*----* *----*----* *----*----* *----*----* ' Select Case myTagDiv.ID Case "naviToday" Rem Case "partWeatherReport" For Each mySubTag In myTagDiv.childNodes Select Case mySubTag.ID Case "subPartEast", "subPartWest" If Len(mySubTag.innerText) <> 0 And mySubTag.innerText <> " " Then rr(i) = rr(i) + 1 Cells(rr(i), "A").Value = " " & mySubTag.innerText myText = Left(mySubTag.innerHTML, InStr(mySubTag.innerHTML, " Zzzsrc=") - 1) myText = Mid(myText, InStr(myText, " alt=") + 5) myText = vbCrLf & myText Cells(rr(i), "A").Value = Replace(Cells(rr(i), "A").Value, vbCrLf, myText, 1, 1) End If End Select DoEvents Next ' mySubTag Case Else Set mySubTags = myTagDiv.getElementsByTagName(myTag2) For Each mySubTag In mySubTags If Len(mySubTag.innerText) <> 0 And mySubTag.innerText <> " " Then rr(i) = rr(i) + 1 myHref = Replace(mySubTag.childNodes(0).href, myIEblank, myURL) ActiveSheet.Hyperlinks.Add Anchor:=Cells(rr(i), "A"), Address:=myHref, TextToDisplay:=mySubTag.innerText ' If ActiveSheet.Name <> "主要コンテンツ" Then If CommandBars("MyXlKanaloco").Controls(2).FaceId = 220 Then Cells(rr(i), "B").Value = myHref End If End If End If DoEvents Next ' mySubTag End Select End Sub ' MyXlKanalocoTags *----*----* *----*----* *----*----* *----*----* Sub MyXlKanalocoBody(rr As Variant, myHTTP As Variant, myIE As Variant) Dim myDoc As Variant ' MSHTML.HTMLDocument Dim myTagDivs As Variant ' DispHTMLElementCollection Dim myTagDiv As Variant ' HTMLDivElement Dim mySubTags As Variant ' DispHTMLElementCollection Dim mySubTag As Variant ' HTMLHeaderElement ' Dim myMax As Long Dim myText As String Dim myString As String ' Dim myURL As String Dim myFlag As Boolean Dim myStatusBar As String ' Dim i As Long Dim r As Long Dim c As Long Rem *----*----* *----*----* *----*----* *----*----* ' c = 0 myMax = 0 For i = 2 To Worksheets.Count myMax = myMax + rr(i) Next ' i ' myStatusBar = "□神奈川新聞サイト[カナロコトップ]ページ 本文 取り込み開始" Application.StatusBar = "MyXlKanaloco: " & myStatusBar ' For i = 2 To Worksheets.Count Sheets(i).Activate c = c + 1 ActiveWindow.Zoom = 75 For r = 2 To rr(i) myFlag = True c = c + 1 With myIE .Navigate "about:blank" .Visible = False ' True Do While .Busy DoEvents Loop DoEvents Set myDoc = myIE.Document End With ' If Len(Cells(r, "B").Value) = 0 Then myFlag = False Else myURL = Cells(r, "B").Value ' Call myHTTP.Open("GET", myURL, False) Call myHTTP.Send If myHTTP.readyState <> 4 Then ' 4:READYSTATE_COMPLETE myStatusBar = "接続できません。" & " readyState <> 4" & vbLf & myHTTP.statusText & vbLf myStatusBar = myStatusBar & "readyState: " & myHTTP.readyState & vbLf myStatusBar = myStatusBar & "URL: " & myURL ActiveCell.Value = myStatusBar myFlag = False End If If myHTTP.Status <> 200 Then myStatusBar = "接続できません。" & " Status <> 200" & vbLf & myHTTP.statusText & vbLf myStatusBar = myStatusBar & "readyState: " & myHTTP.readyState & vbLf myStatusBar = myStatusBar & "URL: " & myURL ActiveCell.Value = myStatusBar myFlag = False End If End If ' If myFlag = True Then myString = "<div id=" & Chr(34) & "partEntry" & Chr(34) & ">" myText = Replace(myHTTP.responseText, "<div class=" & Chr(34) & "partEntry" & Chr(34) & ">", myString) myText = Replace(myText, "<link ", "<!-- link ", 1, 1) myText = Replace(myText, "</head>", " --></head>", 1, 1) myText = Replace(myText, "<script ", "<!-- script ") myText = Replace(myText, " src=", " Zzzsrc=") myText = Replace(myText, "<img ", "<Zzzimg ") myDoc.write myText ' Set myTagDivs = myDoc.getElementsByTagName("div") For Each myTagDiv In myTagDivs myStatusBar = "□神奈川新聞サイト[カナロコトップ]ページ 本文 取り込み中 " myStatusBar = myStatusBar & c * 100 \ myMax & "% " myStatusBar = myStatusBar & r & "/" & rr(i) & "行 " myStatusBar = myStatusBar & i & "/" & Worksheets.Count & "頁" Application.StatusBar = "MyXlKanaloco: " & myStatusBar ' Select Case myTagDiv.ID Case "partEntry" myText = myTagDiv.innerText myText = Mid(myText, InStr(myText, vbCrLf) + 2) Cells(r, "B").Value = myText Rem Exit For Case "partCommentlist" myText = myTagDiv.innerText myText = Mid(myText, InStr(myText, vbCrLf) + 2) myText = Mid(myText, InStr(myText, "。") + 1) myText = Replace(myText, vbCrLf & vbCrLf & "[", " [", 1, 1) myText = Replace(myText, "]" & vbCrLf & vbCrLf, "]" & vbCrLf, 1, 1) Cells(r, "C").Value = myText Exit For End Select DoEvents Next ' myTagDiv End If DoEvents Next ' r ActiveSheet.Range("B1").Select DoEvents Next ' i End Sub ' MyXlKanalocoBody *----*----* *----*----* *----*----* *----*----* Sub MyXlKanalocoCmmdBar(myTitle As String) Dim myCmmdBar As CommandBar Dim myCtrlBttn As CommandBarControl Dim myCtrlBttnDeTail As CommandBarControl Dim myCtrlBttnOk As CommandBarControl Dim myCtrlBttnCancel As CommandBarControl Dim x As Long Dim y As Long Dim myFaceId As Long Dim myMsg As String Rem *----*----* *----*----* *----*----* *----*----* ' On Error Resume Next CommandBars(myTitle).Delete On Error GoTo 0 ' Set myCmmdBar = CommandBars.Add(Name:=myTitle, Position:=msoBarPopup, Temporary:=True) Set myCtrlBttn = myCmmdBar.Controls.Add(Type:=msoControlButton, Before:=1, Temporary:=True) Set myCtrlBttnDeTail = myCmmdBar.Controls.Add(Type:=msoControlButton, Before:=2, Temporary:=True) Set myCtrlBttnOk = myCmmdBar.Controls.Add(Type:=msoControlButton, Before:=3, Temporary:=True) Set myCtrlBttnCancel = myCmmdBar.Controls.Add(Type:=msoControlButton, Before:=4, Temporary:=True) ' myMsg = myTitle & vbCrLf & vbCrLf myMsg = myMsg & "神奈川新聞サイト" & vbCrLf myMsg = myMsg & "[カナロコトップ]ページ" & vbCrLf myMsg = myMsg & "取り込み処理" & vbCrLf & vbCrLf ' With myCtrlBttn .DescriptionText = "神奈川新聞サイト[カナロコトップ]ページ取り込み処理ポップアップメニュー" .Style = msoButtonIconAndWrapCaption .Caption = myMsg & "処理を実行しますか?" .TooltipText = "処理を実行しますか?" .FaceId = 1089 myFaceId = .FaceId End With ' With myCtrlBttnDeTail .DescriptionText = "神奈川新聞サイト[カナロコトップ]ページ取り込み処理:[もっと詳しく]ボタン" .BeginGroup = True .Style = msoButtonIconAndCaption .Caption = "ニュースの本文も取り込む" .TooltipText = "ニュースの本文・コメントは取り込まない。" .FaceId = 6963 .OnAction = myTitle & "BttnMyDetail" End With ' With myCtrlBttnOk .DescriptionText = "神奈川新聞サイト[カナロコトップ]ページ取り込み処理:[OK]ボタン" .BeginGroup = True .Style = msoButtonIconAndCaption .Caption = "OK" .TooltipText = "処理をを実行します。" .FaceId = 964 .OnAction = myTitle & "BttnMyOk" End With ' With myCtrlBttnCancel .DescriptionText = "神奈川新聞サイト[カナロコトップ]ページ取り込み処理:[キャンセル]ボタン" .Style = msoButtonIconAndCaption .Caption = "キャンセル" & String(12, " ") .TooltipText = "処理を中止します。" .FaceId = 330 .OnAction = myTitle & "BttnMyCancel" End With Rem *----*----* *----*----* *----*----* *----*----* ' x = ActiveWindow.PointsToScreenPixelsX(0) y = ActiveWindow.PointsToScreenPixelsY(0) Beep Do On Error Resume Next myCmmdBar.ShowPopup x, y On Error GoTo 0 DoEvents If myCmmdBar.Controls(1).FaceId <> myFaceId Then Exit Do Loop End Sub ' MyXlKanalocoCmmdBar *----*----* *----*----* *----*----* *----*----* Sub MyXlKanalocoBttnMyOk(Optional myDummy As Boolean) Rem *----*----* *----*----* *----*----* *----*----* Rem コマンドボタン[OK]OnAction処理 Rem *----*----* *----*----* *----*----* *----*----* ' CommandBars("MyXlKanaloco").Controls(1).FaceId = 964 End Sub ' MyXlKanalocoBttnMyOk *----*----* *----*----* *----*----* *----*----* Sub MyXlKanalocoBttnMyCancel(Optional myDummy As Boolean) Rem *----*----* *----*----* *----*----* *----*----* Rem コマンドボタン[キャンセル]OnAction処理 Rem *----*----* *----*----* *----*----* *----*----* ' CommandBars("MyXlKanaloco").Controls(1).FaceId = 330 End Sub ' MyXlKanalocoBttnMyCancel *----*----* *----*----* *----*----* *----*----* Sub MyXlKanalocoBttnMyDetail(Optional myDummy As Boolean) Rem *----*----* *----*----* *----*----* *----*----* Rem [ニュースの本文も取り込む]ボタン処理 Rem *----*----* *----*----* *----*----* *----*----* ' With CommandBars("MyXlKanaloco").Controls(2) If .FaceId = 6963 Then .FaceId = 220 .TooltipText = "ニュースの本文・コメントも取り込む。" Else .FaceId = 6963 .TooltipText = "ニュースの本文・コメントは取り込まない。" End If End With End Sub ' MyXlKanalocoBttnMyDetail *----*----* *----*----* *----*----* *----*----*