Sub MyRssIza()
Rem *----*----* *----*----* *----*----* *----*----*
Rem イザ！RSS取り込み処理
Rem 作譜：Hitrock Camellia Shinopy
Rem 言語：Excel VBA
Rem 機能...
Rem 指定したサイトのRSSを取り込みする。
Rem 注記...
Rem 1. MyRssIzaを起動して実行。
Rem 2. 初回実行前に「myFile」に取り込むRSSデータの保存先を指定すること。
Rem 履歴...
Rem 第01版：2008/03/23：作成。
Rem 第02版：2008/04/12：シート名設定を変更。
Rem 第03版：2008/04/27：[詳細RSSも取り込む]選択ポップアップメニューを追加。
Rem 第04版：2008/08/23：FaceIdの指定を変更。「459」=>「964」（Excel2007に対応）。
Rem *----*----* *----*----* *----*----* *----*----*
Dim myTitle As String
Dim myAns As Long
Dim myFlag As Boolean
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 *----*----* *----*----* *----*----* *----*----*
'
myTitle = "MyRssIza"
myFile = "C:\Documents and Settings\User\My Documents\Zzz\MyRssIza.xml"
Call MyRssIzaPopUp(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
myFlag = True
Else
myFlag = False
End If
'
If myAns = vbCancel Then GoTo MyRssIzaSubExit
'
Call MyRssIzaMySite(mySite, myFlag)
mySiteArray = Split(mySite, ",")
Call MyRssIzaMySheet(mySheet)
mySheetArray = Split(mySheet, ",")
'
mySiteArray = Split(mySite, ",")
myMax = UBound(mySiteArray) + 1
Rem *----*----* *----*----* *----*----* *----*----*
'
myStatusBar = "イザ！RSS取り込み処理 開始！"
Application.StatusBar = "MyRssIza: " & 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 *----*----* *----*----* *----*----* *----*----*
'
MyRssIzaSubEntry:
c = 0
For Each myURL In mySiteArray
c = c + 1
myStatusBar = c * 100 \ myMax & "% " & c & "/" & myMax & "頁 "
Application.StatusBar = "MyRssIza" & "：" & myStatusBar
'
Columns("A:A").Select
With Selection
.ColumnWidth = 70
' .RowHeight = 19
.VerticalAlignment = xlTop
.WrapText = True
End With
Columns("B:B").Select
With Selection
.ColumnWidth = 50
.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 MyRssIzaMyXmlDoc(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 *----*----* *----*----* *----*----* *----*----*
'
MyRssIzaSubExit:
Application.ScreenUpdating = True
On Error Resume Next
Kill myFile
On Error GoTo 0
myText = "処理が終了しました。"
Application.StatusBar = "MyRssIza: " & myText & " " & Now()
Application.Speech.Speak myText, False
End Sub ' MyRssIza *----*----* *----*----* *----*----* *----*----*
Sub MyRssIzaMyXmlDoc(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 MyRssIzaSheetName(mySheetArray)
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
' myText = Cells(i, 2).Value
' myText = Replace(myText, "BR", "")
' Cells(i, 2).Value = myText
End If
End Select
DoEvents
Next ' i
End Sub ' MyRssIzaMyXmlDoc *----*----* *----*----* *----*----* *----*----*
Sub MyRssIzaMySite(mySite As String, myFlag As Boolean)
If myFlag = False Then
mySite = "http://www.iza.ne.jp/top/NwEntTopRSS.rdf"
mySite = mySite & "," & "http://www.iza.ne.jp/voice/kisha-blog/PplBgEntKishaRSS.rdf"
mySite = mySite & "," & "http://www.iza.ne.jp/voice/specialist-blog/PplBgEntSpclstRSS.rdf"
mySite = mySite & "," & "http://www.iza.ne.jp/voice/user-blog/PplBgEntUserRSS.rdf"
'
mySite = mySite & "," & "http://www.iza.ne.jp/bookmark/list/total/new/NewBkmkRSS.rdf"
'
mySite = mySite & "," & "http://www.iza.ne.jp/izaword/KwRSS.rdf"
'
mySite = mySite & "," & "http://www.iza.ne.jp/news/event/NwCateRSS.rdf"
mySite = mySite & "," & "http://www.iza.ne.jp/news/sports/NwCateRSS.rdf"
mySite = mySite & "," & "http://www.iza.ne.jp/news/entertainment/NwCateRSS.rdf"
mySite = mySite & "," & "http://www.iza.ne.jp/news/natnews/NwCateRSS.rdf"
mySite = mySite & "," & "http://www.iza.ne.jp/news/column/NwCateRSS.rdf"
mySite = mySite & "," & "http://www.iza.ne.jp/news/world/NwCateRSS.rdf"
mySite = mySite & "," & "http://www.iza.ne.jp/news/economy/NwCateRSS.rdf"
mySite = mySite & "," & "http://www.iza.ne.jp/news/business/NwCateRSS.rdf"
mySite = mySite & "," & "http://www.iza.ne.jp/news/it/NwCateRSS.rdf"
mySite = mySite & "," & "http://www.iza.ne.jp/news/politics/NwCateRSS.rdf"
mySite = mySite & "," & "http://www.iza.ne.jp/news/books/NwCateRSS.rdf"
mySite = mySite & "," & "http://www.iza.ne.jp/news/living/NwCateRSS.rdf"
Exit Sub
End If
'
mySite = "http://www.iza.ne.jp/top/NwEntTopRSS.rdf"
mySite = mySite & "," & "http://www.iza.ne.jp/voice/kisha-blog/PplBgEntKishaRSS.rdf"
mySite = mySite & "," & "http://www.iza.ne.jp/voice/specialist-blog/PplBgEntSpclstRSS.rdf"
mySite = mySite & "," & "http://www.iza.ne.jp/voice/user-blog/PplBgEntUserRSS.rdf"
'
mySite = mySite & "," & "http://www.iza.ne.jp/bookmark/list/total/new/NewBkmkRSS.rdf"
'
mySite = mySite & "," & "http://www.iza.ne.jp/izaword/KwRSS.rdf"
'
mySite = mySite & "," & "http://www.iza.ne.jp/news/event/NwCateRSS.rdf"
mySite = mySite & "," & "http://www.iza.ne.jp/news/event/crime/NwCateRSS.rdf"
mySite = mySite & "," & "http://www.iza.ne.jp/news/event/trial/NwCateRSS.rdf"
mySite = mySite & "," & "http://www.iza.ne.jp/news/event/disaster/NwCateRSS.rdf"
mySite = mySite & "," & "http://www.iza.ne.jp/news/event/accident/NwCateRSS.rdf"
'
mySite = mySite & "," & "http://www.iza.ne.jp/news/sports/NwCateRSS.rdf"
mySite = mySite & "," & "http://www.iza.ne.jp/news/sports/npb/NwCateRSS.rdf"
mySite = mySite & "," & "http://www.iza.ne.jp/news/sports/mlb/NwCateRSS.rdf"
mySite = mySite & "," & "http://www.iza.ne.jp/news/sports/soccer/NwCateRSS.rdf"
mySite = mySite & "," & "http://www.iza.ne.jp/news/sports/golf/NwCateRSS.rdf"
mySite = mySite & "," & "http://www.iza.ne.jp/news/sports/fight/NwCateRSS.rdf"
mySite = mySite & "," & "http://www.iza.ne.jp/news/sports/sumo/NwCateRSS.rdf"
mySite = mySite & "," & "http://www.iza.ne.jp/news/sports/race/NwCateRSS.rdf"
mySite = mySite & "," & "http://www.iza.ne.jp/news/sports/other/NwCateRSS.rdf"
'
mySite = mySite & "," & "http://www.iza.ne.jp/news/entertainment/NwCateRSS.rdf"
mySite = mySite & "," & "http://www.iza.ne.jp/news/entertainment/television/NwCateRSS.rdf"
mySite = mySite & "," & "http://www.iza.ne.jp/news/entertainment/celebrity/NwCateRSS.rdf"
mySite = mySite & "," & "http://www.iza.ne.jp/news/entertainment/movie/NwCateRSS.rdf"
mySite = mySite & "," & "http://www.iza.ne.jp/news/entertainment/music/NwCateRSS.rdf"
mySite = mySite & "," & "http://www.iza.ne.jp/news/entertainment/stage/NwCateRSS.rdf"
mySite = mySite & "," & "http://www.iza.ne.jp/news/entertainment/game/NwCateRSS.rdf"
mySite = mySite & "," & "http://www.iza.ne.jp/news/entertainment/comic/NwCateRSS.rdf"
mySite = mySite & "," & "http://www.iza.ne.jp/news/entertainment/other/NwCateRSS.rdf"
'
mySite = mySite & "," & "http://www.iza.ne.jp/news/natnews/NwCateRSS.rdf"
mySite = mySite & "," & "http://www.iza.ne.jp/news/natnews/topics/NwCateRSS.rdf"
mySite = mySite & "," & "http://www.iza.ne.jp/news/natnews/koushitsu/NwCateRSS.rdf"
mySite = mySite & "," & "http://www.iza.ne.jp/news/natnews/education/NwCateRSS.rdf"
mySite = mySite & "," & "http://www.iza.ne.jp/news/natnews/environment/NwCateRSS.rdf"
mySite = mySite & "," & "http://www.iza.ne.jp/news/natnews/science/NwCateRSS.rdf"
mySite = mySite & "," & "http://www.iza.ne.jp/news/natnews/medical/NwCateRSS.rdf"
mySite = mySite & "," & "http://www.iza.ne.jp/news/natnews/interview/NwCateRSS.rdf"
'
mySite = mySite & "," & "http://www.iza.ne.jp/news/column/NwCateRSS.rdf"
mySite = mySite & "," & "http://www.iza.ne.jp/news/column/dan/NwCateRSS.rdf"
mySite = mySite & "," & "http://www.iza.ne.jp/news/column/opinion/NwCateRSS.rdf"
mySite = mySite & "," & "http://www.iza.ne.jp/news/column/gaishin/NwCateRSS.rdf"
mySite = mySite & "," & "http://www.iza.ne.jp/news/column/other/NwCateRSS.rdf"
'
mySite = mySite & "," & "http://www.iza.ne.jp/news/world/NwCateRSS.rdf"
mySite = mySite & "," & "http://www.iza.ne.jp/news/world/america/NwCateRSS.rdf"
mySite = mySite & "," & "http://www.iza.ne.jp/news/world/china/NwCateRSS.rdf"
mySite = mySite & "," & "http://www.iza.ne.jp/news/world/korea/NwCateRSS.rdf"
mySite = mySite & "," & "http://www.iza.ne.jp/news/world/asia/NwCateRSS.rdf"
mySite = mySite & "," & "http://www.iza.ne.jp/news/world/mideast/NwCateRSS.rdf"
mySite = mySite & "," & "http://www.iza.ne.jp/news/world/europe/NwCateRSS.rdf"
mySite = mySite & "," & "http://www.iza.ne.jp/news/world/worldnews/NwCateRSS.rdf"
'
mySite = mySite & "," & "http://www.iza.ne.jp/news/economy/NwCateRSS.rdf"
mySite = mySite & "," & "http://www.iza.ne.jp/news/economy/finance/NwCateRSS.rdf"
mySite = mySite & "," & "http://www.iza.ne.jp/news/economy/policy/NwCateRSS.rdf"
mySite = mySite & "," & "http://www.iza.ne.jp/news/economy/chinaecon/NwCateRSS.rdf"
mySite = mySite & "," & "http://www.iza.ne.jp/news/economy/worldecon/NwCateRSS.rdf"
'
mySite = mySite & "," & "http://www.iza.ne.jp/news/business/NwCateRSS.rdf"
mySite = mySite & "," & "http://www.iza.ne.jp/news/business/product/NwCateRSS.rdf"
mySite = mySite & "," & "http://www.iza.ne.jp/news/business/manufacturer/NwCateRSS.rdf"
mySite = mySite & "," & "http://www.iza.ne.jp/news/business/retail/NwCateRSS.rdf"
mySite = mySite & "," & "http://www.iza.ne.jp/news/business/media/NwCateRSS.rdf"
mySite = mySite & "," & "http://www.iza.ne.jp/news/business/infotech/NwCateRSS.rdf"
mySite = mySite & "," & "http://www.iza.ne.jp/news/business/other/NwCateRSS.rdf"
mySite = mySite & "," & "http://www.iza.ne.jp/news/business/financial/NwCateRSS.rdf"
'
mySite = mySite & "," & "http://www.iza.ne.jp/news/it/NwCateRSS.rdf"
mySite = mySite & "," & "http://www.iza.ne.jp/news/it/itbiz/NwCateRSS.rdf"
mySite = mySite & "," & "http://www.iza.ne.jp/news/it/internet/NwCateRSS.rdf"
'
mySite = mySite & "," & "http://www.iza.ne.jp/news/politics/NwCateRSS.rdf"
mySite = mySite & "," & "http://www.iza.ne.jp/news/politics/politicsit/NwCateRSS.rdf"
mySite = mySite & "," & "http://www.iza.ne.jp/news/politics/diplomacy/NwCateRSS.rdf"
mySite = mySite & "," & "http://www.iza.ne.jp/news/politics/econpolicy/NwCateRSS.rdf"
mySite = mySite & "," & "http://www.iza.ne.jp/news/politics/dompolicy/NwCateRSS.rdf"
mySite = mySite & "," & "http://www.iza.ne.jp/news/politics/localpolicy/NwCateRSS.rdf"
'
mySite = mySite & "," & "http://www.iza.ne.jp/news/books/NwCateRSS.rdf"
mySite = mySite & "," & "http://www.iza.ne.jp/news/books/breview/NwCateRSS.rdf"
mySite = mySite & "," & "http://www.iza.ne.jp/news/books/art/NwCateRSS.rdf"
'
mySite = mySite & "," & "http://www.iza.ne.jp/news/living/NwCateRSS.rdf"
mySite = mySite & "," & "http://www.iza.ne.jp/news/living/cooking/NwCateRSS.rdf"
mySite = mySite & "," & "http://www.iza.ne.jp/news/living/health/NwCateRSS.rdf"
mySite = mySite & "," & "http://www.iza.ne.jp/news/living/style/NwCateRSS.rdf"
mySite = mySite & "," & "http://www.iza.ne.jp/news/living/pet/NwCateRSS.rdf"
mySite = mySite & "," & "http://www.iza.ne.jp/news/living/children/NwCateRSS.rdf"
mySite = mySite & "," & "http://www.iza.ne.jp/news/living/senior/NwCateRSS.rdf"
mySite = mySite & "," & "http://www.iza.ne.jp/news/living/hobby/NwCateRSS.rdf"
mySite = mySite & "," & "http://www.iza.ne.jp/news/living/household/NwCateRSS.rdf"
End Sub ' MyRssIzaMySite *----*----* *----*----* *----*----* *----*----*
Sub MyRssIzaMySheet(mySheet As String)
'
mySheet = "イザ！ニュース イザ！のトップニュース"
mySheet = mySheet & "," & "記者ブログ"
mySheet = mySheet & "," & "専門家ブログ"
mySheet = mySheet & "," & "ユーザーブログ"
'
mySheet = mySheet & "," & "ブックマーク"
'
mySheet = mySheet & "," & "イザ語"
'
'
mySheet = mySheet & "," & "イザ！ニュース 事件です "
mySheet = mySheet & "," & "イザ！ニュース 事件 "
mySheet = mySheet & "," & "イザ！ニュース 裁判 "
mySheet = mySheet & "," & "イザ！ニュース 災害 "
mySheet = mySheet & "," & "イザ！ニュース 事故 "
'
mySheet = mySheet & "," & "イザ！ニュース スポーツ "
mySheet = mySheet & "," & "イザ！ニュース プロ野球 "
mySheet = mySheet & "," & "イザ！ニュース 大リーグ "
mySheet = mySheet & "," & "イザ！ニュース サッカー "
mySheet = mySheet & "," & "イザ！ニュース ゴルフ "
mySheet = mySheet & "," & "イザ！ニュース 格闘技 "
mySheet = mySheet & "," & "イザ！ニュース 相撲 "
mySheet = mySheet & "," & "イザ！ニュース 競馬・レース "
' mySheet = mySheet & "," & "イザ！ニュース その他 "
'
mySheet = mySheet & "," & "イザ！ニュース エンタメ "
mySheet = mySheet & "," & "イザ！ニュース 芸能界 "
mySheet = mySheet & "," & "イザ！ニュース テレビ "
mySheet = mySheet & "," & "イザ！ニュース 映画 "
mySheet = mySheet & "," & "イザ！ニュース 音楽 "
mySheet = mySheet & "," & "イザ！ニュース ステージ "
mySheet = mySheet & "," & "イザ！ニュース ゲーム "
mySheet = mySheet & "," & "イザ！ニュース コミック・アニメ "
' mySheet = mySheet & "," & "イザ！ニュース その他 "
'
mySheet = mySheet & "," & "イザ！ニュース 話題！ イザ！の話題！"
mySheet = mySheet & "," & "イザ！ニュース 話のタネ "
mySheet = mySheet & "," & "イザ！ニュース 皇室 "
mySheet = mySheet & "," & "イザ！ニュース 教育 "
mySheet = mySheet & "," & "イザ！ニュース 環境・エコ "
mySheet = mySheet & "," & "イザ！ニュース 宇宙と科学 "
mySheet = mySheet & "," & "イザ！ニュース 病気 "
mySheet = mySheet & "," & "イザ！ニュース インタビュー "
'
mySheet = mySheet & "," & "イザ！ニュース コラむ "
mySheet = mySheet & "," & "イザ！ニュース 断 "
mySheet = mySheet & "," & "イザ！ニュース オピニオン "
mySheet = mySheet & "," & "イザ！ニュース 海外から "
mySheet = mySheet & "," & "イザ！ニュース その他論説 "
'
mySheet = mySheet & "," & "イザ！ニュース 世界から "
mySheet = mySheet & "," & "イザ！ニュース 南北アメリカ "
mySheet = mySheet & "," & "イザ！ニュース 中国・台湾 "
mySheet = mySheet & "," & "イザ！ニュース 韓国・北朝鮮 "
mySheet = mySheet & "," & "イザ！ニュース アジア・太平洋 "
mySheet = mySheet & "," & "イザ！ニュース 中東・アフリカ "
mySheet = mySheet & "," & "イザ！ニュース ヨーロッパ "
mySheet = mySheet & "," & "イザ！ニュース 世界の話題 "
'
mySheet = mySheet & "," & "イザ！ニュース マネー・経済 "
mySheet = mySheet & "," & "イザ！ニュース 金融 "
' mySheet = mySheet & "," & "イザ！ニュース 経済政策 "
mySheet = mySheet & "," & "イザ！ニュース アジア経済 "
mySheet = mySheet & "," & "イザ！ニュース 海外経済 "
'
mySheet = mySheet & "," & "イザ！ニュース ビジネス "
mySheet = mySheet & "," & "イザ！ニュース 新商品 "
mySheet = mySheet & "," & "イザ！ニュース メーカー "
mySheet = mySheet & "," & "イザ！ニュース 流通・商社 "
mySheet = mySheet & "," & "イザ！ニュース メディア "
mySheet = mySheet & "," & "イザ！ニュース 情報・通信 "
mySheet = mySheet & "," & "イザ！ニュース その他産業 "
mySheet = mySheet & "," & "イザ！ニュース 財界 "
'
mySheet = mySheet & "," & "イザ！ニュース IT "
mySheet = mySheet & "," & "イザ！ニュース ITビジネス "
mySheet = mySheet & "," & "イザ！ニュース インターネット "
'
mySheet = mySheet & "," & "イザ！ニュース 政治も "
mySheet = mySheet & "," & "イザ！ニュース 政局 "
mySheet = mySheet & "," & "イザ！ニュース 外交 "
' mySheet = mySheet & "," & "イザ！ニュース 経済政策 "
mySheet = mySheet & "," & "イザ！ニュース 社会政策 "
mySheet = mySheet & "," & "イザ！ニュース 地方自治 "
'
mySheet = mySheet & "," & "イザ！ニュース 本・アート "
mySheet = mySheet & "," & "イザ！ニュース 書評 "
mySheet = mySheet & "," & "イザ！ニュース アート "
'
mySheet = mySheet & "," & "イザ！ニュース リビング "
mySheet = mySheet & "," & "イザ！ニュース 食 "
mySheet = mySheet & "," & "イザ！ニュース 健康 "
mySheet = mySheet & "," & "イザ！ニュース ファッション "
mySheet = mySheet & "," & "イザ！ニュース ペット "
mySheet = mySheet & "," & "イザ！ニュース 育児・福祉 "
mySheet = mySheet & "," & "イザ！ニュース シニア "
mySheet = mySheet & "," & "イザ！ニュース 趣味 "
mySheet = mySheet & "," & "イザ！ニュース 暮らし経済 "
'
'
mySheet = mySheet & "," & "イザ！ニュース 経済政策 "
mySheet = mySheet & "," & "イザ！ニュース その他 "
End Sub ' MyRssIzaMySheet *----*----* *----*----* *----*----* *----*----*
Sub MyRssIzaSheetName(mySheetArray As Variant)
Dim myName As String
Dim mySheet As Variant
Static myCategory As String
'
myName = Cells(1, 1).Text
'
For Each mySheet In mySheetArray
Select Case True
Case InStr(myName, mySheet) > 0
myName = mySheet
'
Select Case True
Case InStr(myName, "イザ！ニュース イザ！のトップニュース") > 0
myName = "■総合"
myCategory = Mid(myName, 2) & " "
'
Case InStr(myName, "記者ブログ") > 0
myCategory = "ブログ "
'
Case InStr(myName, "ブックマーク") > 0
myCategory = myName
'
Case InStr(myName, "イザ語") > 0
myCategory = myName
'
'
Case InStr(myName, "イザ！ニュース 事件です ") > 0
myName = "■事件です"
myCategory = Mid(myName, 2) & " "
'
Case InStr(myName, "イザ！ニュース スポーツ ") > 0
myName = "■スポーツ"
myCategory = Mid(myName, 2) & " "
'
Case InStr(myName, "イザ！ニュース エンタメ ") > 0
myName = "■エンタメ"
myCategory = Mid(myName, 2) & " "
'
Case InStr(myName, "イザ！ニュース 話題！ イザ！の話題！") > 0
myName = "■話題"
myCategory = Mid(myName, 2) & " "
'
Case InStr(myName, "イザ！ニュース コラむ ") > 0
myName = "■コラむ"
myCategory = Mid(myName, 2) & " "
'
Case InStr(myName, "イザ！ニュース 世界から ") > 0
myName = "■世界から"
myCategory = Mid(myName, 2) & " "
'
Case InStr(myName, "イザ！ニュース マネー・経済 ") > 0
myName = "■マネー・経済"
myCategory = Mid(myName, 2) & " "
'
Case InStr(myName, "イザ！ニュース ビジネス ") > 0
myName = "■ビジネス"
myCategory = Mid(myName, 2) & " "
'
Case InStr(myName, "イザ！ニュース IT ") > 0
myName = "■IT"
myCategory = Mid(myName, 2) & " "
'
Case InStr(myName, "イザ！ニュース 政治も ") > 0
myName = "■政治も"
myCategory = Mid(myName, 2) & " "
'
Case InStr(myName, "イザ！ニュース 本・アート ") > 0
myName = "■本・アート"
myCategory = Mid(myName, 2) & " "
'
Case InStr(myName, "イザ！ニュース リビング ") > 0
myName = "■リビング"
myCategory = Mid(myName, 2) & " "
'
'
Case InStr(myName, "イザ！ニュース 経済政策 ") > 0
myName = myCategory & "経済政策"
Case InStr(myName, "イザ！ニュース その他 ") > 0
myName = myCategory & "その他"
End Select
Exit For
End Select
Next ' mySheet
'
myName = Replace(myName, "イザ！ニュース ", "")
ActiveSheet.Name = myName
End Sub ' MyRssIzaSheetName *----*----* *----*----* *----*----* *----*----*
Sub MyRssIzaPopUp(myTitle As String)
Rem *----*----* *----*----* *----*----* *----*----*
Rem ポップアップ表示処理
Rem *----*----* *----*----* *----*----* *----*----*
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 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 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
myMsg = myMsg & "イザ！RSS取り込み処理" & vbCrLf & vbCrLf
'
With myCtrlBttnIcon
.DescriptionText = "イザ！RSS取り込み処理ポップアップメニュー"
.Style = msoButtonIconAndWrapCaption
.Caption = myMsg & "処理を実行しますか？"
.TooltipText = "処理を実行しますか？"
.FaceId = 1089
myFaceId = .FaceId
.OnAction = "MyRssIzaBttnMyIcon"
End With
'
With myCtrlBttnDeTail
.DescriptionText = "[詳細RSSも取り込む]ボタン"
.BeginGroup = True
.Style = msoButtonIconAndCaption
.Caption = "詳細RSSも取り込む"
.TooltipText = "詳細RSSは取り込まない。"
.FaceId = 6963
.OnAction = "MyRssIzaBttnMyDetail"
End With
'
With myCtrlBttnOk
.DescriptionText = "[OK]ボタン"
.BeginGroup = True
.Style = msoButtonIconAndCaption
.Caption = "OK"
.TooltipText = "処理をを実行します。"
.FaceId = 964
.OnAction = "MyRssIzaBttnMyOk"
End With
'
With myCtrlBttnCancel
.DescriptionText = "[キャンセル]ボタン"
.Style = msoButtonIconAndCaption
.Caption = "キャンセル" & String(13, " ")
.TooltipText = "処理を中止します。"
.FaceId = 330
.OnAction = "MyRssIzaBttnMyCancel"
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, 1089 ' [チェックボックス]オン・オフ／[処理を実行しますか？]
x = myCmmdBar.Left
y = myCmmdBar.Top
myCmmdBar.Controls(1).FaceId = myFaceId
Case Else
x = -1: y = -1
End Select
Loop
End Sub ' MyRssIzaPopUp *----*----* *----*----* *----*----* *----*----*
Sub MyRssIzaBttnMyIcon(Optional MyDummy As Boolean)
Rem *----*----* *----*----* *----*----* *----*----*
Rem [処理を実行しますか？]ボタン処理
Rem *----*----* *----*----* *----*----* *----*----*
'
CommandBars("MyRssIza").Controls(1).FaceId = 1089
End Sub ' MyRssIzaBttnMyIcon *----*----* *----*----* *----*----* *----*----*
Sub MyRssIzaBttnMyDetail(Optional MyDummy As Boolean)
Rem *----*----* *----*----* *----*----* *----*----*
Rem [詳細RSSも取り込む]ボタン処理
Rem *----*----* *----*----* *----*----* *----*----*
'
With CommandBars("MyRssIza").Controls(2)
If .FaceId = 6963 Then
.FaceId = 220
.TooltipText = "詳細RSSも取り込む。"
Else
.FaceId = 6963
.TooltipText = "詳細RSSは取り込まない。"
End If
End With
CommandBars("MyRssIza").Controls(1).FaceId = CommandBars("MyRssIza").Controls(2).FaceId
End Sub ' MyRssIzaBttnMyDetail *----*----* *----*----* *----*----* *----*----*
Sub MyRssIzaBttnMyOk(Optional MyDummy As Boolean)
Rem *----*----* *----*----* *----*----* *----*----*
Rem コマンドボタン[OK]OnAction処理
Rem *----*----* *----*----* *----*----* *----*----*
'
CommandBars("MyRssIza").Controls(1).FaceId = 964
End Sub ' MyRssIzaBttnMyOk *----*----* *----*----* *----*----* *----*----*
Sub MyRssIzaBttnMyCancel(Optional MyDummy As Boolean)
Rem *----*----* *----*----* *----*----* *----*----*
Rem コマンドボタン[キャンセル]OnAction処理
Rem *----*----* *----*----* *----*----* *----*----*
'
CommandBars("MyRssIza").Controls(1).FaceId = 330
End Sub ' MyRssIzaBttnMyCancel *----*----* *----*----* *----*----* *----*----*
