Sub MyRssMainichi()
Rem *----*----* *----*----* *----*----* *----*----*
Rem 毎日新聞RSS取り込み処理
Rem 作譜：Hitrock Camellia Shinopy
Rem 言語：Excel VBA
Rem 機能...
Rem 指定したサイトのRSSを取り込みする。
Rem 注記...
Rem 1. MyRssMainichiを起動して実行。
Rem 2. 初回実行前に「myFile」に取り込むRSSデータの保存先を指定すること。
Rem 履歴...
Rem 第01版：2008/04/15：作成。
Rem *----*----* *----*----* *----*----* *----*----*
Dim i As Long
Dim c As Long
Dim myMax As Long
Dim mySheetFirst As Long
'
Dim mySite As String
Dim mySiteArray As Variant
Dim mySheet As String
Dim mySheetArray As Variant
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\Zzz\MyRssMainichi.xml"
Call MyRssMainichiMySite(mySite)
mySiteArray = Split(mySite, ",")
Call MyRssMainichiMySheet(mySheet)
mySheetArray = Split(mySheet, ",")
myMax = UBound(mySiteArray) + 1
Rem *----*----* *----*----* *----*----* *----*----*
'
myStatusBar = "毎日新聞 RSS取り込み処理 開始！"
Application.StatusBar = "MyRssMainichi: " & myStatusBar
Application.CommandBars("Task Pane").Visible = False
Application.ScreenUpdating = 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")
Rem *----*----* *----*----* *----*----* *----*----*
'
MyRssMainichiSubEntry:
c = 0
For Each myURL In mySiteArray
c = c + 1
myStatusBar = c * 100 \ myMax & "% " & c & "/" & myMax & "頁 "
Application.StatusBar = "MyRssMainichi" & "：" & myStatusBar
'
Columns("A:A").Select
With Selection
.ColumnWidth = 80
.VerticalAlignment = xlTop
.WrapText = True
End With
Columns("B:B").Select
With Selection
.ColumnWidth = 70
.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 MyRssMainichiMyXmlDoc(myXmlDoc, myFile, mySheetArray)
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 = 80
On Error Resume Next
ActiveSheet.Next.Select
On Error GoTo 0
DoEvents
Next ' myURL
'
Sheets(mySheetFirst).Activate
Rem *----*----* *----*----* *----*----* *----*----*
'
MyRssMainichiSubExit:
Application.ScreenUpdating = True
On Error Resume Next
Kill myFile
On Error GoTo 0
myText = "処理が終了しました。"
Application.StatusBar = "MyRssMainichi: " & myText & " " & Now()
Application.Speech.Speak myText, False
End Sub ' MyRssMainichi *----*----* *----*----* *----*----* *----*----*
Sub MyRssMainichiMyXmlDoc(myXmlDoc As Variant, myFile As String, mySheetArray As Variant)
Dim myTitle As Variant
Dim myLink As Variant
Dim myDescript As Variant
'
Dim i As Long
Dim myText As String
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
Cells(i, 1).RowHeight = 30
Call MyRssMainichiSheetName(mySheetArray)
Case Else
ActiveSheet.Hyperlinks.Add Anchor:=Cells(i, 1), Address:=myLink(i).Text, TextToDisplay:=myTitle(i).Text
If Not (myDescript(i - 1) Is Nothing) Then
myText = myDescript(i - 1).Text
If InStr(myText, "<br ") > 0 Then
myText = Left(myText, InStr(myText, "<br ") - 1)
End If
If InStr(myText, "<table") > 0 Then
myText = Left(myText, InStr(myText, "<table") - 1)
End If
Cells(i, 2).Value = myText
End If
End Select
If i > 1 Then
If Len(Cells(i, 2).Value) = 0 Then
Cells(i, 1).RowHeight = 22
End If
End If
DoEvents
Next ' i
End Sub ' MyRssMainichiMyXmlDoc *----*----* *----*----* *----*----* *----*----*
Sub MyRssMainichiMySite(mySite As String)
mySite = "http://mainichi.pheedo.jp/f/mainichijp_flash"
mySite = mySite & "," & "http://mainichi.jp/rss/etc/sports.rss"
mySite = mySite & "," & "http://mainichi.jp/rss/etc/enta.rss"
mySite = mySite & "," & "http://mainichi.jp/rss/etc/mantan.rss"
mySite = mySite & "," & "http://mainichi.pheedo.jp/f/mainichijp_electronics"
mySite = mySite & "," & "http://mainichi.jp/rss/etc/weekly.rss"
'
mySite = mySite & "," & "http://mdn.mainichi.jp/rss/etc/national.rdf"
mySite = mySite & "," & "http://mdn.mainichi.jp/rss/etc/waiwai.rdf"
mySite = mySite & "," & "http://mdn.mainichi.jp/rss/etc/business.rdf"
mySite = mySite & "," & "http://mdn.mainichi.jp/rss/etc/entertainment.rdf"
mySite = mySite & "," & "http://mdn.mainichi.jp/rss/etc/features.rdf"
mySite = mySite & "," & "http://mdn.mainichi.jp/rss/etc/international.rdf"
mySite = mySite & "," & "http://mdn.mainichi.jp/rss/etc/sports.rdf"
mySite = mySite & "," & "http://mdn.mainichi.jp/rss/etc/travel.rdf"
End Sub ' MyRssMainichiMySite *----*----* *----*----* *----*----* *----*----*
Sub MyRssMainichiMySheet(mySheet As String)
mySheet = "ニュース速報(総合) - 毎日ｊｐ(毎日新聞)"
mySheet = mySheet & "," & "スポーツ - 毎日ｊｐ(毎日新聞)"
mySheet = mySheet & "," & "エンターテインメント（芸能、映画、音楽）- 毎日ｊｐ(毎日新聞)"
mySheet = mySheet & "," & "アニメ・マンガ・ゲーム（まんたんウェブ) - 毎日ｊｐ(毎日新聞)"
mySheet = mySheet & "," & "ＩＴ・家電 - 毎日ｊｐ(毎日新聞)"
mySheet = mySheet & "," & "英語を学ぶ（MAINICHI WEEKLY） - 毎日ｊｐ(毎日新聞)"
'
mySheet = mySheet & "," & "Japan National News"
mySheet = mySheet & "," & "WaiWai"
mySheet = mySheet & "," & "Japan Business News"
mySheet = mySheet & "," & "Japan Entertainment News"
mySheet = mySheet & "," & "Mainichi Features"
mySheet = mySheet & "," & "Mainichi International News"
mySheet = mySheet & "," & "Japan Sports News"
mySheet = mySheet & "," & "Mainichi Travel Features"
End Sub ' MyRssMainichiMySheet *----*----* *----*----* *----*----* *----*----*
Sub MyRssMainichiSheetName(mySheetArray As Variant)
Dim myName As String
Dim mySheet As Variant
'
myName = Cells(1, 1).Text
'
For Each mySheet In mySheetArray
Select Case True
Case InStr(myName, mySheet) > 0
myName = mySheet
myName = Replace(myName, "- 毎日ｊｐ(毎日新聞)", " ")
Exit For
End Select
Next ' mySheet
'
ActiveSheet.Name = myName
End Sub ' MyRssMainichiSheetName *----*----* *----*----* *----*----* *----*----*
