Sub MyXlKyodo() Rem *----*----* *----*----* *----*----* *----*----* Rem 神奈川新聞サイト[国内・海外のニュース](共同通信社)ページ取り込み処理 Rem (HttpRequest使用) Rem 作譜:Hitrock Camellia Shinopy Rem 言語:Excel VBA Rem 機能... Rem 神奈川新聞サイトの[国内・海外のニュース]ページを取り込みし、 Rem Excelシートに書き込みする。 Rem 注記... Rem 1. MyXlKyodoを起動して使用。 Rem 2. 文字列変数「myIEblank」の値指定は、IEのバージョンによって変更要! Rem 3. なぜか、IEの「Visible = False」が機能しないので、 Rem ExcelのWindowStateの操作で対処。 Rem 4. サイトのページ内容を取り損ねることがあるため、 Rem ページを読み込む時に、DoEvents関数で処理を一時停止させる。 Rem (これまでの試行により、前のページに戻る時は、不要と思われる。) Rem 5. 音声で処理終了を知らせるため、[コントロール パネル]の[音声認識]にある Rem [音声合成]タブの[音声の選択]で[LH Kenji]または[LH Naoko]を指定しておくこと。 Rem 6. ポップアップメニューのコマンドボタンに付加したOnActionプロパティのプロシージャには、 Rem パラメーターを指定していない。(ExcelVBAでは指定可能だが、他のOffice製品では不可のため。) Rem 履歴... Rem 第1版:2006/09/10:作成。 Rem 第2版:2006/11/07:IE7に対応:「about:blank」を「about:」に変更した箇所あり。 Rem 第3版:2007/01/27:Excel2007に対応:バルーン表示を廃止、ポップアップメニューに変更。 Rem 第4版:2007/05/06:「myIEblank」の値指定を修正。WindowState操作を追加。 Rem 第5版:2007/10/12:神奈川新聞サイトのページ変更に対処。 Rem 第6版:2007/10/15:ポップアップメニューの表示方法を変更。 Rem 第7版:2008/08/23:FaceIdの指定を変更。「459」=>「964」(Excel2007に対応)。 Rem 第8版:2009/10/16:サイトの変更に対処。 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 myTagDivs As Variant ' DispHTMLElementCollection Dim myTagDiv As Variant ' HTMLDivElement Dim mySubTags As Variant ' DispHTMLElementCollection Dim mySubTag As Variant ' HTMLHeaderElement ' Dim myTitle As String Dim rr As Variant Dim myCount As Long Dim myText As String Dim myString As String ' Dim myURL As String Dim myURLkyodo As String Dim myIEblank As String Dim myStatusBar As String ' Dim i As Long Dim myAns As Long Dim myCbox(1) As Boolean Rem *----*----* *----*----* *----*----* *----*----* ' myTitle = "MyXlKyodo" Call MyXlKyodoPopUp(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(0) = True Else myCbox(0) = False End If ' If CommandBars(myTitle).Controls(3).FaceId = 220 Then myCbox(1) = True Else myCbox(1) = False End If ' If myAns = vbCancel Then GoTo MyXlKyodoSubExit Rem *----*----* *----*----* *----*----* *----*----* ' Rem 神奈川新聞サイト[国内・海外のニュース]ページ myURLkyodo = "http://news.kanaloco.jp/kyodo/" myURL = myURLkyodo & "main/" ' myIEblank = "about:blank" ' IEのバージョンによって変更要! myIEblank = "about:" ' IEのバージョンによって変更要! ' 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 ' Application.WindowState = xlMinimized Application.WindowState = xlNormal myStatusBar = "□神奈川新聞サイト [ 国内・海外のニュース ]ページ 取り込み開始" If myCbox(0) = True Then myStatusBar = myStatusBar & "(見出し・本文とも取り込み)" Else myStatusBar = myStatusBar & "(見出しのみ取り込み)" End If Application.StatusBar = myTitle & ": " & 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, "MyXlKyodo" GoTo MyXlKyodoSubExit 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, "MyXlKyodo" GoTo MyXlKyodoSubExit End If ' myText = myHTTP.responseText myText = Mid(myText, InStr(myText, "<!-- main start -->")) myText = Left(myText, InStrRev(myText, "<!-- main end -->") - 1) myDoc.write myText Rem *----*----* *----*----* *----*----* *----*----* ' ' ジャンルの設定 Set myTagDivs = myDoc.getElementsByTagName("div") ' If Worksheets.Count < myTagDivs.Item(3).Children.Length Then myCount = myTagDivs.Item(3).Children.Length - Worksheets.Count For i = 1 To myCount Worksheets.Add After:=Sheets(Worksheets.Count), Count:=1 Next ' i End If Sheets(1).Activate ActiveSheet.Range("A1").Select ' ReDim rr(myTagDivs.Item(3).Children.Length) For i = 1 To UBound(rr) Sheets(i).Activate rr(i) = 2 ' 行位置の指定 Cells(rr(i), "A").Select Cells(rr(i), "A").Interior.ColorIndex = 34 ' 薄い水色 ' Cells(rr(i), "A").Value = " ○" & " " & myTagDivs.Item(3).Children.Item(i - 1).innerText ActiveSheet.Name = myTagDivs.Item(3).Children.Item(i - 1).innerText ' Cells(rr(i), "B").Value = myTagDivs.Item(3).Children.Item(i - 1).href Next ' i Rem *----*----* *----*----* *----*----* *----*----* ' Sheets(1).Activate ActiveSheet.Range("A1").Select ' Application.ScreenUpdating = False For i = 1 To UBound(rr) rr(0) = i Sheets(i).Activate myDoc.Title = myURLkyodo Call MyXlKyodoPage(rr, myHTTP, myIE) Next ' i Application.ScreenUpdating = True Rem *----*----* *----*----* *----*----* *----*----* ' Sheets(1).Activate ActiveSheet.Range("A1").Select Rem ニュース本文の取り込み If myCbox(0) = True Then myDoc.Title = myURLkyodo Call MyXlKyodoBody(myCbox, rr, myHTTP, myIE) End If Rem *----*----* *----*----* *----*----* *----*----* ' MyXlKyodoSubExit: Sheets(1).Activate myStatusBar = "処理が終了しました。" Application.StatusBar = myTitle & ": " & myStatusBar & Now() Application.Speech.Speak myStatusBar, False ' On Error Resume Next Rem myIE.Visible = True myIE.Quit Application.ScreenUpdating = True CommandBars(myTitle).Delete On Error GoTo 0 Beep ' Set myHTTP = Nothing Set myIE = Nothing Set myDoc = Nothing End Sub ' MyXlKyodo *----*----* *----*----* *----*----* *----*----* Sub MyXlKyodoPage(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 myText As String Dim myString As String ' Dim myURL As String Dim myURLkyodo As String Dim myHref As String Dim myIEblank As String Dim myStatusBar As String ' Dim i As Long Dim C As Long Dim myDatePrev As String Dim myDateCurr As String Rem *----*----* *----*----* *----*----* *----*----* ' ' myIEblank = "about:blank" ' IEのバージョンによって変更要! myIEblank = "about:" ' IEのバージョンによって変更要! ' i = rr(0) myURLkyodo = myIE.Document.Title ' With myIE .Navigate "about:blank" .Visible = False ' True Do While .Busy DoEvents Loop DoEvents Set myDoc = myIE.Document End With myStatusBar = "□神奈川新聞サイト [ 国内・海外のニュース ]ページ 取り込み中:" & ActiveSheet.Name myURL = Cells(2, "B").Value ' 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, "MyXlKyodo" GoTo MyXlKyodoPageSubExit 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, "MyXlKyodo" GoTo MyXlKyodoPageSubExit End If ' myText = myHTTP.responseText myText = Mid(myText, InStr(myText, "<!-- main start -->")) myText = Left(myText, InStrRev(myText, "<!-- main end -->") - 1) myDoc.write myText ' C = 0 Set myTagDivs = myDoc.getElementsByTagName("li") If myTagDivs.Length = 0 Then rr(i) = rr(i) + 1 Cells(rr(i), "A").Select myText = "現在、掲載記事がありません。" myHref = Cells(2, "B").Value Cells(2, "B").Value = "" ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=myHref, TextToDisplay:=myText ActiveSheet.Range("A1").Select Columns("A:A").ColumnWidth = 70# Columns("B:B").ColumnWidth = 70# Else Cells(2, "B").Value = "" ' myDatePrev = myTagDivs.Item(0).ChildNodes.Item(0).NodeValue myDatePrev = Left(myDatePrev, InStr(myDatePrev, " ") - 1) For Each myTagDiv In myTagDivs C = C + 1 myStatusBar = "□神奈川新聞サイト [ 国内・海外のニュース ]ページ 取り込み中:" myStatusBar = myStatusBar & " ○ " & ActiveSheet.Name & " " & C & "/" & myTagDivs.Length Application.StatusBar = "MyXlKyodo: " & myStatusBar ' myDateCurr = myTagDiv.ChildNodes(0).NodeValue myDateCurr = Left(myDateCurr, InStr(myDateCurr, " ") - 1) If myDateCurr <> myDatePrev Then rr(i) = rr(i) + 1 Cells(rr(i), "A").Select myDatePrev = myTagDiv.ChildNodes(0).NodeValue myDatePrev = Left(myDatePrev, InStr(myDatePrev, " ") - 1) End If ' rr(i) = rr(i) + 1 Cells(rr(i), "A").Select myText = myTagDiv.ChildNodes(0).NodeValue & " " myText = myText & myTagDiv.ChildNodes(1).innerText & " " myHref = myTagDiv.ChildNodes(1).href ' ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=myHref, TextToDisplay:=myText ' ActiveWindow.SmallScroll up:=rr(i) ActiveSheet.Range("A1").Select Columns("A:A").ColumnWidth = 70# Columns("B:B").ColumnWidth = 70# DoEvents Next ' myTagDiv End If MyXlKyodoPageSubExit: Rem End Sub ' MyXlKyodoPage *----*----* *----*----* *----*----* *----*----* Sub MyXlKyodoBody(myCbox As Variant, 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 myURLkyodo As String Dim myStatusBar As String ' Dim i As Long Dim r As Long Dim C As Long Rem *----*----* *----*----* *----*----* *----*----* ' i = rr(0) myURLkyodo = myIE.Document.Title ' myMax = 0 If myCbox(1) = True Then For i = 1 To Worksheets.Count Sheets(i).Activate C = 2 For r = 3 To rr(i) If Len(Cells(r, "A").Value) = 0 Then Exit For C = C + 1 Next ' r rr(i) = C myMax = myMax + rr(i) Next ' i Else C = 0 For i = 1 To Worksheets.Count myMax = myMax + rr(i) Next ' i End If ' myStatusBar = "□神奈川新聞サイト [ 国内・海外のニュース ]ページ 本文 取り込み開始" Application.StatusBar = "MyXlKyodo: " & myStatusBar ' For i = 1 To Worksheets.Count Sheets(i).Activate C = C + 2 ActiveWindow.Zoom = 75 For r = 3 To rr(i) Cells(r, "A").Select C = C + 1 If myCbox(1) = True Then If Len(Cells(r, "A").Value) = 0 Then Exit For End If ' If Len(Cells(r, "A").Value) <> 0 Then With myIE .Navigate "about:blank" .Visible = False ' True Do While .Busy DoEvents Loop DoEvents Set myDoc = myIE.Document End With myURL = Cells(r, "A").Hyperlinks(1).Address ' 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, "MyXlKyodo" GoTo MyXlKyodoBodySubExit 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, "MyXlKyodo" GoTo MyXlKyodoBodySubExit End If ' myText = myHTTP.responseText myText = Mid(myText, InStr(myText, "<!-- main start -->")) myText = Left(myText, InStrRev(myText, "<!-- main end -->") - 1) myDoc.write myText ' Set myTagDivs = myDoc.getElementsByTagName("div") ' myStatusBar = "□神奈川新聞サイト [ 国内・海外のニュース ]ページ 本文 取り込み中 " myStatusBar = myStatusBar & C * 100 \ myMax & "% " myStatusBar = myStatusBar & r & "/" & rr(i) & "行 " myStatusBar = myStatusBar & i & "/" & Worksheets.Count & "頁" Application.StatusBar = "MyXlKyodo: " & myStatusBar ' If myTagDivs.Length <> 0 Then Cells(r, "B").Value = myTagDivs.Item(0).LastChild.innerText Else Rem 「この記事は削除されました。」の場合 Set myTagDivs = myDoc.getElementsByTagName("p") Cells(r, "B").Value = myTagDivs.Item(0).innerText End If End If DoEvents Next ' r ActiveSheet.Range("B1").Select DoEvents Next ' i ' *----*----* *----*----* *----*----* *----*----* ' MyXlKyodoBodySubExit: Rem End Sub ' MyXlKyodoBody *----*----* *----*----* *----*----* *----*----* Sub MyXlKyodoPopUp(myTitle As String) Rem *----*----* *----*----* *----*----* *----*----* Rem ポップアップ表示処理 Rem *----*----* *----*----* *----*----* *----*----* Dim myCmmdBar As CommandBar Dim myCtrlBttn As CommandBarControl Dim myCtrlBttnDeTail As CommandBarControl Dim myCtrlBttnLastest 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 ' 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 myCtrlBttnLastest = myCmmdBar.Controls.Add(Type:=msoControlButton, Before:=3, Temporary:=True) Set myCtrlBttnOk = myCmmdBar.Controls.Add(Type:=msoControlButton, Before:=4, Temporary:=True) Set myCtrlBttnCancel = myCmmdBar.Controls.Add(Type:=msoControlButton, Before:=5, Temporary:=True) ' myMsg = myTitle & vbCrLf & vbCrLf myMsg = myMsg & "神奈川新聞サイト" & 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 = "MyXlKyodoBttnMyDetail" End With ' With myCtrlBttnLastest .DescriptionText = "[最新日のみ本文を取り込む]ボタン" .BeginGroup = True .Style = msoButtonIconAndCaption .Caption = "最新日のみ本文を取り込む" .TooltipText = "最新日のみ本文を取り込む。" .FaceId = 220 .OnAction = "MyXlKyodoBttnMyLastest" End With ' With myCtrlBttnOk .DescriptionText = "[OK]ボタン" .BeginGroup = True .Style = msoButtonIconAndCaption .Caption = "OK" .TooltipText = "処理をを実行します。" .FaceId = 964 .OnAction = "MyXlKyodoBttnMyOk" End With ' With myCtrlBttnCancel .DescriptionText = "[キャンセル]ボタン" .BeginGroup = True .Style = msoButtonIconAndCaption .Caption = "キャンセル" & String(12, " ") .TooltipText = "処理を中止します。" .FaceId = 330 .OnAction = "MyXlKyodoBttnMyCancel" End With Rem *----*----* *----*----* *----*----* *----*----* ' x = -1: y = -1 myFaceId = myCmmdBar.Controls(1).FaceId Beep ' Do On Error Resume Next If x = -1 Then myCmmdBar.ShowPopup Else myCmmdBar.ShowPopup x, y End If On Error GoTo 0 DoEvents Select Case myCmmdBar.Controls(1).FaceId Case 964, 330 ' 実行/キャンセル Exit Do Case 220, 6963 ' [チェックボックス]オン・オフ x = myCmmdBar.Left y = myCmmdBar.Top myCmmdBar.Controls(1).FaceId = myFaceId Case Else x = -1: y = -1 End Select Loop End Sub ' MyXlKyodoPopUp *----*----* *----*----* *----*----* *----*----* Sub MyXlKyodoBttnMyOk(Optional myDummy As Boolean) Rem *----*----* *----*----* *----*----* *----*----* Rem コマンドボタン[OK]OnAction処理 Rem *----*----* *----*----* *----*----* *----*----* ' CommandBars("MyXlKyodo").Controls(1).FaceId = 964 End Sub ' MyXlKyodoBttnMyOk *----*----* *----*----* *----*----* *----*----* Sub MyXlKyodoBttnMyCancel(Optional myDummy As Boolean) Rem *----*----* *----*----* *----*----* *----*----* Rem コマンドボタン[キャンセル]OnAction処理 Rem *----*----* *----*----* *----*----* *----*----* ' CommandBars("MyXlKyodo").Controls(1).FaceId = 330 End Sub ' MyXlKyodoBttnMyCancel *----*----* *----*----* *----*----* *----*----* Sub MyXlKyodoBttnMyDetail(Optional myDummy As Boolean) Rem *----*----* *----*----* *----*----* *----*----* Rem [ニュースの本文も取り込む]ボタン処理 Rem *----*----* *----*----* *----*----* *----*----* ' With CommandBars("MyXlKyodo").Controls(2) If .FaceId = 6963 Then .FaceId = 220 .TooltipText = "ニュースの本文も取り込む。" Else .FaceId = 6963 .TooltipText = "ニュースの本文は取り込まない。" End If End With CommandBars("MyXlKyodo").Controls(1).FaceId = CommandBars("MyXlKyodo").Controls(3).FaceId End Sub ' MyXlKyodoBttnMyDetail *----*----* *----*----* *----*----* *----*----* Sub MyXlKyodoBttnMyLastest(Optional myDummy As Boolean) Rem *----*----* *----*----* *----*----* *----*----* Rem [ニュースの本文も取り込む]ボタン処理 Rem *----*----* *----*----* *----*----* *----*----* ' With CommandBars("MyXlKyodo").Controls(3) If .FaceId = 220 Then .FaceId = 6963 .TooltipText = "総て本文を取り込む。" Else .FaceId = 220 .TooltipText = "最新日のみ本文を取り込む。" End If End With CommandBars("MyXlKyodo").Controls(1).FaceId = CommandBars("MyXlKyodo").Controls(3).FaceId End Sub ' MyXlKyodoBttnMyLastest *----*----* *----*----* *----*----* *----*----*