|
|
Jen la programo-funkcio Macro de Microsoft Excel por aŭtomate listi la RSS-on sur la Sheet-on pri la BBS k. a. de kelkaj WWW-ejoj.
Vi povos facile rigardi ties renovigojn.
Jene:
Sub MyEoRss()
Rem *----*----* *----*----* *----*----* *----*----*
Rem エスペラント関係RSS取り込み処理
Rem 作譜：Hitrock Camellia Shinopy
Rem 言語：Excel VBA
Rem 機能...
Rem 指定したRSSを取り込みする。
Rem 注記...
Rem 1. MyEoRssを起動して実行。
Rem 2. 実行時に、マイドキュメント内に一時ファイル「\MyEoRss.xml」を作る。
Rem 2. 実行中は、ステータスバーに処理状況を表示する。
Rem 履歴...
Rem 第01版：2010/09/25：作成。
Rem 第02版：2012/03/29：一部の「Variant」を「Object」に変更。
Rem *----*----* *----*----* *----*----* *----*----*
Dim i As Long
Dim c As Long
Dim myMax As Long
Dim mySheetFirst As Long
Dim myShell As Object ' IWshShell3
'
Dim myArray As Variant
Dim mySite As String
Dim myURL As Variant
Dim myText As String
Dim myStatusBar As String
'
Dim myHTTP As Object ' IXMLHTTPRequest
Dim myStream As Object ' Stream
Dim myFile As String
'
Dim myFileValue As Boolean
Dim myXmlDoc As Object
Rem *----*----* *----*----* *----*----* *----*----*
'
Set myShell = CreateObject("WScript.Shell")
Rem 保存先フォルダ｡
myFile = myShell.Specialfolders("MyDocuments") ' マイドキュメント
myFile = myFile & "\MyEoRss.xml"
Call MyEoRssMySite(mySite)
'
myArray = Split(mySite, ",")
myMax = UBound(myArray) + 1
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 *----*----* *----*----* *----*----* *----*----*
'
MyEoRssSubEntry:
c = 0
For Each myURL In myArray
c = c + 1
myStatusBar = c * 100 \ myMax & "% " & c & "/" & myMax & "件 "
Application.StatusBar = "MyEoRss" & "：" & myStatusBar
'
Columns("A:A").Select
With Selection
.ColumnWidth = 50
.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 MyEoRssMyXmlDoc(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
Rem *----*----* *----*----* *----*----* *----*----*
'
MyEoRssSubExit:
Application.ScreenUpdating = True
On Error Resume Next
Kill myFile
On Error GoTo 0
myText = "処理が終了しました。"
Application.StatusBar = "MyEoRss: " & myText & " " & Now()
Application.Speech.Speak myText, False
'
Sheets(mySheetFirst).Activate
ActiveWindow.Activate
Beep
End Sub ' MyEoRss *----*----* *----*----* *----*----* *----*----*
Sub MyEoRssMyXmlDoc(myXmlDoc As Object, myFile As String)
Dim myTitle As Object
Dim myLink As Object
Dim myDescript As Object
'
Dim i As Long
Dim j As Long
Dim myText As String
Dim myStatusBar As String
'
Dim myRegExp As Object ' VBScript_RegExp_55.RegExp
Rem *----*----* *----*----* *----*----* *----*----*
'
Set myTitle = myXmlDoc.selectNodes("//title")
Set myLink = myXmlDoc.selectNodes("//link")
Set myDescript = myXmlDoc.selectNodes("//description")
'
Set myRegExp = CreateObject("VBScript.RegExp") ' New VBScript_RegExp_55.RegExp
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
myText = myTitle(i - 1).Text & " " & myDescript(i - 1).Text
Call MyEoRssReplace(myText, myRegExp)
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=myLink(i - 1).Text, TextToDisplay:=myText
Call MyEoRssSheetName
Case Else
Cells(i, 1).Select
myText = myTitle(i - 1).Text
Call MyEoRssReplace(myText, myRegExp)
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=myLink(i - 1).Text, TextToDisplay:=myText
'
Select Case ActiveSheet.Name
Case "名古屋エスペラント会"
j = i - 2
Case Else
j = i - 1
End Select
'
If Not (myDescript(j) Is Nothing) Then
Cells(i, 2).Value = Cells(i, 2).Value & " " & myDescript(j).Text
myText = Cells(i, 2).Value
Call MyEoRssReplace(myText, myRegExp)
Cells(i, 2).Value = myText
End If
End Select
DoEvents
Next ' i
'
Set myRegExp = Nothing
End Sub ' MyEoRssMyXmlDoc *----*----* *----*----* *----*----* *----*----*
Sub MyEoRssReplace(myText As String, myRegExp As Object)
Dim myMatches As Object ' MatchCollection
Dim myMatch As Object ' Match
Dim myVal As String
'
myText = Replace(myText, " ", " ") ' 空白
myText = Replace(myText, "&quot;", Chr(34))
myText = Replace(myText, """, Chr(34))
myText = Replace(myText, "&", "&")
myText = Replace(myText, "<", "<")
myText = Replace(myText, ">", ">")
myText = Replace(myText, "<br />", "<br>")
myText = Replace(myText, vbLf, "<br>")
myText = Replace(myText, "<p>", "")
'
With myRegExp
.Pattern = "&#\d{3,5};" ' パターンを設定
.IgnoreCase = False ' 大文字と小文字を区別する
.Global = True ' 文字列全体を検索
.MultiLine = False
If .Test(myText) = True Then
Set myMatches = .Execute(myText)
For Each myMatch In myMatches
myVal = Replace(myMatch.Value, "&#", "")
myVal = Replace(myVal, ";", "")
myText = Replace(myText, myMatch.Value, ChrW(Val(myVal)))
DoEvents
Next ' myMatch
End If
End With
'
myText = Replace(myText, "<br>", vbLf)
'
Set myMatches = Nothing
End Sub ' MyEoRssReplace *----*----* *----*----* *----*----* *----*----*
Sub MyEoRssMySite(mySite As String)
mySite = "http://6607.teacup.com/helesp/bbs/rss40.xml" ' 北海道エスペラント連盟
mySite = mySite & "," & "http://6002.teacup.com/esplerno/bbs/rss40.xml" ' 北海道エスペラント連盟 エスペラント学習の交流掲示板
mySite = mySite & "," & "http://archive.mag2.com/0000024895/rss10.xml" ' 北海道エスペラント連盟メルマガ
mySite = mySite & "," & "http://archive.mag2.com/0000185468/rss10.xml" ' 中四国エスペラント連盟メルマガ
mySite = mySite & "," & "http://hukuiesperanto.bbs.fc2.com/rss/" ' 福井エスペラント会
mySite = mySite & "," & "http://8223.teacup.com/toer/bbs/rss40.xml" ' 所沢エスペラント会
mySite = mySite & "," & "http://suita.chu.jp/index.php?cmd=rss&ver=1.0" ' 吹田エスペラント会
Rem mySite = mySite & "," & "http://6013.teacup.com/ies21jp/bbs/rss20.xml" ' 池袋エスペラント会（休眠中）
Rem mySite = mySite & "," & "http://blog.livedoor.jp/esperanto_nagoja/index.rdf" ' 名古屋エスペラント会（休眠中）
'
mySite = mySite & "," & "http://twitter.com/statuses/user_timeline/191828611.rss" ' JEI Twitter
mySite = mySite & "," & "http://twitter.com/statuses/user_timeline/190257678.rss" ' 関西エスペラント連盟 Twitter
mySite = mySite & "," & "http://twitter.com/statuses/user_timeline/225032937.rss" ' 日本青年エスペラント連絡会(JEJ) Twitter
'
mySite = mySite & "," & "http://botd.wordpress.com/topposts-eo.xml" ' WordPressブログ Esperanto
mySite = mySite & "," & "http://archive.mag2.com/0000059458/rss10.xml" ' 覚えようエスペラント単語"
mySite = mySite & "," & "http://archive.mag2.com/0000165838/rss10.xml" ' 聖書で学ぶエスペラント語、２日で１節
End Sub ' MyEoRssMySite *----*----* *----*----* *----*----* *----*----*
Sub MyEoRssSheetName(Optional myDummy As Boolean)
Dim myName As String
'
myName = Cells(1, 1).Text
'
Select Case True
Case InStr(myName, "北海道エスペラント連盟の第2掲示板") > 0
myName = "学習の交流掲示板"
Case InStr(myName, "北海道") > 0
myName = "北海道エスペラント連盟"
Case InStr(myName, "国際共通語 Ｅｓｐｅｒａｎｔｏ") > 0
myName = "HEL メルマガ"
Case InStr(myName, "中四国だより") > 0
myName = "中四国だより"
Case InStr(myName, "HUKUI") > 0
myName = "福井エスペラント会"
Case InStr(myName, "所沢") > 0
myName = "所沢エスペラント会"
Case InStr(myName, "吹田") > 0
myName = "吹田エスペラント会"
Case InStr(myName, "池袋") > 0
myName = "池袋エスペラント会"
Case InStr(myName, "esperanto_nagoja") > 0
myName = "名古屋エスペラント会"
'
Case InStr(myName, "Twitter / esperanto_info") > 0
myName = "JEI Twitter"
Case InStr(myName, "Twitter / esperanto_kleg") > 0
myName = "KLEG Twitter"
Case InStr(myName, "JEJ") > 0
myName = "JEJ Twitter"
'
Case InStr(myName, "WordPress.com") > 0
myName = "WordPress EO"
Case InStr(myName, "覚えようエスペラント単語") > 0
myName = "覚えようエスペラント単語"
Case InStr(myName, "聖書で学ぶエスペラント語、２日で１節") > 0
myName = "聖書エス語"
End Select
'
ActiveSheet.Name = myName
End Sub ' MyEoRssSheetName *----*----* *----*----* *----*----* *----*----*
|
|
