Развлечения ради представляю небольшой RSS клиент на VBA, которые читает и парсит ленты с сайтов Shortiki.com и bash.im
PS: Bash и Shortiki в коде - это листы в книге Excel
Читалка Shortiki.com
Dim ObjHTTP As MSXML2.XMLHTTP
Dim sMsg As String
Dim sURL As String
Dim objXML As MSXML2.DOMDocument
Dim xml As String
Dim oNodeList As IXMLDOMSelection
Dim curNode As IXMLDOMNode
Dim oList As IXMLDOMSelection
Dim stepNode As IXMLDOMNode
Dim n As Long
'*************** Запрашиваем RSS ***************'
Set ObjHTTP = New MSXML2.XMLHTTP
sURL = "http://shortiki.com/rss.php"
'use this code snippet to invoke a web service which requires authentication
'ObjHTTP.Open "Post", sURL, False, "username", "password"
'We use this code snippet to invoke a web service that doesn't require any user authentication
ObjHTTP.Open "Post", sURL, False
ObjHTTP.setRequestHeader "Content-Type", "text/xml"
ObjHTTP.send
xml = ObjHTTP.responseText
'*************** Обрабатываем полученную XML ***************'
' Создаем VBA объект XML и загружаем в него XML
Set objXML = New MSXML2.DOMDocument
objXML.LoadXML (xml)
' Парсим XML
Set oNodeList = objXML.SelectNodes("//channel/item")
If oNodeList.Length - 1 > 0 Then
Shortiki.UsedRange.Clear
Shortiki.Cells(1, 1).Value = "Шортики (короткие и смешные)"
Shortiki.Cells(1, 1).Interior.Color = RGB(255, 255, 0)
End If
For n = 0 To oNodeList.Length - 1
' Получим текущий узел
Set curNode = oNodeList.Item(n)
Shortiki.Cells(n + 2, 1).Value = curNode.SelectNodes("description").Item(0).nodeTypedValue
Debug.Print Shortiki.Cells(n + 2, 1).Value
Debug.Print "-----------------------------"
Next
'Shortiki.UsedRange.AutoFit
' Очистим переменные
Set objXML = Nothing
Set ObjHTTP = Nothing
Читалка Bash.im
Dim ObjHTTP As MSXML2.XMLHTTP
Dim sMsg As String
Dim sURL As String
Dim objXML As MSXML2.DOMDocument
Dim xml As String
Dim oNodeList As IXMLDOMSelection
Dim curNode As IXMLDOMNode
Dim oList As IXMLDOMSelection
Dim stepNode As IXMLDOMNode
Dim n As Long
Dim tbash As String
'*************** Запрашиваем RSS ***************'
Set ObjHTTP = New MSXML2.XMLHTTP
sURL = "http://bash.im/rss/"
'use this code snippet to invoke a web service which requires authentication
'ObjHTTP.Open "Post", sURL, False, "username", "password"
'We use this code snippet to invoke a web service that doesn't require any user authentication
ObjHTTP.Open "Get", sURL, False
ObjHTTP.setRequestHeader "Content-Type", "text/xml"
ObjHTTP.send
xml = ObjHTTP.responseText
'*************** Обрабатываем полученную XML ***************'
' Создаем VBA объект XML и загружаем в него XML
Set objXML = New MSXML2.DOMDocument
objXML.LoadXML (xml)
' Парсим XML
Set oNodeList = objXML.SelectNodes("//channel/item")
If oNodeList.Length - 1 > 0 Then
Bash.UsedRange.Clear
Bash.Cells(1, 1).Value = "Цитатник рунета"
Bash.Cells(1, 1).Interior.Color = RGB(255, 255, 0)
End If
For n = 0 To oNodeList.Length - 1
' Получим текущий узел
Set curNode = oNodeList.Item(n)
tbash = curNode.SelectNodes("description").Item(0).nodeTypedValue
'Debug.Print quote
tbash = Replace(tbash, "
", Chr(13) & Chr(10)) tbash = Replace(tbash, """, """") Debug.Print tbash Debug.Print "-----------------------------" Bash.Cells(n + 2, 1) = tbash Next ' Очистим переменные Set objXML = Nothing Set ObjHTTP = Nothing
", Chr(13) & Chr(10)) tbash = Replace(tbash, """, """") Debug.Print tbash Debug.Print "-----------------------------" Bash.Cells(n + 2, 1) = tbash Next ' Очистим переменные Set objXML = Nothing Set ObjHTTP = Nothing
Комментариев нет:
Отправить комментарий