[RESOLVED] Help me get this text!
Code:
Code:
Dim strText As String
Dim x As Long, y As Long
strText = Inet1.OpenURL("http://rscangel.org/highscores.php?skill=attack")
y = InStr(1, strText, "<td>1</td>")
If y Then
x = InStr(y + 20, strText, ">")
If x Then
y = InStr(x, strText, "</td>")
If y Then
Label22.Caption = Mid$(strText, x + 1, (y - x) - 1)
End If
End If
End If
Site's source code bit:
Code:
<td>1</td><td>nitrokyrpa</td><td>99</td><td>
I'm trying to extract 99. 99 only.
With the code above it displays "<td>99" instead of "99"
Been working with this forever! Just can't get get rid of 4 characters. :sick:
Re: Help me get this text!
Start a new project, add Inet1 and List1 to the form and paste:
Code:
Option Explicit
' move this function to a module
Public Function InStrBetween(ByRef Search As String, ByRef StringBegin As String, ByRef StringEnd As String, Optional ByVal Start As Long = 1, Optional ByVal Compare As VbCompareMethod = vbBinaryCompare) As String
Dim lngLenSea As Long, lngLenBeg As Long, lngLenEnd As Long
Dim lngBegin As Long, lngEnd As Long
Dim strSearch As String, strBegin As String, strEnd As String
' get string lengths
lngLenSea = LenB(Search)
lngLenBeg = LenB(StringBegin)
lngLenEnd = LenB(StringEnd)
' make sure we have lengths and a valid starting position
If (lngLenSea <> 0) And (lngLenBeg <> 0) And (lngLenEnd <> 0) And (Start > 0) Then
' make start a byte position
Start = ((Start - 1) * 2) + 1
' case sensitive?
If Compare = vbBinaryCompare Then
' find the starting position
lngBegin = InStrB(Start, Search, StringBegin, vbBinaryCompare)
' because InStrB finds byte positions, we have to ensure we do not get "mid character" positions
Do While ((lngBegin And 1) = 0) And (lngBegin > 0)
lngBegin = InStrB(lngBegin + lngLenBeg, Search, StringBegin, vbBinaryCompare)
Loop
If lngBegin Then
lngBegin = lngBegin + lngLenBeg
' find the ending position
lngEnd = InStrB(lngBegin, Search, StringEnd, vbBinaryCompare)
' because InStrB finds byte positions, we have to ensure we do not get "mid character" positions
Do While ((lngEnd And 1) = 0) And (lngEnd >= lngBegin)
lngEnd = InStrB(lngEnd + lngLenEnd, Search, StringEnd, vbBinaryCompare)
Loop
' make sure we have something
If lngEnd > lngBegin Then
' return the result
InStrBetween = MidB$(Search, lngBegin, lngEnd - lngBegin)
End If
End If
Else
' make upper case copies
strSearch = UCase$(Search)
strBegin = UCase$(StringBegin)
' find the starting position
lngBegin = InStrB(Start, strSearch, strBegin, vbBinaryCompare)
' because InStrB finds byte positions, we have to ensure we do not get "mid character" positions
Do While ((lngBegin And 1) = 0) And (lngBegin > 0)
lngBegin = InStrB(lngBegin + lngLenBeg, strSearch, strBegin, vbBinaryCompare)
Loop
If lngBegin Then
lngBegin = lngBegin + lngLenBeg
' make upper case copy
strEnd = UCase$(StringEnd)
' find the ending position
lngEnd = InStrB(lngBegin, strSearch, strEnd, vbBinaryCompare)
' because InStrB finds byte positions, we have to ensure we do not get "mid character" positions
Do While ((lngEnd And 1) = 0) And (lngEnd >= lngBegin)
lngEnd = InStrB(lngEnd + lngLenEnd, strSearch, strEnd, vbBinaryCompare)
Loop
' make sure we have something
If lngEnd > lngBegin Then
' return the result
InStrBetween = MidB$(Search, lngBegin, lngEnd - lngBegin)
End If
End If
End If
End If
End Function
Private Sub Form_Load()
Dim strText As String, strRows() As String
Dim x As Long, y As Long
strRows = Split(InStrBetween(Inet1.OpenURL("http://rscangel.org/highscores.php?skill=attack"), _
"<h2><center>Top 20 players for attack</center></h2><br><table width=""100%""><tr><td>Rank</td><td>Player</td><td>Level</td><td>Exp</td><tr><tr><td>", _
"</td></table>"), "</td><tr><td>")
For x = 0 To UBound(strRows)
List1.AddItem Replace(strRows(x), "</td><td>", vbTab)
Next x
End Sub
Just use Split again instead of replace if you want to store all the information :)
Re: Help me get this text!
You are almost there... try this:
Code:
Dim strText As String
Dim x As Long, y As Long
strText = Inet1.OpenURL("http://rscangel.org/highscores.php?skill=attack")
y = InStr(1, strText, "<td>1</td>")
If y Then
x = InStr(y + 20, strText, ">")
If x Then
y = InStr(x, strText, "</td>")
If y Then
Label22.Caption = Mid$(strText, x + 5, y - x - 5)
End If
End If
End If
What happend is that you get the colored part in the string:
Code:
<td>1</td><td>nitrokyrpa</td><td>99</td><td>
Where you put x+1 getting "<td>99", I put x+5, and get "99</td", so I fixed the "</td" part, modifying the (y-x)-1 into y-x-5.
Re: Help me get this text!
I don't understand what you wanna do, but this works
Code:
99 = Mid(strText, 34, 2)
Of course it will only work with this string
Re: Help me get this text!
Quote:
Originally Posted by LucianoBraatz
You are almost there... try this:
Code:
Dim strText As String
Dim x As Long, y As Long
strText = Inet1.OpenURL("http://rscangel.org/highscores.php?skill=attack")
y = InStr(1, strText, "<td>1</td>")
If y Then
x = InStr(y + 20, strText, ">")
If x Then
y = InStr(x, strText, "</td>")
If y Then
Label22.Caption = Mid$(strText, x + 5, y - x - 5)
End If
End If
End If
What happend is that you get the colored part in the string:
Code:
<td>1</td><td>nitrokyrpa</td><td>99</td><td>
Where you put
x+1 getting "<td>99", I put
x+5, and get "99</td", so I fixed the "</td" part, modifying the
(y-x)-1 into
y-x-5.
Awesome! Thanks a lot! :bigyello:
