Sub MyRssFnnNews()
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Rem FNN（フジニュースネットワーク）RSS取り込み処理
  Rem 作譜：Hitrock Camellia Shinopy
  Rem 言語：Excel VBA
  Rem 機能...
  Rem   指定したサイトのRSSを取り込みする。
  Rem 注記...
  Rem   1. MyRssFnnNewsを起動して実行。
  Rem   2. 初回実行前に「myFile」に取り込むRSSデータの保存先を指定すること。
  Rem 履歴...
  Rem   第01版：2008/09/08：作成。
  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 = "MyRssFnnNews"
  myFile = "C:\Documents and Settings\User\My Documents\Zzz\MyRssFnnNews.xml"
  Call MyRssFnnNewsPopUp(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 MyRssFnnNewsSubExit
  '
  Call MyRssFnnNewsMySite(mySite, myFlag)
  mySiteArray = Split(mySite, ",")
  Call MyRssFnnNewsMySheet(mySheet)
  mySheetArray = Split(mySheet, ",")
  '
  mySiteArray = Split(mySite, ",")
  myMax = UBound(mySiteArray) + 1
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  myStatusBar = "FNN（フジニュースネットワーク）RSS取り込み処理 開始！"
  Application.StatusBar = "MyRssFnnNews: " & 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 *----*----*    *----*----*    *----*----*    *----*----*
  '
MyRssFnnNewsSubEntry:
  c = 0
  For Each myURL In mySiteArray
    c = c + 1
    myStatusBar = c * 100 \ myMax & "%  " & c & "/" & myMax & "頁　"
    Application.StatusBar = "MyRssFnnNews" & "：" & 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 MyRssFnnNewsMyXmlDoc(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 *----*----*    *----*----*    *----*----*    *----*----*
  '
MyRssFnnNewsSubExit:
  Application.ScreenUpdating = True
  On Error Resume Next
  Kill myFile
  On Error GoTo 0
  myText = "処理が終了しました。"
  Application.StatusBar = "MyRssFnnNews: " & myText & " " & Now()
  Application.Speech.Speak myText, False
End Sub ' MyRssFnnNews *----*----*    *----*----*    *----*----*    *----*----*

Sub MyRssFnnNewsMyXmlDoc(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 + 1
    myStatusBar = Application.StatusBar
    myStatusBar = Left(myStatusBar, InStr(myStatusBar, "頁　") + 1)
    myStatusBar = myStatusBar & i & "/" & myTitle.Length & "行"
    Application.StatusBar = myStatusBar
    '
    If i = 1 Then
      myText = myTitle(i - 1).Text
      ActiveSheet.Hyperlinks.Add Anchor:=Cells(i, 1), Address:=myLink(i - 1).Text, TextToDisplay:=myText ' & " " & myDescript(i - 1).Text
      Cells(i + 1, 2).Value = myDescript(i - 1).Text
      Call MyRssFnnNewsSheetName(mySheetArray)
    Else
      myText = myTitle(i - 1).Text
      ActiveSheet.Hyperlinks.Add Anchor:=Cells(i, 1), Address:=myLink(i - 1).Text, TextToDisplay:=myText
    Cells(i + 1, 2).Value = myDescript(i - 1).Text
    End If
    '
    DoEvents
  Next ' i
End Sub ' MyRssFnnNewsMyXmlDoc *----*----*    *----*----*    *----*----*    *----*----*

Sub MyRssFnnNewsMySite(mySite As String, myFlag As Boolean)
  mySite = "http://rss.fnn-news.com/fnn_news.xml"
  mySite = mySite & "," & "http://rss.fnn-news.com/fnn_news00.xml"
  mySite = mySite & "," & "http://rss.fnn-news.com/fnn_news01.xml"
  mySite = mySite & "," & "http://rss.fnn-news.com/fnn_news02.xml"
  mySite = mySite & "," & "http://rss.fnn-news.com/fnn_news03.xml"
  mySite = mySite & "," & "http://rss.fnn-news.com/fnn_news04.xml"
  mySite = mySite & "," & "http://rss.fnn-news.com/fnn_news05.xml"
  '
  mySite = mySite & "," & "http://rss.fnn-news.com/fnn_news_ranking.xml"
  mySite = mySite & "," & "http://rss.fnn-news.com/fnn_ss.xml"
  mySite = mySite & "," & "http://rss.fnn-news.com/fnn_news_en.xml"
End Sub ' MyRssFnnNewsMySite *----*----*    *----*----*    *----*----*    *----*----*

Sub MyRssFnnNewsMySheet(mySheet As String)
  mySheet = "FNNヘッドラインニュース"
  mySheet = mySheet & "," & "FNN: 社会"
  mySheet = mySheet & "," & "FNN: 政治"
  mySheet = mySheet & "," & "FNN: 経済"
  mySheet = mySheet & "," & "FNN: 国際"
  mySheet = mySheet & "," & "FNN: スポーツ"
  mySheet = mySheet & "," & "FNN: 話題"
  '
  mySheet = mySheet & "," & "FNN: アクセスランキング"
  mySheet = mySheet & "," & "FNNスピーク特集"
  mySheet = mySheet & "," & "FNN Headline news"
End Sub ' MyRssFnnNewsMySheet *----*----*    *----*----*    *----*----*    *----*----*

Sub MyRssFnnNewsSheetName(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
        Exit For
    End Select
  Next ' mySheet
  '
  myName = Replace(myName, ": ", " ")
  ActiveSheet.Name = myName
End Sub ' MyRssFnnNewsSheetName *----*----*    *----*----*    *----*----*    *----*----*

Sub MyRssFnnNewsPopUp(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:=2, Temporary:=True)
  Set myCtrlBttnCancel = myCmmdBar.Controls.Add(Type:=msoControlButton, Before:=3, Temporary:=True)
  '
  myMsg = myTitle & vbCrLf
  myMsg = myMsg & "FNN（フジニュースネットワーク）RSS取り込み処理" & vbCrLf & vbCrLf
  '
  With myCtrlBttnIcon
    .DescriptionText = "FNN（フジニュースネットワーク）RSS取り込み処理ポップアップメニュー"
    .Style = msoButtonIconAndWrapCaption
    .Caption = myMsg & "処理を実行しますか？"
    .TooltipText = "処理を実行しますか？"
    .FaceId = 1089
    myFaceId = .FaceId
    .OnAction = "MyRssFnnNewsBttnMyIcon"
  End With
  '
  ' With myCtrlBttnDeTail
  '   .DescriptionText = "[詳細RSSも取り込む]ボタン"
  '  .BeginGroup = True
  '  .Style = msoButtonIconAndCaption
  '  .Caption = "詳細RSSも取り込む"
  '  .TooltipText = "詳細RSSは取り込まない。"
  '  .FaceId = 6963
  '  .OnAction = "MyRssFnnNewsBttnMyDetail"
  'End With
  '
  With myCtrlBttnOk
    .DescriptionText = "[OK]ボタン"
    .BeginGroup = True
    .Style = msoButtonIconAndCaption
    .Caption = "OK"
    .TooltipText = "処理をを実行します。"
    .FaceId = 964
    .OnAction = "MyRssFnnNewsBttnMyOk"
  End With
  '
  With myCtrlBttnCancel
    .DescriptionText = "[キャンセル]ボタン"
    .Style = msoButtonIconAndCaption
    .Caption = "キャンセル" & String(13, "　")
    .TooltipText = "処理を中止します。"
    .FaceId = 330
    .OnAction = "MyRssFnnNewsBttnMyCancel"
  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 ' MyRssFnnNewsPopUp *----*----*    *----*----*    *----*----*    *----*----*

Sub MyRssFnnNewsBttnMyIcon(Optional MyDummy As Boolean)
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Rem [処理を実行しますか？]ボタン処理
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  CommandBars("MyRssFnnNews").Controls(1).FaceId = 1089
End Sub ' MyRssFnnNewsBttnMyIcon *----*----*    *----*----*    *----*----*    *----*----*

Sub MyRssFnnNewsBttnMyDetail(Optional MyDummy As Boolean)
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Rem [詳細RSSも取り込む]ボタン処理
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  With CommandBars("MyRssFnnNews").Controls(2)
    If .FaceId = 6963 Then
      .FaceId = 220
      .TooltipText = "詳細RSSも取り込む。"
    Else
     .FaceId = 6963
     .TooltipText = "詳細RSSは取り込まない。"
    End If
  End With
  CommandBars("MyRssFnnNews").Controls(1).FaceId = CommandBars("MyRssFnnNews").Controls(2).FaceId
End Sub ' MyRssFnnNewsBttnMyDetail *----*----*    *----*----*    *----*----*    *----*----*

Sub MyRssFnnNewsBttnMyOk(Optional MyDummy As Boolean)
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Rem コマンドボタン[OK]OnAction処理
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  CommandBars("MyRssFnnNews").Controls(1).FaceId = 964
End Sub ' MyRssFnnNewsBttnMyOk *----*----*    *----*----*    *----*----*    *----*----*

Sub MyRssFnnNewsBttnMyCancel(Optional MyDummy As Boolean)
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Rem コマンドボタン[キャンセル]OnAction処理
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  CommandBars("MyRssFnnNews").Controls(1).FaceId = 330
End Sub ' MyRssFnnNewsBttnMyCancel *----*----*    *----*----*    *----*----*    *----*----*