如何提取网页中的数据并自动填充到VB的文本框中
我现在想使用VB提取指定网页的数据，比如说http://1x2.bet007.com/oddslist/668186.htm
这个网页中的数据！
然后，我可以选择我需要的行和需要的列的数据，导入到我文本框中！
--------------------编程问答-------------------- 在类似这个网页中：http://1x2.nowscore.com/668186.js --------------------编程问答-------------------- 首先，谢谢VBLOAD!
这是一个JS文件，需要下载，就算是下载下来后，我又该如何将里面对应的数据
自动写入我的界面的文本框中呢！？ --------------------编程问答-------------------- 下载后提取就是了。
正则或instr()、mid()函数相结合。 --------------------编程问答-------------------- OpenURL
Private Function StrFormat(s As String) As String--------------------编程问答--------------------
On Error Resume Next
Dim Buf As String
Dim StrTemp As String
Dim c As String
Dim i As Long
Dim j As Long
Dim k As Long
Dim L As Long
Buf = s
Do
L = InStr(1, Buf, "<style", vbTextCompare)
If L > 0 Then
k = InStr(L + 6, Buf, "</style>", vbTextCompare)
If k > 0 Then
Buf = Left(Buf, L - 1) + Mid(Buf, k + 8)
Else
Buf = Left(Buf, L - 1)
Exit Do
End If
Else
Exit Do
End If
Loop
Do
L = InStr(1, Buf, "<script", vbTextCompare)
If L > 0 Then
k = InStr(L + 7, Buf, "</script>", vbTextCompare)
If k > 0 Then
Buf = Left(Buf, L - 1) + Mid(Buf, k + 9)
Else
Buf = Left(Buf, L - 1)
Exit Do
End If
Else
Exit Do
End If
Loop
Buf = Replace(Buf, "&", "&")
Buf = Replace(Buf, """, Chr(34)) '替换成双引号
Buf = Replace(Buf, "<", "<")
Buf = Replace(Buf, ">", ">")
Buf = Replace(Buf, " ", "")
Buf = Replace(Buf, "<", " <")
Buf = Replace(Buf, ">", "> ")
Buf = Replace(Buf, " ", "")
Buf = Replace(Buf, Chr(26), " ")
Buf = Replace(Buf, Chr(10), " ")
Buf = Replace(Buf, Chr(9), " ")
Buf = Replace(Buf, Chr(13), " ")
Buf = LTrim(Buf)
Buf = RTrim(Buf)
'您可加入其他替换
StrTemp = ""
For i = 1 To Len(Buf)
c = Mid(Buf, i, 1)
Select Case c
Case "<"
If i <> 1 Then
StrTemp = StrTemp & Mid(Buf, j + 1, i - j - 1)
End If
Case ">"
j = i
End Select
Next i
L = Len(StrTemp)
Do
Buf = Replace(StrTemp, " ", " ")
i = Len(Buf)
If i = L Then Exit Do
L = i
StrTemp = Buf
Loop
StrFormat = Buf
End Function
Option Explicit--------------------编程问答-------------------- 学到了，下次利用这点来做论坛登录器。 --------------------编程问答-------------------- 试了一下好用。
Dim ReturnCode$
Private Sub Command1_Click()
ReturnCode = GetByWinHttp("http://1x2.nowscore.com/668186.js")
Call ResultRegExp(ReturnCode)
End Sub
Function GetByWinHttp$(ByVal GetUrl$)
On Error Resume Next
Dim XmlHttp As Object
Set XmlHttp = CreateObject("WinHttp.WinHttpRequest.5.1")
With XmlHttp
.Open "GET", GetUrl, True
.SetRequestHeader "Accept", "text/html,application/xhtml+xml,application/xml;*/*"
.SetRequestHeader "Accept-Charset", "GB2312,utf-8"
.SetRequestHeader "Keep-Alive", "115"
.Send
.WaitForResponse
GetByWinHttp = BytesToBstr(.ResponseBody, "utf-8")
GetByWinHttp = RemoveHeadTail(GetByWinHttp, "game=Array(", ");")
End With
Set XmlHttp = Nothing
End Function
Function RemoveHeadTail$(ByVal Source$, ByVal sStart$, ByVal strEnd$)
Dim m&, n&
m = InStr(1, Source, sStart)
If m <> 0 Then
n = InStr(m + Len(sStart), Source, strEnd)
If n <> 0 Then
RemoveHeadTail = Mid(Source, m + Len(sStart), n - m - Len(sStart))
Else
RemoveHeadTail = ""
End If
Else
RemoveHeadTail = ""
End If
End Function
Function BytesToBstr$(ByVal strBody As Variant, ByVal CodeBase$)
Dim objStream
Dim server
Set objStream = CreateObject("Adodb.Stream")
objStream.Type = 1
objStream.Mode = 3
objStream.Open
objStream.write strBody
objStream.Position = 0
objStream.Type = 2
objStream.Charset = CodeBase
BytesToBstr = objStream.ReadText
objStream.Close
Set objStream = Nothing
End Function
Private Sub ResultRegExp(ByVal Source$)
On Error Resume Next
Dim RegExp As Object, Matches As Object
Dim i&, j&, tem$
Set RegExp = CreateObject("VBscript.RegExp")
RegExp.Global = True
RegExp.Pattern = """(.*?)\|(.*?)\|(.*?)\|(.*?)\|(.*?)\|(.*?)\|(.*?)\|(.*?)\|(.*?)\|(.*?)\|(.*?)\|(.*?)\|(.*?)\|(.*?)\|(.*?)\|(.*?)\|(.*?)\|(.*?)\|(.*?)\|(.*?)\|(.*?),(.*?),(.*?),(.*?),(.*?),(.*?)\|(.*?)\|(.*?)\|(.*?)"""
Set Matches = RegExp.Execute(Source)
For i = 0 To Matches.Count - 1
For j = 0 To 29
tem = tem & Matches(i).SubMatches(j) & "|"
Next j
Debug.Print tem
tem = ""
Next i
End Sub
补充：VB , 网络编程
