Tipp 0524 RSS-Feeds auslesen
Autor/Einsender:
Datum:
  Christof Heymann
01.12.2006
Entwicklungsumgebung:   VB 6
Dieser Tipp ermöglicht es mit Hilfe der Microsoft XML-Library RSS-Feeds, die im Internet bereitgestellt werden, auszulesen und entsprechend darzustellen. Dazu wurden alle notwendigen Funktionen in einer Klasse zusammengefasst.
Code im Codebereich des Moduls
 
Option Explicit

Private Declare Function InternetOpen Lib "wininet" Alias _
        "InternetOpenA" (ByVal sAgent As String, ByVal _
        lAccessType As Long, ByVal sProxyName As String, ByVal _
        sProxyBypass As String, ByVal lFlags As Long) As Long

Private Declare Function InternetCloseHandle Lib "wininet" _
        (ByVal hInet As Long) As Integer

Private Declare Function InternetReadFile Lib "wininet" _
        (ByVal hFile As Long, ByVal sBuffer As String, ByVal _
        lNumBytesToRead As Long, lNumberOfBytesRead As Long) _
        As Integer

Private Declare Function InternetOpenUrl Lib "wininet" Alias _
        "InternetOpenUrlA" (ByVal hInternetSession As Long, _
        ByVal lpszUrl As String, ByVal lpszHeaders As String, _
        ByVal dwHeadersLength As Long, ByVal dwFlags As Long, _
        ByVal dwContext As Long) As Long

Private Declare Function InternetQueryDataAvailable Lib _
        "wininet.dll" (ByVal hFile As Long, _
        ByRef lpdwNumberOfBytesAvailable As Long, _
        ByVal dwFlags As Long, _
        ByVal dwContext As Long) As Boolean

Private Const INTERNET_OPEN_TYPE_DIRECT As Long = 1
Private Const INTERNET_FLAG_RELOAD = &H80000000

Private strChannel()        As String
Private strURLS()           As String
Private strDescriptions()   As String
Private strTitles()         As String
Private strVersion          As String
Private strXML              As String
Private strURL              As String
Private lngCount            As Long
Private hInternet           As Long
Private hFile               As Long

Public Property Get Channel() As String()
  Channel = strChannel
End Property

Public Property Get URLs() As String()
  URLs = strURLS
End Property

Public Property Get Descriptions() As String()
  Descriptions = strDescriptions
End Property

Public Property Get Titles() As String()
  Titles = strTitles
End Property

Public Property Get XML() As String
  XML = strXML
End Property

Public Property Get Version() As String
  Version = strVersion
End Property

Public Sub GetRSSFromURL(sUrl As String)
  Call Evaluate(GetString(sUrl))
End Sub

Public Sub GetRSSFromString(sText As String)
  Call Evaluate(sText)
End Sub

Public Property Get Count() As Long
  Count = lngCount
End Property

Private Sub Evaluate(strContent As String)
  Dim objXML          As MSXML2.FreeThreadedDOMDocument
  Dim objNode         As MSXML2.IXMLDOMNode
  Dim objItem         As MSXML2.IXMLDOMNode
  Dim objItemList     As MSXML2.IXMLDOMNodeList
  Dim objVersion      As MSXML2.IXMLDOMNode
  Dim objVersionList  As MSXML2.IXMLDOMNodeList
  Dim objChannel      As MSXML2.IXMLDOMNode
  Dim objChannelList  As MSXML2.IXMLDOMNodeList

  Dim i   As Long

  Set objXML = New MSXML2.FreeThreadedDOMDocument

  With objXML
    .async = True
    .validateOnParse = True
    If .loadXML(strContent) = True Then
       Set objItemList = .getElementsByTagName("item")
       Set objVersionList = .getElementsByTagName("rss")
       Set objChannelList = .getElementsByTagName("channel")
    Else
       Exit Sub
    End If
  End With

  For Each objVersion In objVersionList
    If objVersion.Attributes(0).Text <> "" Then
       strVersion = objVersion.Attributes(0).Text
    Else
       strVersion = "Versionsnummer nicht vorhanden!"
    End If
  Next

  ReDim strChannel(0 To 2)
  For Each objChannel In objChannelList
    For Each objNode In objChannel.childNodes
      Select Case objNode.nodeName
        Case "title"
           strChannel(0) = TransformString(objNode.Text)
        Case "link"
           strChannel(1) = objNode.Text
        Case "description"
           strChannel(2) = TransformString(objNode.Text)
      End Select
    Next objNode
  Next objChannel

  i = 0
  For Each objItem In objItemList
    i = i + 1
    ReDim Preserve strTitles(i)
    ReDim Preserve strURLS(i)
    ReDim Preserve strDescriptions(i)

    For Each objNode In objItem.childNodes
      Select Case objNode.nodeName
        Case "title"
          strTitles(i - 1) = TransformString(objNode.Text)
        Case "link"
          strURLS(i - 1) = objNode.Text
        Case "description"
          strDescriptions(i - 1) = TransformString(objNode.Text)
      End Select
    Next objNode
  Next objItem

  ReDim Preserve strTitles(UBound(strTitles()) - 1)
  ReDim Preserve strURLS(UBound(strURLS()) - 1)
  ReDim Preserve strDescriptions(UBound(strDescriptions()) - 1)

  strXML = objXML.XML
  lngCount = i - 1

  Set objXML = Nothing
  Set objItem = Nothing
  Set objItemList = Nothing
  Set objVersion = Nothing
  Set objVersionList = Nothing
  Set objChannel = Nothing
  Set objChannelList = Nothing
End Sub

Private Function GetString(sUrl As String) As String
  Dim Result      As Long
  Dim mBuffer     As String
  Dim mLength     As Long
  Dim mBytes      As Long
  Dim mBytesRead  As Long

  hInternet = InternetOpen( _
        App.EXEName, INTERNET_OPEN_TYPE_DIRECT, vbNullString, _
        vbNullString, 0)
  hFile = InternetOpenUrl(hInternet, sUrl, vbNullString, 0, _
        INTERNET_FLAG_RELOAD, 0)

  mLength = 65000
  mBuffer = Space(mLength)

  Result = InternetReadFile(hFile, mBuffer, mLength, mBytesRead)
  Call InternetCloseHandle(hFile)
  Call InternetCloseHandle(hInternet)

  mBuffer = Left$(mBuffer, mBytesRead)
  GetString = mBuffer
End Function

Private Function TransformString(sText As String) As String
  sText = Replace(sText, "ä", "ä")
  sText = Replace(sText, "ü", "ü")
  sText = Replace(sText, "Ä", "Ä")
  sText = Replace(sText, "ß", "ß")
  sText = Replace(sText, "ö", "ö")
  sText = Replace(sText, "Ö", "Ö")
  sText = Replace(sText, "€", "€")
  sText = Replace(sText, "&amp;", "&")
  sText = Replace(sText, "&quot;", Chr$(34))
  sText = Replace(sText, "&auml;", "ä")
  sText = Replace(sText, "&Auml;", "Ä")
  sText = Replace(sText, "&ouml;", "ö")
  sText = Replace(sText, "&Ouml;", "Ö")
  sText = Replace(sText, "&uuml;", "ü")
  sText = Replace(sText, "&Uuml;", "Ü")
  sText = Replace(sText, "&szlig;", "ß")
  sText = Replace(sText, "&gt;", ">")
  sText = Replace(sText, "&lt;", "<")

  TransformString = sText
End Function
 
Code im Codebereich der Form
 
Option Explicit

Private RSS1 As clsRSS

Private Sub Command1_Click()
  Dim sTitles() As String
  Dim sUrls() As String
  Dim sDescription() As String
  Dim sChannel() As String
  Dim Item As ComctlLib.ListItem
  Dim i As Long

  Set RSS1 = New clsRSS
  MousePointer = vbHourglass
  Call RSS1.GetRSSFromURL( _
        "http://tomshardware.thgweb.de/headlines.rss")
  MousePointer = vbNormal

  sTitles = RSS1.Titles
  sUrls = RSS1.URLs
  sDescription = RSS1.Descriptions
  sChannel = RSS1.Channel

  With ListView1
    .View = lvwReport
    .ColumnHeaders.Clear
    .ColumnHeaders.Add , , "Titel", 3500
    .ColumnHeaders.Add , , "Beschreibung", 2100
    .ColumnHeaders.Add , , "Url", 2500

    .ListItems.Clear
    .ListItems.Add , , "Version: " & RSS1.Version
    .ListItems.Add , , "Channel - Titel: " & sChannel(0)
    .ListItems.Add , , "Channel - URL: " & sChannel(1)
    .ListItems.Add , , "Channel - Beschreibung: " & sChannel(2)
    .ListItems.Add , , ""
  End With

  For i = LBound(sTitles()) To UBound(sTitles())
    Set Item = ListView1.ListItems.Add(, , sTitles(i))
    Item.SubItems(1) = sDescription(i)
    Item.SubItems(2) = sUrls(i)
  Next i
End Sub
 
Hinweis
Um diesen Tipp ausführen zu können, muss ein Verweis auf die Microsoft XML-Library in das Projekt eingebunden werden.

Windows-Version
95
98
ME
NT
2000
XP
Vista
Win 7
VB-Version
VBA 5
VBA 6
VB 4/16
VB 4/32
VB 5
VB 6


Download  (5,3 kB) Downloads bisher: [ 419 ]

Vorheriger Tipp Zum Seitenanfang Nächster Tipp

Startseite | Projekte | Tutorials | API-Referenz | VB-/VBA-Tipps | Komponenten | Bücherecke | VB/VBA-Forum | VB.Net-Forum | DirectX-Forum | Foren-Archiv | DirectX | VB.Net-Tipps | Chat | Spielplatz | Links | Suchen | Stichwortverzeichnis | Feedback | Impressum

Seite empfehlen Bug-Report
Letzte Aktualisierung: Sonntag, 15. Mai 2011