Sub MyRssVbalab()
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Rem VBA質問箱掲示板RSS取り込み処理
  Rem 作譜:Hitrock Camellia Shinopy
  Rem 言語:Excel VBA
  Rem 機能...
  Rem   指定したサイトのRSSを取り込みする。
  Rem   VBA質問箱(http://www.vbalab.net/)のRSSを取り込み、シート上に書き込みする。
  Rem 注記...
  Rem   1. MyRssVbalabを起動して実行。
  Rem   2. 初回実行前に「myFile」に取り込むRSSデータの保存先を指定すること。
  Rem 履歴...
  Rem   第01版:2007/06/09:作成。
  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\MyRssVbalab\MyRssVbalab.xml"
  Call MyRssVbalabMySite(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 *----*----*    *----*----*    *----*----*    *----*----*
  '
MyRssVbalabSubEntry:
  c = 0
  For Each myURL In myArray
    c = c + 1
    myStatusBar = c * 100 \ myMax & "%  " & c & "/" & myMax & "件 "
    Application.StatusBar = "MyRssVbalab" & ":" & myStatusBar
    '
    Columns("A:A").Select
    With Selection
      .ColumnWidth = 40
      .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 MyRssVbalabMyXmlDoc(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 = 100
    On Error Resume Next
    ActiveSheet.Next.Select
    On Error GoTo 0
    DoEvents
  Next ' myURL
  '
  Sheets(mySheetFirst).Activate
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
MyRssVbalabSubExit:
  Application.ScreenUpdating = True
  Kill myFile
  myText = "処理が終了しました。"
  Application.StatusBar = "MyRssVbalab: " & myText & " " & Now()
  Application.Speech.Speak myText, False
End Sub ' MyRssVbalab *----*----*    *----*----*    *----*----*    *----*----*

Sub MyRssVbalabMySite(mySite As String)
  mySite = "http://www.vbalab.net/vbaqa/c-board.cgi?cmd=r2s;id=excel" '
  mySite = mySite & "," & "http://www.vbalab.net/vbaqa/c-board.cgi?cmd=r2s;id=access" '
  mySite = mySite & "," & "http://www.vbalab.net/vbaqa/c-board.cgi?cmd=r2s;id=word" '
  mySite = mySite & "," & "http://www.vbalab.net/vbaqa/c-board.cgi?cmd=r2s;id=" '
  mySite = mySite & "," & "http://www.vbalab.net/vbaqa/c-board.cgi?cmd=r2s;id=FAQ" '
End Sub ' MyRssVbalabMySite *----*----*    *----*----*    *----*----*    *----*----*

Sub MyRssVbalabMyXmlDoc(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
    '
    Select Case i
      Case 1
        Cells(i, 1).Select
        ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=myLink(i - 1).Text, TextToDisplay:=myTitle(i - 1).Text & " " & myDescript(i - 1).Text
        Call MyRssVbalabSheetName
      Case Else
        Cells(i, 1).Select
        ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=myLink(i - 1).Text, TextToDisplay:=myTitle(i - 1).Text
        If Not (myDescript(i - 1) Is Nothing) Then
          Cells(i, 2).Value = myDescript(i - 1).Text
        End If
    End Select
    DoEvents
  Next ' i
End Sub ' MyRssVbalabMyXmlDoc *----*----*    *----*----*    *----*----*    *----*----*

Sub MyRssVbalabSheetName(Optional myDummy As Boolean)
  Dim myName As String
  '
  myName = Cells(1, 1).Text
  Select Case True
    Case InStr(myName, "Excel VBA質問箱") > 0
      myName = "Excel VBA質問箱"
    Case InStr(myName, "Access VBA質問箱") > 0
      myName = "Access VBA質問箱"
    Case InStr(myName, "Word VBA質問箱") > 0
      myName = "Word VBA質問箱"
    Case InStr(myName, "石鹸箱") > 0
      myName = "石鹸箱"
    Case InStr(myName, "目安箱") > 0
      myName = "目安箱"
  End Select
  ActiveSheet.Name = myName
End Sub ' MyRssVbalabSheetName *----*----*    *----*----*    *----*----*    *----*----*
inserted by FC2 system