VB分析超过64K的网页内容（基于XMLHTTP和字节数组处理）
'****************************************************************************************************
'
' WEB Page Read Program
' WEBRead.frm
' 1.0.0
'Dependencies.. XMLHTTP Object
' Dynamic read URL html data
' Zhou Wen Xing
' Nov, 5nd 2010
'CSDN Accounts..SupermanKing
'
'Copyright (c) 2008 by www.rljy
'LiuZhou city, China
'
'****************************************************************************************************
'====================================================================================================
' API function defining ( API 函数定义 )
'====================================================================================================
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
Destination As Any, _
Source As Any, _
ByVal Length As Long)
'====================================================================================================
' Form event dispose process ( 窗体基本的事件处理过程 )
'====================================================================================================
'==================== 点击按钮1产生的事件 ====================
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 ' 访问网页的 XMLHTTP 对象
Dim byteHTML() As Byte ' 存储网页内容的字节流数组变量
On Error Resume Next ' 开始设置错误陷阱，防止程序发生意外错误而崩溃
'==================== 初始化变量 ====================
strUserList = ""
strSearch = "class=""dropmenu"" onmouseover=""showMenu(this.id)"">"
lngSearchSize = LenB(StrConv(strSearch, vbFromUnicode))
'==================== 开始下载指定 URL 的数据内容 ====================
Set ComXMLHTTP = CreateObject("Microsoft.XMLHTTP") '初始化 XMLHTTP 对象
If Err.Number <> 0 T
hen
MsgBox "错误：" & Err.Number & "，" & Err.Description
Err.Clear
Exit Sub
End If
ComXMLHTTP.Open "GET", "bbs.duowan/thread-17408898-2-1.html", False '设置访问方式和URL地址
ComXMLHTTP.setRequestHeader "CONTENT-TYPE", "application/x-www-form-urlencoded" '向HTTP头加入参数
ComXMLHTTP.Send '提交HTTP请求
If Err.Number <> 0 Then
MsgBox "错误：" & Err.Number & "，" & Err.Description
Err.Clear
Exit Sub
End If
'---------- 判断下载是否成功 ----------
If ComXMLHTTP.Status <> 200 Then
MsgBox "访问URL失败，请您确定。", 64, "提示"
Exit Sub
End If
'==================== 下载 URL 的数据完成后将数据读入字节数组中 ====================
'---------- 将数据读入 byteHTML 这个字节数组中 ----------
' 因为该网页原来是 UTF-8 编码，所以取得的数据也就是 UTF-8 的编码数据
byteHTML = ComXMLHTTP.ResponseBody
Call SaveTextFile("c:/", byteHTML, "UTF-8") ' 保存原始数据到磁盘，可以验证数据的完整性
'---------- 将 UTF-8 编码的字节数组转换成 Unicode 编码的字节数组 ----------
byteHTML = UTF8ToUnicode(byteHTML)
Call SaveTextFile("c:/", byteHTML, "Unicode") ' 保存转换 Unicode 后的数据到磁盘，可以验证数据的完整性
'---------- 将 Unicode 编码的字节数组转换成 GB2312 编码的字节数组 ----------
' 其转换目的是方便用 GB2312 的字符串查数据，当然直接用 Unicode 也是可以实现的
byteHTML = UnicodeToGB2312(byteHTML)
Call SaveTextFile("c:/", byteHTML) ' 保存转换 GB2312 后的数据到磁盘，可以验
证数据的完整性
'==================== 得到完整的 GB2312 编码数组数据后，开始分析网页内容 ====================
' 第一个到的被忽略，因为这个不是所需的内容
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, "")
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 Sub
'====================================================================================================
' User in the class custom's funtion dispose process ( 自定义函数及处理过程 )
'====================================================================================================
'----------------------------------------------------------------------------------------------------
' Function Name: UTF8ToUnicode
' Input Parameter: funUTF8(Byte Array) - The UTF-8's byte array
' Return Value: (Byte Array) - Return Unicode's byte array
' Description : Visual Basic compile's conversion the UTF-8 to Unicode dispose process
' Author : SupermanKing
'----------------------------------------------------------------------------------------------------
Function 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
'-------------------- 根据 UTF-8 编码规则数 UTF-8 字符的存储个数 --------------------
lngUTF8Count = 0
byteTemp = funUTF8(i)
For j = 1 To 7
byteBit = Int(byteTemp / (2 ^ (8 - j))) '二进制位向右偏移 (8 - j) 个二进制位
byteBit = byteBit And 1 '取最后一个二进制位值
If byteBit = 1 Then
lngUTF8Count = lngUTF8Count + 1
Else
'碰到0就结束数字符数操作
Exit For
End If
Next j
'-------------------- 判断编码内存储的内容是否是经过编码的 --------------------
If lngUTF8Count < 2 Or lngUTF8Count > 3 Then
'---------- 没有经过 UTF-8 格式编码，直接转换成 Unicode 编码 ----------
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
'---------- 经过 UTF-8 格式编码，先读出内容后再转换成 Unicode 编码 ----------
' 读出这几个UTF-8字节内容
For j = 0 To lngUTF8Count - 1
byteTemp = funUTF8(i + j)
If j = 0 Then
'第一个UTF-8编码含编码字节信息，所以取存储信息特别点
byteTemp = byteTemp And ((2 ^ (8 - (lngUTF8Count + 1))) - 1)
lngUTF8Char = byteTemp字符串转数组 csdn
Else
'后面的只取6个二进制位
byteTemp = byteTemp And &H3F
lngUTF8Char = lngUTF8Char * &H40 '向左偏移6位好存储后面的6位数据
lngUTF8Char = lngUTF8Char Or byteTemp '将低6位的数据补充到编码中
End If
Next j
' 已经取出Unicode编码到 lngUTF8Char 里
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 Function
'----------------------------------------------------------------------------------------------------
' Function Name: UnicodeToGB2312
' Input Parameter: funUnicode(Byte Array) - The Unicode's byte array
' Return Value: (Byte Array) - Return GB2312's byte array
' Description : Visual Basic compile's conversion the Unicode to GB2312 dispose process
' Author : SupermanKing
'----------------------------------------------------------------------------------------------------
Function 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 Function
'----------------------------------------------------------------------------------------------------
' Function Name: InStr_Array
' Input Parameter: funStart(Long) - Search the byte array start's address
' : funBytes(Byte Array) - Want search data's byte array
' : funFind(String) - Search's qualification
' Return Value: (Long) - Find qualification's address
' Description : Imitate InStr function's dispose process
' Author : SupermanKing
'----------------------------------------------------------------------------------------------------
Function 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
Ex
版权声明：本站内容均来自互联网，仅供演示用，请勿用于商业和其他非法用途。如果侵犯了您的权益请与我们联系QQ:729038198，我们将在24小时内删除。
发表评论