Sub MyRssFsBizi()
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Rem フジサンケイ ビジネスアイ（FujiSankei Business i.）RSS取り込み処理
  Rem 作譜：Hitrock Camellia Shinopy
  Rem 言語：Excel VBA
  Rem 機能...
  Rem   指定したサイトのRSSを取り込みする。
  Rem 注記...
  Rem   1. MyRssFsBiziを起動して実行。
  Rem   2. 初回実行前に「myFile」に取り込むRSSデータの保存先を指定すること。
  Rem 履歴...
  Rem   第01版：2008/03/30：作成。
  Rem   第02版：2008/04/12：シート名設定を変更。
  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\MyRssFsBizi.xml"
  Call MyRssFsBiziMySite(mySite)
  mySiteArray = Split(mySite, ",")
  Call MyRssFsBiziMySheet(mySheet)
  mySheetArray = Split(mySheet, ",")
  myMax = UBound(mySiteArray) + 1
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  myStatusBar = "FujiSankei Business i. RSS取り込み処理 開始！"
  Application.StatusBar = "MyRssFsBizi: " & 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 *----*----*    *----*----*    *----*----*    *----*----*
  '
MyRssFsBiziSubEntry:
  c = 0
  For Each myURL In mySiteArray
    c = c + 1
    myStatusBar = c * 100 \ myMax & "%  " & c & "/" & myMax & "頁　"
    Application.StatusBar = "MyRssFsBizi" & "：" & myStatusBar
    '
    Columns("A:A").Select
    With Selection
      .ColumnWidth = 90
      .RowHeight = 22
      .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 MyRssFsBiziMyXmlDoc(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 *----*----*    *----*----*    *----*----*    *----*----*
  '
MyRssFsBiziSubExit:
  Application.ScreenUpdating = True
  On Error Resume Next
  Kill myFile
  On Error GoTo 0
  myText = "処理が終了しました。"
  Application.StatusBar = "MyRssFsBizi: " & myText & " " & Now()
  Application.Speech.Speak myText, False
End Sub ' MyRssFsBizi *----*----*    *----*----*    *----*----*    *----*----*

Sub MyRssFsBiziMyXmlDoc(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 MyRssFsBiziSheetName(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 ' MyRssFsBiziMyXmlDoc *----*----*    *----*----*    *----*----*    *----*----*

Sub MyRssFsBiziMySite(mySite As String)
  mySite = "http://www.pheedo.jp/f/fbi_sou-news"
  '
  mySite = mySite & "," & "http://www.pheedo.jp/f/fbi_kinyu-news"
  mySite = mySite & "," & "http://www.pheedo.jp/f/fbi_china-news"
  mySite = mySite & "," & "http://www.pheedo.jp/f/fbi_ind-news"
  '
  mySite = mySite & "," & "http://www.pheedo.jp/f/fbi_product"
  mySite = mySite & "," & "http://www.rsssuite.jp/sankei/f3756/index.rdf"
  mySite = mySite & "," & "http://www.rsssuite.jp/sankei/f3678/index.rdf"
  mySite = mySite & "," & "http://www.rsssuite.jp/sankei/f3679/index.rdf"
  mySite = mySite & "," & "http://www.rsssuite.jp/sankei/f3683/index.rdf"
  mySite = mySite & "," & "http://www.rsssuite.jp/sankei/f3685/index.rdf"
  mySite = mySite & "," & "http://www.rsssuite.jp/sankei/f3687/index.rdf"
  '
  mySite = mySite & "," & "http://www.rsssuite.jp/sankei/f3680/index.rdf"
  mySite = mySite & "," & "http://www.rsssuite.jp/sankei/f3681/index.rdf"
  mySite = mySite & "," & "http://www.rsssuite.jp/sankei/f3684/index.rdf"
  mySite = mySite & "," & "http://www.rsssuite.jp/sankei/f3686/index.rdf"
End Sub ' MyRssFsBiziMySite *----*----*    *----*----*    *----*----*    *----*----*

Sub MyRssFsBiziMySheet(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 & "," & "知的財産サロン"
End Sub ' MyRssFsBiziMySheet *----*----*    *----*----*    *----*----*    *----*----*

Sub MyRssFsBiziSheetName(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 ' MyRssFsBiziSheetName *----*----*    *----*----*    *----*----*    *----*----*