vb 用 WebBrowser 取到网页内容的部分

Question

vb WebBrowser html
菜鸟..
-------
目的: 打开一个网页 
取到源码中所有 "target=_blank>" 和 "</A></CITE>" 之间的字符. ----- 是用户名.
赋值给一个数组.
-------
由于比较菜.. 只会用最简单的办法..
开始想把源内容都读出来放一个text控件里 再处理字符串..
可杯具的发现网页内容超出 65535 字符. 还有很多读不到..就想... 能不能直接处理完了直接显示赋了值的字符串出来.个网站搜了好多.相关贴.. 结果发现基本都是这个一贴 转来转去的.
http://blog.csdn.net/cutemouse/archive/2004/05/09/6072.aspx
这里没看到对我有用的内容..如可以..
请教 代码..

Answer 1

其他的不了解，就你说的超过65535的字符读不到的问题，我想是你处理有误，试一试这样的处理方式：If Asc(strT) <= 0 Then
            lngAsc = AscW(StrConv(strT, 128))
            If lngAsc < 0 Then
                lngAsc = lngAsc + 65536 '2^16
            End If
        Else
            lngAsc = Asc(strT)
        End If

Answer 2

strT是要处理的字符，首先判断他是否大于65535，在作相应处理。同样的道理，可以使用ChrW或chr来转换。

Answer 3

估计他是把全部 HTML 内容放到 VB 的一个 String 变量里，而VB的String变量最多能存64k的文本，
所以才出问题。你所提供的做法也是基于 strT 变量处理 Unicode 编码，而看你的名称估计也是
String 类型，无论是 Unicode 或 Ascii 在 String 类型的处理上都会受 String 类型 64k 长度
的限制，所以应该解决不了他的问题。

Answer 4

回复4楼 - -  
我不知道为什么 但是感觉应该是超过限制大小了的样子...
--------------------
就比如
http://bbs.duowan.com/thread-17408898-2-1.html
这个页面。我就想取到shoh多玩
飛飛※→伈
谭园官
billy仔~~の多
orcxhh
张徐明
落泪···
meetb
PTX-003C
超能探长
多玩游者
lakdhyc
拉拉拉舞
阉掉的番茄
白崎一护------------
不知道怎么写...

Answer 5

你的那个网页是UTF-8编码，如果要方便VB处理，最好先将UTF-8转换成Unicode再处理。
然后直接在字节数组里搜索识别相关数据位置，然后取出就可以了

Answer 6

你不该使用TextBox 你要使用RichTextBox控件

Answer 7

本帖最后由 bcrun 于 2010-11-05 07:23:14 编辑

  

Answer 8

帮你写了一个具体的实现过程Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
Destination As Any, _
Source As Any, _
ByVal Length As Long)Private Sub Command1_Click()
Dim strTemp As String
Dim strUserList As String
Dim strSearch As String
Dim lngSearchSize As Long
Dim lngStart As Long
Dim lngEnd As Long
Dim ComXMLHTTP As Object
Dim byteHTML() As Byte On Error Resume Next
strUserList = ""
strSearch = "class=""dropmenu"" onmouseover=""showMenu(this.id)"">"
lngSearchSize = LenB(StrConv(strSearch, vbFromUnicode)) Set ComXMLHTTP = CreateObject("Microsoft.XMLHTTP")
ComXMLHTTP.Open "GET", "http://bbs.duowan.com/thread-17408898-2-1.html", False
ComXMLHTTP.setRequestHeader "CONTENT-TYPE", "application/x-www-form-urlencoded"
ComXMLHTTP.Send byteHTML = ComXMLHTTP.ResponseBody
Call SaveTextFile("c:\UTF-8.txt", byteHTML, "UTF-8") byteHTML = UTF8ToUnicode(byteHTML)
Call SaveTextFile("c:\Unicode.txt", byteHTML, "Unicode") byteHTML = UnicodeToGB2312(byteHTML)
Call SaveTextFile("c:\GB2312.txt", byteHTML) lngStart = InStr_Array(0, byteHTML, strSearch)
If lngStart >= 0 Then
lngStart = lngStart + lngSearchSize
Do
lngStart = InStr_Array(lngStart, byteHTML, strSearch)
If lngStart >= 0 Then
lngStart = lngStart + lngSearchSize
lngEnd = InStr_Array(lngStart, byteHTML, "</a>")
strTemp = Mid_Array(byteHTML, lngStart, lngEnd - lngStart)
lngStart = lngEnd
strUserList = strUserList & strTemp & vbCrLf
End If
Loop While lngStart >= 0
End If
Text1.Text = strUserList
End SubFunction UTF8ToUnicode(ByRef funUTF8() As Byte) As Byte()
Dim lngLength As Long
Dim lngLengthB As Long
Dim lngUTF8Char As Long
Dim intWChar As Integer
Dim byteTemp As Byte
Dim byteBit As Byte
Dim byteUnicode() As Byte
Dim lngUTF8Count As Long
Dim i As Long
Dim j As Long On Error Resume Next
lngLengthB = 0 lngLength = UBound(funUTF8) + 1
If Err.Number <> 0 Then
Err.Clear
Exit Function
End If For i = 0 To lngLength - 1
lngUTF8Count = 0
byteTemp = funUTF8(i)
For j = 1 To 7
byteBit = Int(byteTemp / (2 ^ (8 - j)))
byteBit = byteBit And 1
If byteBit = 1 Then
lngUTF8Count = lngUTF8Count + 1
Else
Exit For
End If
Next j If lngUTF8Count < 2 Or lngUTF8Count > 3 Then
If lngLengthB = 0 Then
lngLengthB = 2
ReDim byteUnicode(lngLengthB - 1)
Else
lngLengthB = lngLengthB + 2
ReDim Preserve byteUnicode(lngLengthB - 1)
End If
byteUnicode(lngLengthB - 2) = byteTemp
Else
For j = 0 To lngUTF8Count - 1
byteTemp = funUTF8(i + j)
If j = 0 Then
byteTemp = byteTemp And ((2 ^ (8 - (lngUTF8Count + 1))) - 1)
lngUTF8Char = byteTemp
Else
byteTemp = byteTemp And &H3F
lngUTF8Char = lngUTF8Char * &H40
lngUTF8Char = lngUTF8Char Or byteTemp
End If
Next j
If lngLengthB = 0 Then
lngLengthB = 2
ReDim byteUnicode(lngLengthB - 1)
Else
lngLengthB = lngLengthB + 2
ReDim Preserve byteUnicode(lngLengthB - 1)
End If
byteUnicode(lngLengthB - 2) = lngUTF8Char And 255
byteUnicode(lngLengthB - 1) = Int(lngUTF8Char / (2 ^ 8)) And 255
i = i + (lngUTF8Count - 1)
End If
If i > (lngLength - 1) Then
Exit For
End If
Next i
UTF8ToUnicode = byteUnicode
End FunctionFunction UnicodeToGB2312(ByRef funUnicode() As Byte) As Byte()
Dim lngLength As Long
Dim lngLengthB As Long
Dim byteGB2312() As Byte
Dim i As Long
Dim intWChar As Integer
Dim intChar As Integer On Error Resume Next
lngLengthB = 0 lngLength = UBound(funUnicode) + 1
If Err.Number <> 0 Then
Err.Clear
Exit Function
End If
lngLength = lngLength / 2 For i = 0 To lngLength - 1
CopyMemory intWChar, funUnicode(i * 2), 2
intChar = Asc(StrConv(ChrW(intWChar), vbNarrow))
If intChar < 0 Or intChar > 255 Then
If lngLengthB = 0 Then
lngLengthB = 2
ReDim byteGB2312(lngLengthB - 1)
byteGB2312(lngLengthB - 1) = intChar And 255
byteGB2312(lngLengthB - 2) = Int(CLng("&H" & Hex(intChar)) / (2 ^ 8)) And 255
Else
lngLengthB = lngLengthB + 2
ReDim Preserve byteGB2312(lngLengthB - 1)
byteGB2312(lngLengthB - 1) = intChar And 255
byteGB2312(lngLengthB - 2) = Int(CLng("&H" & Hex(intChar)) / (2 ^ 8)) And 255
End If
Else
If lngLengthB = 0 Then
lngLengthB = 1
ReDim byteGB2312(lngLengthB - 1)
byteGB2312(lngLengthB - 1) = CByte(intChar)
Else
lngLengthB = lngLengthB + 1
ReDim Preserve byteGB2312(lngLengthB - 1)
byteGB2312(lngLengthB - 1) = CByte(intChar)
End If
End If
Next i
UnicodeToGB2312 = byteGB2312
End FunctionFunction InStr_Array(ByVal funStart As Long, _
ByRef funBytes() As Byte, _
ByVal funFind As String) As Long
Dim byteFindArray() As Byte
Dim lngBytesCount As Long
Dim lngFindCount As Long
Dim lngIsFind As Long
Dim i As Long
Dim j As Long

On Error Resume Next
InStr_Array = -1
If Len(funFind) = 0 Then
Exit Function
End If
lngBytesCount = UBound(funBytes)
If Err.Number <> 0 Then
Err.Clear
Exit Function
End If
byteFindArray = StrConv(funFind, vbFromUnicode)
Open "C:\S.txt" For Binary As #1
Put #1, 1, byteFindArray
Close #1
lngFindCount = UBound(byteFindArray)
If funStart + lngFindCount > lngBytesCount Then
Exit Function
End If
For i = funStart To lngBytesCount
lngIsFind = 1
If i >= 4160 Then
i = i
End If
For j = 0 To lngFindCount
If funBytes(i + j) < &HA0 And byteFindArray(j) < &HA0 Then
If UCase(Chr(funBytes(i + j))) <> UCase(Chr(byteFindArray(j))) Then
lngIsFind = 0
Exit For
End If
Else
If funBytes(i + j) <> byteFindArray(j) Then
lngIsFind = 0
Exit For
End If
End If
Next j
If lngIsFind = 1 Then
InStr_Array = i
Exit For
End If
Next i
End FunctionFunction Mid_Array(ByRef funBytes() As Byte, _
ByVal funStart As Long, _
ByVal funCount As Long) As String
Dim byteRead() As Byte
Dim lngBytesCount As Long On Error Resume Next
Mid_Array = ""
lngBytesCount = UBound(funBytes)
If Err.Number <> 0 Then
Err.Clear
Exit Function
End If
If funStart + funCount > lngBytesCount Then
Exit Function
End If
ReDim byteRead(funCount - 1)
CopyMemory byteRead(0), funBytes(funStart), funCount
Mid_Array = StrConv(byteRead, vbUnicode)
End FunctionSub SaveTextFile(ByVal funFileName As String, _
ByRef funBytes() As Byte, _
Optional ByVal funMode As String = "GB2312")
Dim fs As Integer
On Error Resume Next
fs = FreeFile
Open funFileName For Output As #fs
If Err.Number <> 0 Then
MsgBox "错误：" & Err.Number & "，" & Err.Description, 16, "错误"
Err.Clear
Exit Sub
End If
Close #fs
fs = FreeFile
Open funFileName For Binary As #fs
Select Case UCase(funMode)
Case "GB2312":
Put #1, 1, funBytes
Case "UNICODE":
Put #1, 1, CByte(&HFF)
Put #1, 2, CByte(&HFE)
Put #1, 3, funBytes
Case "UTF-8":
Put #1, 1, CByte(&HEF)
Put #1, 2, CByte(&HBB)
Put #1, 3, CByte(&HBF)
Put #1, 4, funBytes
End Select
Close #fs
End Sub

Answer 9

这个过程即使上 GB 的 HTM 都能解释，呵呵

Answer 10

OMG! ....
SupermanKing 辛苦了！！！！！！ 
无以言表..
这就去测试..

Answer 11

cbm666 老师的那个   对百度的话可以用 - - 
但是我换我的那个 . 就出乱码了..

Answer 12

10# 测试可用.
谢谢 SupermanKing .. 谢谢..
虽然我不知道那大部分代码都是什么意思..
这就去F8跑跑看... 
其他功能我继续自己搞先...
实在搞不出来的话再来请教...再次感谢SupermanKing ...

Answer 13

我发布了一个注译版本到我的博客，你可以去看看
http://blog.csdn.net/SupermanKing/archive/2010/11/05/5989227.aspx