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 *----*----* *----*----* *----*----* *----*----*