Sub MyRssKanaloco() Rem *----*----* *----*----* *----*----* *----*----* Rem 神奈川新聞サイトRSS取り込み処理 Rem 作譜:Hitrock Camellia Shinopy Rem 言語:Excel VBA Rem 機能... Rem 指定したサイトのRSSページを取り込みする。 Rem 注記... Rem 1. MyRssKanalocoを起動して実行。 Rem 2. 初回実行前に「myFile」に取り込むRSSの保存先を指定すること。 Rem 履歴... Rem 第01版:2007/04/30:作成。 Rem *----*----* *----*----* *----*----* *----*----* Dim i As Long Dim j As Long Dim c As Long Dim myMax As Long Dim mySheetFirst As Long ' Dim myArray As Variant Dim mySite As String Dim myURL As Variant Dim myText As String Dim myStatusBar As String ' Dim myHTTP As Variant ' IXMLHTTPRequest Dim myStream As Variant ' Stream Dim myFile As String ' Dim myFileValue As Boolean Dim myXmlDoc As Variant Rem *----*----* *----*----* *----*----* *----*----* ' myFile = "C:\Documents and Settings\User\My Documents\MyRssKanaloco\MyRssKanaloco.xml" Call MyRssKanalocoMySite(mySite) ' myArray = Split(mySite, ",") myMax = UBound(myArray) + 1 Rem *----*----* *----*----* *----*----* *----*----* ' Application.CommandBars("Task Pane").Visible = False Range("A1").Select mySheetFirst = ActiveSheet.Index ' c = Worksheets.Count - ActiveSheet.Index + 1 If c < myMax Then c = myMax - c For i = 1 To c Worksheets.Add After:=Sheets(Worksheets.Count), Count:=1 Next ' i Sheets(mySheetFirst).Activate End If Rem *----*----* *----*----* *----*----* *----*----* ' Set myXmlDoc = CreateObject("MSXML2.DOMDocument") Set myHTTP = CreateObject("Microsoft.XMLHTTP") Set myStream = CreateObject("ADODB.Stream") ' Application.ScreenUpdating = False Rem *----*----* *----*----* *----*----* *----*----* ' MyRssKanalocoSubEntry: c = 0 j = 0 For Each myURL In myArray c = c + 1 myStatusBar = c * 100 \ myMax & "% " & c & "/" & myMax & "件 " Application.StatusBar = "MyRssKanaloco" & ":" & myStatusBar ' Columns("A:A").Select With Selection .ColumnWidth = 80 .VerticalAlignment = xlTop .WrapText = True End With Columns("B:B").Select With Selection .ColumnWidth = 100 .VerticalAlignment = xlTop .WrapText = True End With Rem *----*----* *----*----* ' Call myHTTP.Open("GET", myURL, False) On Error Resume Next myHTTP.Send ' If Err.Number <> 0 Then Range("A1").Value = Err.Number Range("B1").Value = Err.Description Else Const AdBinary = 1 ' Const AdTypeText = 2 Set myStream = CreateObject("ADODB.Stream") myStream.Type = AdBinary myStream.Open myStream.write (myHTTP.responseBody) myStream.Position = 0 myStream.Type = AdBinary Call myStream.SaveToFile(myFile, 2) ' 上書き myStream.Close ' myXmlDoc.Async = False myFileValue = myXmlDoc.Load(myFile) ' If myFileValue = True Then Call MyRssKanalocoMyXmlDoc(myXmlDoc, j, myFile) Else Range("A1").Value = "XMLファイルがありません!" Range("B1").Value = myURL End If End If On Error GoTo 0 Rem *----*----* *----*----* ' Range("B1").Select ActiveWindow.ScrollColumn = 1 ActiveWindow.Zoom = 75 On Error Resume Next ActiveSheet.Next.Select On Error GoTo 0 DoEvents Next ' myURL ' Call MyRssKanalocoUninetblog Sheets(mySheetFirst).Activate Rem *----*----* *----*----* *----*----* *----*----* ' MyRssKanalocoSubExit: Application.ScreenUpdating = True Kill myFile myText = "処理が終了しました。" Application.StatusBar = "MyRssKanaloco: " & myText & " " & Now() Application.Speech.Speak myText, False End Sub ' MyRssKanaloco *----*----* *----*----* *----*----* *----*----* Sub MyRssKanalocoMyXmlDoc(myXmlDoc As Variant, j As Long, myFile As String) Dim myTitle As Variant Dim myLink As Variant Dim myDescript As Variant ' Dim i As Long Dim myStatusBar As String Rem *----*----* *----*----* *----*----* *----*----* ' Set myTitle = myXmlDoc.selectNodes("//title") Set myLink = myXmlDoc.selectNodes("//link") Set myDescript = myXmlDoc.selectNodes("//description") Rem *----*----* *----*----* *----*----* *----*----* ' For i = 1 To myTitle.Length myStatusBar = Application.StatusBar myStatusBar = Left(myStatusBar, InStr(myStatusBar, "件 ") + 1) myStatusBar = myStatusBar & i & "/" & myTitle.Length & "行" Application.StatusBar = myStatusBar ' Select Case i Case 1 ActiveSheet.Hyperlinks.Add Anchor:=Cells(i, 1), Address:=myLink(i - 1).Text, TextToDisplay:=myTitle(i - 1).Text & " " & myDescript(i - 1).Text On Error Resume Next ActiveSheet.Name = Cells(i, 1).Text If Err.Number <> 0 Then j = j + 1 ActiveSheet.Name = Cells(i, 1).Text & " " & j End If Err.Clear On Error GoTo 0 Call MyRssKanalocoSheetName Cells(i, 1).Value = "○ " & Cells(i, 1).Value Case Else ActiveSheet.Hyperlinks.Add Anchor:=Cells(i, 1), Address:=myLink(i - 1).Text, TextToDisplay:=myTitle(i - 1).Text ' If Not (myDescript(i - 1) Is Nothing) Then ' Cells(i, 2).Value = Cells(i, 2).Value & " " & myDescript(i - 1).Text ' End If End Select DoEvents Next ' i End Sub ' MyRssKanalocoMyXmlDoc *----*----* *----*----* *----*----* *----*----* Sub MyRssKanalocoMySite(mySite As String) mySite = "http://www.pheedo.jp/f/kanaloco_localnews" ' ローカルニュース mySite = mySite & "," & "http://www.kanaloco.jp/casefiles/rss/" ' カナガワ事件簿 mySite = mySite & "," & "http://www.kanaloco.jp/sportsnews/rss" ' スポーツニュース mySite = mySite & "," & "http://www.kanaloco.jp/editorial/rss" ' 神奈川新聞の社説 mySite = mySite & "," & "http://www.kanaloco.jp/serial/rss" ' 神奈川新聞の連載 mySite = mySite & "," & "http://www.kanaloco.jp/lamp/rss" ' 神奈川新聞の照明灯 ' mySite = mySite & "," & "http://www.kanaloco.jp/dailybaystars/rss" ' デイリーベイスターズ mySite = mySite & "," & "http://www.kanaloco.jp/baystarsfever/rss/" ' ベイスターズフィーバー mySite = mySite & "," & "http://www.kanaloco.jp/jleague/rss/" ' カナロコJリーグ mySite = mySite & "," & "http://www.kanaloco.jp/idobata/rss/" ' 井戸端会議 mySite = mySite & "," & "http://www.kanaloco.jp/report/rss/" ' りぽーと mySite = mySite & "," & "http://www.kanaloco.jp/photo/rss/" ' カナロコ写真帳 ' mySite = mySite & "," & "http://www.kanaloco.jp/uninetblog/rss/" ' ゆにねっと mySite = mySite & "," & "http://www.kanaloco.jp/uninetblog/information_rss/" ' ゆにねっと インフォメーション mySite = mySite & "," & "http://www.kanaloco.jp/uninetblog/ayu_view_rss/" ' ゆにねっと あゆの視線 mySite = mySite & "," & "http://www.kanaloco.jp/uninetblog/with_ayu_rss/" ' ゆにねっと あゆと歩こう ' mySite = mySite & "," & "http://www.kanaloco.jp/lmcolumn/rss/" ' コラムで読むライブ mySite = mySite & "," & "http://www.kanaloco.jp/lmpickup/rss/" ' 今月のPickup! ' mySite = mySite & "," & "http://www.kanaloco.jp/bookbar/rss/" ' BOOK BAR mySite = mySite & "," & "http://www.kanaloco.jp/stationery/rss/" ' 至福の文具 mySite = mySite & "," & "http://www.kanaloco.jp/gardenstyle/rss/" ' 私のガーデンスタイル ' mySite = mySite & "," & "http://www.kanaloco.jp/officeblog/rss/" ' カナロコ編集部ブログ mySite = mySite & "," & "http://www.kanaloco.jp/information/rss/" ' 神奈川新聞社からのお知らせ End Sub ' MyRssKanalocoMySite *----*----* *----*----* *----*----* *----*----* Sub MyRssKanalocoSheetName(Optional myDummy As Boolean) Dim myName As String ' myName = ActiveSheet.Name myName = Replace(myName, " localnews", "") myName = Replace(myName, " casefiles", "") myName = Replace(myName, " sportsnews", "") myName = Replace(myName, " editorial", "") myName = Replace(myName, " serial", "") myName = Replace(myName, " lamp", "") ' myName = Replace(myName, " dailybaystars", "") myName = Replace(myName, " baystarsfever", "") myName = Replace(myName, " jleague", "") ' myName = Replace(myName, " lmcolumn", "") myName = Replace(myName, " lmpickup", "") ' myName = Replace(myName, " bookbar", "") myName = Replace(myName, " stationery", "") myName = Replace(myName, " gardenstyle", "") ' myName = Replace(myName, " officeblog", "") myName = Replace(myName, " information", "") myName = Replace(myName, "神奈川新聞の", "") myName = Replace(myName, "神奈川新聞社からの", "") ' ActiveSheet.Name = myName End Sub ' MyRssKanalocoSheetName *----*----* *----*----* *----*----* *----*----* Sub MyRssKanalocoUninetblog(Optional myDummy As Boolean) On Error Resume Next ' Sheets("ゆにねっと uninetblog").Activate ActiveSheet.Name = Replace(ActiveSheet.Name, " uninetblog", "") ' Sheets("ゆにねっと uninetblog 1").Activate ActiveSheet.Name = Replace(ActiveSheet.Name, " uninetblog 1", " インフォメーション") ' Sheets("ゆにねっと uninetblog 2").Activate ActiveSheet.Name = Replace(ActiveSheet.Name, " uninetblog 2", " あゆの視線") ' Sheets("ゆにねっと uninetblog 3").Activate ActiveSheet.Name = Replace(ActiveSheet.Name, " uninetblog 3", " あゆと歩こう") ' On Error GoTo 0 End Sub ' MyRssKanalocoUninetblog *----*----* *----*----* *----*----* *----*----*