Sub MyRssAsahiCom()
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Rem asahi.comサイトRSS取り込み処理
  Rem 作譜：Hitrock Camellia Shinopy
  Rem 言語：Excel VBA
  Rem 機能...
  Rem   指定したサイトのRSSを取り込みする。
  Rem 注記...
  Rem   1. MyRssAsahiComを起動して実行。
  Rem   2. 初回実行前に変数「myFile」に取り込むRSSデータの保存先を指定すること。
  Rem 履歴...
  Rem   第01版：2008/03/12：作成。
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Dim i 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\Zzz\MyRssAsahiCom.xml"
  Call MyRssAsahiComMySite(mySite)
  '
  myArray = Split(mySite, ",")
  myMax = UBound(myArray) + 1
  '
  myStatusBar = "取り込み開始"
  Application.StatusBar = "MyRssAsahiCom" & "：" & myStatusBar
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  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 *----*----*    *----*----*    *----*----*    *----*----*
  '
MyRssAsahiComSubEntry:
  c = 0
  For Each myURL In myArray
    c = c + 1
    myStatusBar = c * 100 \ myMax & "%  " & c & "/" & myMax & "頁　"
    Application.StatusBar = "MyRssAsahiCom" & "：" & myStatusBar
    '
    Columns("A:A").Select
    With Selection
      .ColumnWidth = 115
      .RowHeight = 25
      .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 <> False Then
        Call MyRssAsahiComMyXmlDoc(myXmlDoc, 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
  '
  Sheets(mySheetFirst).Activate
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
MyRssAsahiComSubExit:
  On Error Resume Next
  Application.ScreenUpdating = True
  Kill myFile
  On Error GoTo 0
  myText = "処理が終了しました。"
  Application.StatusBar = "MyRssAsahiCom: " & myText & " " & Now()
  Application.Speech.Speak myText, False
End Sub ' MyRssAsahiCom *----*----*    *----*----*    *----*----*    *----*----*

Sub MyRssAsahiComMyXmlDoc(myXmlDoc As Variant, myFile As String)
  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
    '
    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
      Call MyRssAsahiComSheetName
    Else
      myText = myTitle(i - 1).Text
      ActiveSheet.Hyperlinks.Add Anchor:=Cells(i, 1), Address:=myLink(i - 1).Text, TextToDisplay:=myText
    End If
    '
    DoEvents
  Next ' i
End Sub ' MyRssAsahiComMyXmlDoc *----*----*    *----*----*    *----*----*    *----*----*

Sub MyRssAsahiComMySite(mySite As String)
  mySite = "http://rss.asahi.com/f/asahi_newsheadlines" ' "http://www3.asahi.com/rss/index.rdf"
  mySite = mySite & "," & "http://rss.asahi.com/f/asahi_national" ' "http://www3.asahi.com/rss/national.rdf"
  mySite = mySite & "," & "http://rss.asahi.com/f/asahi_politics" ' "http://www3.asahi.com/rss/politics.rdf"
  mySite = mySite & "," & "http://rss.asahi.com/f/asahi_life" ' "http://www3.asahi.com/rss/life.rdf"
  mySite = mySite & "," & "http://rss.asahi.com/f/asahi_sports" ' "http://www3.asahi.com/rss/sports.rdf"
  mySite = mySite & "," & "http://rss.asahi.com/f/asahi_business" ' "http://www3.asahi.com/rss/business.rdf"
  mySite = mySite & "," & "http://rss.asahi.com/f/asahi_international" ' "http://www3.asahi.com/rss/international.rdf"
  mySite = mySite & "," & "http://rss.asahi.com/f/asahi_culture" ' "http://www3.asahi.com/rss/culture.rdf"
  mySite = mySite & "," & "http://rss.asahi.com/f/asahi_komimi" ' "http://www3.asahi.com/rss/komimi.rdf"
  mySite = mySite & "," & "http://feeds.asahi.com/asahi/Book" ' "http://www3.asahi.com/rss/book.rdf"
  '
  mySite = mySite & "," & "http://www3.asahi.com/rssegm/daigaku/nyushi.rdf"
  mySite = mySite & "," & "http://www3.asahi.com/rssegm/daigaku/ippan.rdf"
End Sub ' MyRssAsahiComMySite *----*----*    *----*----*    *----*----*    *----*----*

Sub MyRssAsahiComSheetName(Optional MyDummy As Boolean)
  Dim myName As String
  '
  myName = Cells(1, 1).Text
  Select Case True
    Case myName = "asahi.com アサヒ・コム": myName = "速報ニュース"
    Case InStr(myName, "政治") > 0: myName = "政治"
    Case InStr(myName, "暮らし") > 0: myName = "暮らし"
    Case InStr(myName, "スポーツ") > 0: myName = "スポーツ"
    Case InStr(myName, "ビジネス") > 0: myName = "ビジネス"
    Case InStr(myName, "国際") > 0: myName = "国際"
    Case InStr(myName, "文化・芸能") > 0: myName = "文化・芸能"
    Case InStr(myName, "コミミ口コミ") > 0: myName = "コミミ口コミ"
    Case InStr(myName, "書評") > 0: myName = "BOOK"
    Case InStr(myName, "受験生向け情報") > 0: myName = "大学からの受験生向け情報"
    Case InStr(myName, "社会人向け情報") > 0: myName = "大学からの社会人向け情報"
    Case InStr(myName, "社会") > 0: myName = "社会"
    ' Case Else: myName = "All"
  End Select
  ActiveSheet.Name = myName
End Sub ' MyRssAsahiComSheetName *----*----*    *----*----*    *----*----*    *----*----*