Sub MyRssMsnSankei()
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Rem MSN産経ニュースRSS取り込み処理
  Rem 作譜:Hitrock Camellia Shinopy
  Rem 言語:Excel VBA
  Rem 機能...
  Rem   指定したサイトのRSSを取り込みする。
  Rem 注記...
  Rem   1. MyRssMsnSankeiを起動して実行。
  Rem   2. 初回実行前に「myFile」に取り込むRSSデータの保存先を指定すること。
  Rem 履歴...
  Rem   第01版:2008/03/23:作成。
  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\MyRssMsnSankei.xml"
  Call MyRssMsnSankeiMySite(mySite)
  mySiteArray = Split(mySite, ",")
  Call MyRssMsnSankeiMySheet(mySheet)
  mySheetArray = Split(mySheet, ",")
  myMax = UBound(mySiteArray) + 1
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  myStatusBar = "MSN産経ニュース取り込み処理 開始!"
  Application.StatusBar = "MyRssMsnSankei" & ":" & 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 *----*----*    *----*----*    *----*----*    *----*----*
  '
MyRssMsnSankeiSubEntry:
  c = 0
  For Each myURL In mySiteArray
    c = c + 1
    myStatusBar = c * 100 \ myMax & "%  " & c & "/" & myMax & "頁 "
    Application.StatusBar = "MyRssMsnSankei" & ":" & 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 MyRssMsnSankeiMyXmlDoc(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 *----*----*    *----*----*    *----*----*    *----*----*
  '
MyRssMsnSankeiSubExit:
  Application.ScreenUpdating = True
  On Error Resume Next
  Kill myFile
  On Error GoTo 0
  myText = "処理が終了しました。"
  Application.StatusBar = "MyRssMsnSankei: " & myText & " " & Now()
  Application.Speech.Speak myText, False
End Sub ' MyRssMsnSankei *----*----*    *----*----*    *----*----*    *----*----*

Sub MyRssMsnSankeiMyXmlDoc(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 MyRssMsnSankeiSheetName(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
        End If
    End Select
    DoEvents
  Next ' i
End Sub ' MyRssMsnSankeiMyXmlDoc *----*----*    *----*----*    *----*----*    *----*----*

Sub MyRssMsnSankeiMySite(mySite As String)
  mySite = "http://sankei.jp.msn.com/rss/news/points.xml"
  mySite = mySite & "," & "http://sankei.jp.msn.com/rss/news/affairs.xml"
  mySite = mySite & "," & "http://sankei.jp.msn.com/rss/news/politics.xml"
  mySite = mySite & "," & "http://sankei.jp.msn.com/rss/news/economy.xml"
  mySite = mySite & "," & "http://sankei.jp.msn.com/rss/news/world.xml"
  mySite = mySite & "," & "http://sankei.jp.msn.com/rss/news/sports.xml"
  mySite = mySite & "," & "http://sankei.jp.msn.com/rss/news/entertainments.xml"
  mySite = mySite & "," & "http://sankei.jp.msn.com/rss/news/life.xml"
  mySite = mySite & "," & "http://sankei.jp.msn.com/rss/news/culture.xml"
  mySite = mySite & "," & "http://sankei.jp.msn.com/rss/news/release.xml"
  mySite = mySite & "," & "http://sankei.jp.msn.com/rss/news/region.xml"
  mySite = mySite & "," & "http://sankei.jp.msn.com/rss/news/usatoday.xml"
End Sub ' MyRssMsnSankeiMySite *----*----*    *----*----*    *----*----*    *----*----*

Sub MyRssMsnSankeiMySheet(mySheet As String)
  mySheet = "MSN産経ニュース - 注目"
  mySheet = mySheet & "," & "MSN産経ニュース - 事件"
  mySheet = mySheet & "," & "MSN産経ニュース - 政治"
  mySheet = mySheet & "," & "MSN産経ニュース - 経済・IT"
  mySheet = mySheet & "," & "MSN産経ニュース - 国際"
  mySheet = mySheet & "," & "MSN産経ニュース - スポーツ"
  mySheet = mySheet & "," & "MSN産経ニュース - エンタメ"
  mySheet = mySheet & "," & "MSN産経ニュース - 生活"
  mySheet = mySheet & "," & "MSN産経ニュース - 文化"
  mySheet = mySheet & "," & "MSN産経ニュース - 新商品"
  mySheet = mySheet & "," & "MSN産経ニュース - 地方"
  mySheet = mySheet & "," & "MSN産経ニュース - USA TODAY"
End Sub ' MyRssMsnSankeiMySheet *----*----*    *----*----*    *----*----*    *----*----*

Sub MyRssMsnSankeiSheetName(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, "MSN産経ニュース - ", "")
        Exit For
    End Select
  Next ' mySheet
  '
  ActiveSheet.Name = myName
End Sub ' MyRssMsnSankeiSheetName *----*----*    *----*----*    *----*----*    *----*----*
inserted by FC2 system