|
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, "&", "&")
sText = Replace(sText, """, Chr$(34))
sText = Replace(sText, "ä", "ä")
sText = Replace(sText, "Ä", "Ä")
sText = Replace(sText, "ö", "ö")
sText = Replace(sText, "Ö", "Ö")
sText = Replace(sText, "ü", "ü")
sText = Replace(sText, "Ü", "Ü")
sText = Replace(sText, "ß", "ß")
sText = Replace(sText, ">", ">")
sText = Replace(sText, "<", "<")
TransformString = sText
End Function
|
|