Sub MyXlChibaNp() Rem *----*----* *----*----* *----*----* *----*----* Rem 千葉日報サイト 取り込み処理 Rem 作譜:Hitrock Camellia Shinopy Rem 言語:Excel VBA Rem 機能... Rem 千葉日報サイトの記事を取り込みし、Excelシートに書き込みする。 Rem 注記... Rem 1. MyXlChibaNpを起動して使用。 Rem 2. 文字列変数「myIEblank」の値指定は、IEのバージョンによって変更要! Rem 3. なぜか、IEの「Visible = False」が機能しないので、 Rem ExcelのWindowStateの操作で対処。 Rem 履歴... Rem 第1版:2007/03/04:作成。 Rem 第2版:2007/05/06:「myIEblank」の値指定を修正。WindowState操作を追加。 Rem 第3版:2007/06/18:プロシージャの変更。 Rem 第4版:2007/11/16:再作成。 Rem 第5版: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 myStream As Variant ' Stream Dim mySource As String ' Dim myTags As Variant ' DispHTMLElementCollection Dim myTag As Variant ' HTMLHeaderElement Dim mySubTags As Variant ' DispHTMLElementCollection Dim mySubTag As Variant ' HTMLHeaderElement Dim mySubTag1 As Variant ' HTMLHeaderElement Dim mySubTag2 As Variant ' HTMLHeaderElement Dim mySubTag3 As Variant ' HTMLHeaderElement ' Dim myTitle As String Dim myURL As String Dim mySubURL As String Dim myHref As String Dim myinnerText As String Dim myLink As Hyperlink ' Dim myAns As Long Dim myMax As Long Dim mySheetName As String Dim myRow As Variant Dim myStatusBar As String Dim i As Long Dim j As Long Dim r As Long Dim c As Long Dim v As Variant Dim myString As String Dim myIEblank As String Dim mySheetArray As Variant Dim myLinks As String Dim myLinkArray As Variant Dim myCounts As String Dim myCountArray As Variant Rem *----*----* *----*----* *----*----* *----*----* ' myTitle = "MyXlChibaNp" myIEblank = "about:blank" ' IEのバージョンによって変更要! ' myIEblank = "about:" ' IEのバージョンによって変更要! myURL = "http://www.chibanippo.co.jp/" myString = "千葉日報サイトマップ,県内ニューストップ,国内外ニューストップ,フォトニュース," myString = myString & "スポーツトップ,忙人寸語,社説" mySheetArray = Split(myString, ",") ' On Error Resume Next CommandBars(myTitle).Delete On Error GoTo 0 ' Call MyXlChibaNpCmmdBar(myTitle) myLinks = myURL & "sitemap/" Rem *----*----* *----*----* *----*----* *----*----* ' Select Case CommandBars(myTitle).Controls(1).FaceId Case 964 myAns = vbOK Case 330 myAns = vbCancel End Select ' If myAns = vbCancel Then Exit Sub Rem *----*----* *----*----* *----*----* *----*----* ' Application.CommandBars("Task Pane").Visible = False ActiveSheet.Range("A1").Select For Each v In mySheetArray ActiveSheet.Name = v On Error Resume Next ActiveSheet.Next.Select If Err.Number <> 0 Then If v = mySheetArray(UBound(mySheetArray)) Then Exit For Worksheets.Add After:=Sheets(Worksheets.Count), Count:=1 ActiveSheet.Name = v.Text End If On Error GoTo 0 DoEvents Next ' v Sheets(mySheetArray(0)).Activate Rem *----*----* *----*----* *----*----* *----*----* ' Rem サイトマップの取り込み処理 myStatusBar = "□千葉日報サイト 取り込み開始!" Application.StatusBar = myTitle & ": " & myStatusBar Set myHTTP = CreateObject("MSXML2.XMLHTTP") ' ("Microsoft.XMLHTTP") Set myStream = CreateObject("ADODB.Stream") Set myIE = CreateObject("InternetExplorer.Application") Call MyXlChibaNpHttp(myLinks, myHTTP, myIE, myDoc, myStream, mySource) ' Application.WindowState = xlMinimized Application.WindowState = xlNormal ' mySource = Replace(mySource, "<h2 ", "<a ") mySource = Replace(mySource, "</h2>", "</a>") mySource = Replace(mySource, "<h3 ", "<a ") mySource = Replace(mySource, "</h3>", "</a>") myDoc.write mySource Rem *----*----* *----*----* *----*----* *----*----* ' Set myTags = myDoc.getElementsByTagName("div") r = 1 c = 0 i = 0 For Each myTag In myTags i = i + 1 myStatusBar = "□千葉日報サイト 取り込み中:" myStatusBar = myStatusBar & " [" & ActiveSheet.Name & "] " myStatusBar = myStatusBar & i & "/" & myTags.Length & " " myStatusBar = myStatusBar & myTag.ID Application.StatusBar = myTitle & ": " & myStatusBar ' Select Case myTag.ID Case "Ymd" Range("A1").Select Range("A1").Value = "千葉日報" & vbLf & myTag.innertext & vbLf With Selection .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter .RowHeight = 70 End With r = r + 1 Case "wearther" myinnerText = myTag.innertext & vbLf ' myinnerText = "" ' Set mySubTags = myTag.getElementsByTagName("li") ' For Each mySubTag In mySubTags ' myinnerText = myinnerText & mySubTag.innertext & vbLf ' Next ' mySubTag ' myinnerText = Replace(myinnerText, "度 " & vbLf, "度" & vbLf & vbLf) Range("A16").Value = myinnerText ' *----*----* *----*----* *----*----* *----*----* Case "ChangeSize" Set mySubTags = myTag.getElementsByTagName("a") For Each mySubTag In mySubTags If Len(mySubTag.Title) > 0 Then r = 2 c = c + 1 Cells(r, c).Value = mySubTag.innertext Else myHref = Replace(mySubTag.href, myIEblank & "../", myURL) myinnerText = mySubTag.innertext ActiveSheet.Hyperlinks.Add Anchor:=Cells(r, c), Address:=myHref, TextToDisplay:=myinnerText ' For Each v In mySheetArray If myinnerText = v Then myString = myLinks myString = myString & "," & myHref myLinks = myString Exit For End If DoEvents Next ' v End If r = r + 1 Next ' mySubTag ' *----*----* *----*----* *----*----* *----*----* End Select ' DoEvents Next ' myTagDiv Columns("A:A").ColumnWidth = 1# Rows("1:100").RowHeight = 1# Columns("A:Z").EntireColumn.AutoFit Rows("1:100").EntireRow.AutoFit Columns("A:A").WrapText = True ActiveWindow.Zoom = 75 Rem *----*----* *----*----* *----*----* *----*----* ' Rem シートごとのの取り込み処理 Application.ScreenUpdating = False myLinkArray = Split(myLinks, ",") myCounts = "0" For i = 1 To UBound(myLinkArray) Sheets(mySheetArray(i)).Activate myStatusBar = "□千葉日報サイト 取り込み中:" myStatusBar = myStatusBar & " [" & ActiveSheet.Name & "] " myStatusBar = myStatusBar & i & "/" & UBound(myLinkArray) & "頁 " Application.StatusBar = myTitle & ": " & myStatusBar ' r = 1 ActiveSheet.Hyperlinks.Add Anchor:=Cells(r, 1), Address:=myLinkArray(i), TextToDisplay:=mySheetArray(i) myString = myLinkArray(i) Call MyXlChibaNpHttp(myString, myHTTP, myIE, myDoc, myStream, mySource) ' Select Case ActiveSheet.Name Case "忙人寸語" myString = "<h2 title=" & Chr(34) & "忙人寸語" & Chr(34) & ">" mySource = Mid(mySource, InStr(mySource, myString)) Case "フォトニュース" myString = "<h2>フォトニュース</h2>" mySource = Mid(mySource, InStr(mySource, myString)) Case Else mySource = Replace(mySource, "<h2 ", "<a ") mySource = Replace(mySource, "</h2>", "</a>") mySource = Replace(mySource, "<div class=" & Chr(34), "<div id=" & Chr(34)) End Select mySource = Replace(mySource, "title=" & Chr(34) & "一覧" & Chr(34), "") myDoc.write mySource ' Select Case ActiveSheet.Name Case "忙人寸語" Set mySubTag1 = myDoc.getElementsByTagName("p") Set mySubTag2 = myDoc.getElementsByTagName("ul") r = 3 For j = 1 To mySubTag1.Length myStatusBar = "□千葉日報サイト 取り込み中:" myStatusBar = myStatusBar & " [" & ActiveSheet.Name & "] " myStatusBar = myStatusBar & i & "/" & UBound(myLinkArray) & "頁 " myStatusBar = myStatusBar & j & "/" & mySubTag1.Length & "件 " Application.StatusBar = myTitle & ": " & myStatusBar ' If mySubTag1(j - 1).className = "BoujinDays" Then Cells(r, 1) = mySubTag1(j - 1).innertext Cells(r, 2) = mySubTag2(j - 1).innertext & vbLf r = r + 1 End If DoEvents Next ' j Columns("B:B").ColumnWidth = 1# Rows("3:100").RowHeight = 1# Columns("A:A").ColumnWidth = 30# Columns("B:B").ColumnWidth = 70# Columns("A:B").WrapText = True Rows("3:100").EntireRow.AutoFit ActiveWindow.Zoom = 75 ' *----*----* *----*----* *----*----* *----*----* Case "フォトニュース" Set myTags = myDoc.getElementsByTagName("div") r = 3 j = 0 For Each myTag In myTags j = j + 1 myStatusBar = "□千葉日報サイト 取り込み中:" myStatusBar = myStatusBar & " [" & ActiveSheet.Name & "] " myStatusBar = myStatusBar & i & "/" & UBound(myLinkArray) & "頁 " myStatusBar = myStatusBar & j & "/" & myTags.Length & "件 " Application.StatusBar = myTitle & ": " & myStatusBar ' Select Case myTag.className Case "PhotoArticle" myHref = Replace(myTag.Children(0).href, myIEblank, myURL) myinnerText = myTag.Children(1).innertext & vbLf myinnerText = myinnerText & myTag.Children(2).innertext & vbLf ActiveSheet.Hyperlinks.Add Anchor:=Cells(r, 1), Address:=myHref, TextToDisplay:=myinnerText r = r + 1 End Select DoEvents Next ' myTag Columns("B:B").ColumnWidth = 1# Rows("3:100").RowHeight = 1# Columns("A:B").ColumnWidth = 70# Rows("3:100").EntireRow.AutoFit ' *----*----* *----*----* *----*----* *----*----* Case Else Set myTags = myDoc.getElementsByTagName("div") j = 0 For Each myTag In myTags j = j + 1 myStatusBar = "□千葉日報サイト 取り込み中:" myStatusBar = myStatusBar & " [" & ActiveSheet.Name & "] " myStatusBar = myStatusBar & i & "/" & UBound(myLinkArray) & "頁 " myStatusBar = myStatusBar & j & "/" & myTags.Length & "件 " Application.StatusBar = myTitle & ": " & myStatusBar ' Select Case myTag.ID Case "news" Set mySubTags = myTag.getElementsByTagName("a") For Each mySubTag In mySubTags If Len(mySubTag.Title) > 0 Then c = 1 r = r + 1 If mySubTag.innertext <> Cells(1, 1).Value Then Cells(r, c).Value = mySubTag.innertext r = r + 1 Else Rem 1行目の見出しと同じものは表示しない。 Cells(r, c).Value = "" r = r + 1 End If Else If mySubTag.innertext <> "全文を読む" Then myHref = Replace(mySubTag.href, myIEblank, myURL) myinnerText = mySubTag.innertext ActiveSheet.Hyperlinks.Add Anchor:=Cells(r, c), Address:=myHref, TextToDisplay:=myinnerText r = r + 1 End If End If DoEvents Next ' mySubTag Columns("A:Z").EntireColumn.AutoFit ' *----*----* *----*----* *----*----* *----*----* End Select DoEvents Next ' myTag End Select myCounts = myCounts & "," & CStr(r - 1) ' DoEvents Next ' i Rem *----*----* *----*----* *----*----* *----*----* myCountArray = Split(myCounts, ",") myMax = 0 For i = 1 To UBound(myCountArray) myMax = myMax + CLng(myCountArray(i)) Next ' i myCountArray(0) = CStr(myMax) Sheets(mySheetArray(0)).Activate ' If CommandBars(myTitle).Controls(2).FaceId <> 220 Then GoTo MyXlChibaNpSubExit Rem *----*----* *----*----* *----*----* *----*----* ' c = 0 For i = 1 To UBound(mySheetArray) Sheets(mySheetArray(i)).Activate ' c = c + 1 For r = 2 To myCountArray(i) c = c + 1 myStatusBar = "□千葉日報サイト 本文 取り込み中 " myStatusBar = myStatusBar & c * 100 \ myMax & "% " myStatusBar = myStatusBar & " [" & ActiveSheet.Name & "] " myStatusBar = myStatusBar & i & "/" & UBound(myLinkArray) & "頁 " myStatusBar = myStatusBar & r & "/" & myCountArray(i) & "行 " Application.StatusBar = myTitle & ": " & myStatusBar ' Select Case ActiveSheet.Name Case "千葉日報サイトマップ" c = c + myCountArray(i) - 2 Exit For Case "忙人寸語" c = c + myCountArray(i) - 2 Exit For Case Else Select Case Cells(r, "A").Value Case "一覧" Rem Case Else If Cells(r, "A").Hyperlinks.Count > 0 Then myString = Cells(r, "A").Hyperlinks(1).Address Call MyXlChibaNpHttp(myString, myHTTP, myIE, myDoc, myStream, mySource) ' mySource = Mid(mySource, InStr(mySource, "ChangeSize" & Chr(34) & ">") + 12) myString = "指定された記事はございません" If InStr(mySource, myString) > 0 Then mySource = Replace(mySource, myString, "<p>" & myString & "</p>") mySource = Left(mySource, InStrRev(mySource, "<hr") - 1) Else mySource = Left(mySource, InStrRev(mySource, "<hr") - 1) mySource = Left(mySource, InStrRev(mySource, "<hr") - 1) End If ' mySource = Replace(mySource, "<h1 ", "<p ") mySource = Replace(mySource, "</h1>", "</p>") mySource = Replace(mySource, "<h2", "<p") mySource = Replace(mySource, "</h2>", "</p>") mySource = Replace(mySource, "<h3", "<p") mySource = Replace(mySource, "</h3>", "</p>") myDoc.write mySource ' Set myTags = myDoc.getElementsByTagName("p") myString = "" For Each myTag In myTags myString = myString & myTag.innertext & vbLf Next ' myTag Cells(r, "B").Value = myString End If End Select End Select ' DoEvents Next ' r Columns("B:B").ColumnWidth = 1# Rows("3:100").RowHeight = 1# Columns("A:A").ColumnWidth = 30# Columns("B:B").ColumnWidth = 70# Columns("A:B").WrapText = True Rows("3:100").EntireRow.AutoFit ActiveWindow.Zoom = 75 ' DoEvents Next ' i Rem *----*----* *----*----* *----*----* *----*----* ' MyXlChibaNpSubExit: On Error Resume Next myIE.Quit Application.ScreenUpdating = True CommandBars(myTitle).Delete On Error GoTo 0 Sheets(mySheetArray(0)).Activate ' myStatusBar = "処理が終了しました。" Application.StatusBar = "MyXlChibaNp: " & myStatusBar Application.Speech.Speak myStatusBar, False ' Set myHTTP = Nothing Set myIE = Nothing Set myDoc = Nothing Set myStream = Nothing End Sub ' MyXlChibaNp *----*----* *----*----* *----*----* *----*----* Sub MyXlChibaNpHttp(myURL As String, myHTTP As Variant, myIE As Variant, myDoc As Variant, myStream As Variant, mySource As String) Dim myResponseBody As Variant ' Call myHTTP.Open("GET", myURL, False) myHTTP.Send myResponseBody = myHTTP.responseBody ' Const AdBinary = 1 Const AdTypeText = 2 myStream.Type = AdBinary myStream.Open myStream.write (myResponseBody) myStream.Position = 0 myStream.Type = AdTypeText myStream.Charset = "EUC-JP" ' "iso-2022-jp" mySource = myStream.ReadText() ' myFile = "C:\Documents and Settings\User\My Documents\Zzz\Zzz.html" ' Call myStream.SaveToFile(myFile, 2) myStream.Close ' With myIE .Navigate "about:blank" .Visible = False ' True Do While .Busy DoEvents Loop DoEvents Set myDoc = .Document End With ' mySource = Replace(mySource, "<link ", "<!-- link ") mySource = Replace(mySource, "<script ", "<!-- script ") mySource = Replace(mySource, " src=", " Zzzsrc=") mySource = Replace(mySource, " SRC=", " Zzzsrc=") End Sub ' MyXlChibaNpHttp *----*----* *----*----* *----*----* *----*----* Sub MyXlChibaNpCmmdBar(myTitle As String) Dim myCmmdBar As CommandBar Dim myCtrlBttnIcon 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 myOnAction As String 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 myCtrlBttnIcon = 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 & vbCrLf ' With myCtrlBttnIcon .DescriptionText = "千葉日報サイト取り込み処理ポップアップメニュー" .Style = msoButtonIconAndWrapCaption .Caption = myMsg & "処理を実行しますか?" .TooltipText = "処理を実行しますか?" .FaceId = 1089 .Parameter = "../sitemap/" myFaceId = .FaceId myOnAction = myTitle & "BttnMyValue" & " " myOnAction = myOnAction & Chr(&H22) & myTitle & ChrW(&H22) & ", " & "487" .OnAction = "'" & myOnAction & "'" End With ' With myCtrlBttnDeTail .DescriptionText = "千葉日報サイト取り込み処理:[本文も取り込みする]ボタン" .BeginGroup = True .Style = msoButtonIconAndCaption .Caption = "本文も取り込みする" .TooltipText = "[本文]は取り込みしない。" .FaceId = 6963 .OnAction = "'" & myTitle & "BttnMyDetail" & " " & Chr(&H22) & myTitle & ChrW(&H22) & ", " & .Index & "'" End With ' With myCtrlBttnOk .DescriptionText = "千葉日報サイト取り込み処理:[実行]ボタン" .BeginGroup = True .Style = msoButtonIconAndCaption .Caption = "実行" .TooltipText = "処理をを実行します。" .FaceId = 964 myOnAction = myTitle & "BttnMyValue" & " " myOnAction = myOnAction & Chr(&H22) & myTitle & ChrW(&H22) & ", " & .FaceId .OnAction = "'" & myOnAction & "'" End With ' With myCtrlBttnCancel .DescriptionText = "千葉日報サイト取り込み処理:[キャンセル]ボタン" .Style = msoButtonIconAndCaption .Caption = "キャンセル" & Space(24) .TooltipText = "処理を中止します。" .FaceId = 330 myOnAction = myTitle & "BttnMyValue" & " " myOnAction = myOnAction & Chr(&H22) & myTitle & ChrW(&H22) & ", " & .FaceId .OnAction = "'" & myOnAction & "'" 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, 487 ' [チェックボックス]オン・オフ/[選択して下さい。] x = myCmmdBar.Left y = myCmmdBar.Top myCmmdBar.Controls(1).FaceId = myFaceId Case Else x = -1: y = -1 End Select Loop End Sub ' MyXlChibaNpCmmdBar *----*----* *----*----* *----*----* *----*----* Sub MyXlChibaNpBttnMyValue(myTitle As String, myValue As Long) Rem *----*----* *----*----* *----*----* *----*----* Rem コマンドボタンOnAction処理 Rem *----*----* *----*----* *----*----* *----*----* ' CommandBars(myTitle).Controls(1).FaceId = myValue End Sub ' MyXlChibaNpBttnMyValue *----*----* *----*----* *----*----* *----*----* Sub MyXlChibaNpBttnMyDetail(myTitle As String, myIndex As Long) Rem *----*----* *----*----* *----*----* *----*----* Rem [ニュースの本文も取り込む]ボタン処理 Rem *----*----* *----*----* *----*----* *----*----* ' With CommandBars(myTitle).Controls(myIndex) If .FaceId = 6963 Then .FaceId = 220 .TooltipText = "[本文]も取り込みする。" Else .FaceId = 6963 .TooltipText = "[本文]は取り込みしない。" End If End With CommandBars(myTitle).Controls(1).FaceId = CommandBars(myTitle).Controls(myIndex).FaceId End Sub ' MyXlChibaNpBttnMyDetail *----*----* *----*----* *----*----* *----*----*