VB分析超过64K的网页内容（基于XMLHTTP和字节数组处理）

Visual Basic Code'****************************************************************************************************
'
'Name.......... WEB Page Read Program
'File.......... WEBRead.frm
'Version....... 1.0.0
'Dependencies.. XMLHTTP Object
'Description... Dynamic read URL html data
'Author........ Zhou Wen Xing 
'Date.......... Nov, 5nd 2010
'CSDN Accounts..SupermanKing
'
'Copyright (c) 2008 by www.rljy.com
'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 Then
         MsgBox "错误：" & Err.Number & "，" & Err.Description
         Err.Clear
         Exit Sub
     End If
     ComXMLHTTP.Open "GET", "http://bbs.duowan.com/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:/UTF-8.txt", byteHTML, "UTF-8")        ' 保存原始数据到磁盘，可以验证数据的完整性

    '---------- 将 UTF-8 编码的字节数组转换成 Unicode 编码的字节数组 ----------
     byteHTML = UTF8ToUnicode(byteHTML)
     Call SaveTextFile("c:/Unicode.txt", byteHTML, "Unicode")    ' 保存转换 Unicode 后的数据到磁盘，可以验证数据的完整性

    '---------- 将 Unicode 编码的字节数组转换成 GB2312 编码的字节数组 ----------
    ' 其转换目的是方便用 GB2312 的字符串查找数据，当然直接用 Unicode 也是可以实现的
     byteHTML = UnicodeToGB2312(byteHTML)
     Call SaveTextFile("c:/GB2312.txt", 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
                 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
         Exit Function
     End If
    '---------- 校验搜索内容参数 ----------
     lngBytesCount = UBound(funBytes)
     If Err.Number <> 0 Then
         Err.Clear
         Exit Function
     End If
     byteFindArray = StrConv(funFind, vbFromUnicode)
     lngFindCount = UBound(byteFindArray)
    '---------- 校验搜索位置参数 ----------
     If funStart + lngFindCount > lngBytesCount Then
         Exit Function
     End If

    '==================== 开始搜索数据 ====================
     For i = funStart To lngBytesCount
         lngIsFind = 1
         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 Function

'----------------------------------------------------------------------------------------------------
'  Function   Name:  Mid_Array
'  Input Parameter:  funBytes(Byte Array)       - Want get data's byte array
'                 :  funStart(Long)             - Want get data's start address
'                 :  funCount(Long)             - Want get data's size
'  Return    Value:  (String)                   - Return want get string
'  Description    :  Imitate Mid function's dispose process
'  Author         :  SupermanKing
'----------------------------------------------------------------------------------------------------
Function 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 Function

'----------------------------------------------------------------------------------------------------
'  Function   Name:  SaveTextFile
'  Input Parameter:  funFileName(String)        - Save file's path
'                 :  funBytes(Byte Array)       - Save file's data
'                 :  funMode(String)            - Data codeing mode
'  Return    Value:  (void)
'  Description    :  Save .txt file dispose process
'  Author         :  SupermanKing
'----------------------------------------------------------------------------------------------------
Sub 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
    '根据编码模式来写 TXT 文件头，这样可让 Windows 记事本识别该文件的编码方式
     Select Case UCase(funMode)
     Case "GB2312":  '输出 GB2312 编码的文本文件
                     Put #1, 1, funBytes

     Case "UNICODE": '输出 Unicode 编码的文本文件
                     Put #1, 1, CByte(&HFF)
                     Put #1, 2, CByte(&HFE)
                     Put #1, 3, funBytes

     Case "UTF-8":   '输出 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