Husk en List1 (ListBox)
Option Explicit
Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
Private Declare Function DeleteUrlCacheEntry Lib "Wininet.dll" Alias "DeleteUrlCacheEntryA" (ByVal lpszUrlName As String) As Long
Private Const ERROR_SUCCESS As Long = 0
Private Const BINDF_GETNEWESTVERSION As Long = &H10
Private Const INTERNET_FLAG_RELOAD As Long = &H80000000
Private Function DownloadFile(sSourceUrl As String, sLocalFile As String) As Boolean
DownloadFile = URLDownloadToFile(0&, sSourceUrl, sLocalFile, BINDF_GETNEWESTVERSION, 0&) = ERROR_SUCCESS
End Function
Private Function DownloadString(sSourceUrl As String) As String
Dim intFree As Integer
Dim sLocalFile As String
sLocalFile = "C:\dltemp.txt"
Call DeleteUrlCacheEntry(sSourceUrl)
If DownloadFile(sSourceUrl, sLocalFile) = True Then
intFree = FreeFile
Open sLocalFile For Input As #intFree
DownloadString = Input$(LOF(intFree), intFree)
Close #intFree
Kill sLocalFile
End If
End Function
Private Sub Form_Load()
Dim i As Integer
Dim strHtml As String
Dim strName As String
Dim arrXps As Variant
Dim arrRanks As Variant
Dim arrLevels As Variant
Dim arrNames As Variant
strHtml = DownloadString("
http://hiscore-web.runescape.com/aff/runescape/hiscores.html")
strHtml = Replace(strHtml, Chr$(10), vbCrLf)
'Text1.Text = strHtml
arrRanks = Split(Replace(FindTags(strHtml, "<b>Rank</b><br>" & vbCrLf, vbCrLf & "</td>"), "<br>", ""), vbCrLf)
arrLevels = Split(Replace(FindTags(strHtml, "<b>Level</b><br>" & vbCrLf, vbCrLf & "</td>"), "<br>", ""), vbCrLf)
arrXps = Split(Replace(FindTags(strHtml, "<b>XP</b> <br>" & vbCrLf, vbCrLf & "</td>"), "<br>", ""), vbCrLf)
strName = FindTags(strHtml, "<b>Name</b><br>" & vbCrLf, vbCrLf & "</td>")
arrNames = ArrayFindTags(strName, "class=c" & vbCrLf & ">", "</a>")
For i = LBound(arrNames) To UBound(arrNames)
List1.AddItem "(" & arrRanks(i) & ") " & arrNames(i) & " Level:" & arrLevels(i) & " XP:" & arrXps(i)
Next
End Sub
Public Function FindTags(strData As String, strTag1 As String, strTag2 As String) As String
Dim intStart As Long
Dim intEnd As Long
intStart = InStr(1, strData, strTag1, vbTextCompare)
If intStart > 0 Then
intStart = (intStart + Len(strTag1))
intEnd = InStr(intStart, strData, strTag2, vbTextCompare)
If intEnd > 0 Then
FindTags = Mid$(strData, intStart, (intEnd - intStart))
End If
End If
End Function
Public Function ArrayFindTags(strData As String, strTag1 As String, strTag2 As String) As Variant
Dim intEnd As Long
Dim intStart As Long
Dim arrTags() As String
Dim intTagsCount As Integer
intStart = 1
Do While intStart
intStart = InStr(intStart, strData, strTag1, vbTextCompare)
If intStart > 0 Then
intStart = (intStart + Len(strTag1))
intEnd = InStr(intStart, strData, strTag2, vbTextCompare)
If intEnd > 0 Then
ReDim Preserve arrTags(0 To intTagsCount) As String
arrTags(intTagsCount) = Mid$(strData, intStart, (intEnd - intStart))
intTagsCount = (intTagsCount + 1)
End If
End If
Loop
If intTagsCount > 0 Then
ArrayFindTags = arrTags
Else
ArrayFindTags = Array()
End If
End Function
Ny bruger
Nybegynder
Opret
Preview
