Sub MyRssKanaloco()
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Rem 神奈川新聞サイトRSS取り込み処理
  Rem 作譜:Hitrock Camellia Shinopy
  Rem 言語:Excel VBA
  Rem 機能...
  Rem   指定したサイトのRSSページを取り込みする。
  Rem 注記...
  Rem   1. MyRssKanalocoを起動して実行。
  Rem   2. 初回実行前に「myFile」に取り込むRSSの保存先を指定すること。
  Rem 履歴...
  Rem   第01版:2007/04/30:作成。
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Dim i As Long
  Dim j 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\MyRssKanaloco\MyRssKanaloco.xml"
  Call MyRssKanalocoMySite(mySite)
  '
  myArray = Split(mySite, ",")
  myMax = UBound(myArray) + 1
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  Application.CommandBars("Task Pane").Visible = 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")
  '
  Application.ScreenUpdating = False
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
MyRssKanalocoSubEntry:
  c = 0
  j = 0
  For Each myURL In myArray
    c = c + 1
    myStatusBar = c * 100 \ myMax & "%  " & c & "/" & myMax & "件 "
    Application.StatusBar = "MyRssKanaloco" & ":" & myStatusBar
    '
    Columns("A:A").Select
    With Selection
      .ColumnWidth = 80
      .VerticalAlignment = xlTop
      .WrapText = True
    End With
    Columns("B:B").Select
    With Selection
      .ColumnWidth = 100
      .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 MyRssKanalocoMyXmlDoc(myXmlDoc, j, 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
  '
  Call MyRssKanalocoUninetblog
  Sheets(mySheetFirst).Activate
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
MyRssKanalocoSubExit:
  Application.ScreenUpdating = True
  Kill myFile
  myText = "処理が終了しました。"
  Application.StatusBar = "MyRssKanaloco: " & myText & " " & Now()
  Application.Speech.Speak myText, False
End Sub ' MyRssKanaloco *----*----*    *----*----*    *----*----*    *----*----*

Sub MyRssKanalocoMyXmlDoc(myXmlDoc As Variant, j As Long, myFile As String)
  Dim myTitle  As Variant
  Dim myLink  As Variant
  Dim myDescript  As Variant
  '
  Dim i As Long
  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
        On Error Resume Next
        ActiveSheet.Name = Cells(i, 1).Text
        If Err.Number <> 0 Then
          j = j + 1
          ActiveSheet.Name = Cells(i, 1).Text & " " & j
        End If
        Err.Clear
        On Error GoTo 0
        Call MyRssKanalocoSheetName
        Cells(i, 1).Value = "○ " & Cells(i, 1).Value
      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 ' MyRssKanalocoMyXmlDoc *----*----*    *----*----*    *----*----*    *----*----*

Sub MyRssKanalocoMySite(mySite As String)
  mySite = "http://www.pheedo.jp/f/kanaloco_localnews" ' ローカルニュース
  mySite = mySite & "," & "http://www.kanaloco.jp/casefiles/rss/" ' カナガワ事件簿
  mySite = mySite & "," & "http://www.kanaloco.jp/sportsnews/rss" ' スポーツニュース
  mySite = mySite & "," & "http://www.kanaloco.jp/editorial/rss" ' 神奈川新聞の社説
  mySite = mySite & "," & "http://www.kanaloco.jp/serial/rss" ' 神奈川新聞の連載
  mySite = mySite & "," & "http://www.kanaloco.jp/lamp/rss" ' 神奈川新聞の照明灯
  '
  mySite = mySite & "," & "http://www.kanaloco.jp/dailybaystars/rss" ' デイリーベイスターズ
  mySite = mySite & "," & "http://www.kanaloco.jp/baystarsfever/rss/" ' ベイスターズフィーバー
  mySite = mySite & "," & "http://www.kanaloco.jp/jleague/rss/" ' カナロコJリーグ
  mySite = mySite & "," & "http://www.kanaloco.jp/idobata/rss/" ' 井戸端会議
  mySite = mySite & "," & "http://www.kanaloco.jp/report/rss/" ' りぽーと
  mySite = mySite & "," & "http://www.kanaloco.jp/photo/rss/" ' カナロコ写真帳
  '
  mySite = mySite & "," & "http://www.kanaloco.jp/uninetblog/rss/" ' ゆにねっと
  mySite = mySite & "," & "http://www.kanaloco.jp/uninetblog/information_rss/" ' ゆにねっと インフォメーション
  mySite = mySite & "," & "http://www.kanaloco.jp/uninetblog/ayu_view_rss/" ' ゆにねっと あゆの視線
  mySite = mySite & "," & "http://www.kanaloco.jp/uninetblog/with_ayu_rss/" ' ゆにねっと あゆと歩こう
  '
  mySite = mySite & "," & "http://www.kanaloco.jp/lmcolumn/rss/" ' コラムで読むライブ
  mySite = mySite & "," & "http://www.kanaloco.jp/lmpickup/rss/" ' 今月のPickup!
  '
  mySite = mySite & "," & "http://www.kanaloco.jp/bookbar/rss/" ' BOOK BAR
  mySite = mySite & "," & "http://www.kanaloco.jp/stationery/rss/" ' 至福の文具
  mySite = mySite & "," & "http://www.kanaloco.jp/gardenstyle/rss/" ' 私のガーデンスタイル
  '
  mySite = mySite & "," & "http://www.kanaloco.jp/officeblog/rss/" ' カナロコ編集部ブログ
  mySite = mySite & "," & "http://www.kanaloco.jp/information/rss/" ' 神奈川新聞社からのお知らせ
End Sub ' MyRssKanalocoMySite *----*----*    *----*----*    *----*----*    *----*----*

Sub MyRssKanalocoSheetName(Optional myDummy As Boolean)
  Dim myName As String
  '
  myName = ActiveSheet.Name
  myName = Replace(myName, " localnews", "")
  myName = Replace(myName, " casefiles", "")
  myName = Replace(myName, " sportsnews", "")
  myName = Replace(myName, " editorial", "")
  myName = Replace(myName, " serial", "")
  myName = Replace(myName, " lamp", "")
  '
  myName = Replace(myName, " dailybaystars", "")
  myName = Replace(myName, " baystarsfever", "")
  myName = Replace(myName, " jleague", "")
  '
  myName = Replace(myName, " lmcolumn", "")
  myName = Replace(myName, " lmpickup", "")
  '
  myName = Replace(myName, " bookbar", "")
  myName = Replace(myName, " stationery", "")
  myName = Replace(myName, " gardenstyle", "")
  '
  myName = Replace(myName, " officeblog", "")
  myName = Replace(myName, " information", "")
  myName = Replace(myName, "神奈川新聞の", "")
  myName = Replace(myName, "神奈川新聞社からの", "")
  '
  ActiveSheet.Name = myName
End Sub ' MyRssKanalocoSheetName *----*----*    *----*----*    *----*----*    *----*----*

Sub MyRssKanalocoUninetblog(Optional myDummy As Boolean)
  On Error Resume Next
  '
  Sheets("ゆにねっと uninetblog").Activate
  ActiveSheet.Name = Replace(ActiveSheet.Name, " uninetblog", "")
  '
  Sheets("ゆにねっと uninetblog 1").Activate
  ActiveSheet.Name = Replace(ActiveSheet.Name, " uninetblog 1", " インフォメーション")
  '
  Sheets("ゆにねっと uninetblog 2").Activate
  ActiveSheet.Name = Replace(ActiveSheet.Name, " uninetblog 2", " あゆの視線")
  '
  Sheets("ゆにねっと uninetblog 3").Activate
  ActiveSheet.Name = Replace(ActiveSheet.Name, " uninetblog 3", " あゆと歩こう")
  '
  On Error GoTo 0
End Sub ' MyRssKanalocoUninetblog *----*----*    *----*----*    *----*----*    *----*----*
inserted by FC2 system