VB分析超過64K的網頁內容（基於XMLHTTP和位元組陣列處理）
阿新 • • 發佈：2019-01-11
'
'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
'====================================================================================================
' 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
相關推薦
VB分析超過64K的網頁內容（基於XMLHTTP和位元組陣列處理）
'****************************************************************************************************''Name.......... WEB Page Read Program'File..........
python獲取完整網頁內容（即包括js動態載入的）：selenium+phantomjs
在上一篇文章（http://blog.csdn.net/Trisyp/article/details/78732630）中我們利用模擬開啟瀏覽器的方法模擬點選網頁中的載入更多來實現動態載入網頁並獲取網
【linux】Valgrind工具集詳解（十）：SGCheck（檢查棧和全域性陣列溢位）
一、概述 SGCheck是一種用於檢查棧中和全域性陣列溢位的工具。它的工作原理是使用一種啟發式方法，該方法源於對可能的堆疊形式和全域性陣列訪問的觀察。 棧中的資料：例如函式內宣告陣列int a[10]，而不是malloc分配的，malloc分配的記憶體是在堆中。 SGCheck和Me
xml 轉換 map （包括屬性和相同元素處理）
xml轉map，從網上看了一些部落格，都不能完全滿足需求，自己在其他部落格分享的方法上進一步處理，最終滿足所有格式xml轉map。 在這裡感謝這些博主分享文章。（具體使用了哪位博主的文章有點記不清楚了） 直接看程式碼： package com.test
UIWebView獲得網頁內容（HTML原始碼）、載入本地HTML檔案
獲取網頁內容 在使用UIWebView載入一個網頁的時候，有時候需要獲得此頁面的原始碼，可以使用UIWebView執行JS程式碼來獲得： //載入網址 let req = NSMutableURLRequest.init(URL: NSURL.init(string: "h
java集合之----HashMap原始碼分析（基於JDK1.7與1.8）
一、什麼是HashMap 百度百科這樣解釋： 簡而言之，HashMap儲存的是鍵值對（key和value），通過key對映到value，具有很快的訪問速度。HashMap是非執行緒安全的，也就是說在多執行緒併發環境下會出現問題（死迴圈） 二、內部實現 （1）結構 HashM
Python爬蟲：lxml模組分析並獲取網頁內容
運用css選擇器： # -*- coding: utf-8 -*- from lxml import html page_html = ''' <html><body> <input id="input_id" value="input value" nam
Vue.js 運行環境搭建詳解（基於windows的手把手安裝教學）及vue、node基礎知識普及
頁面 沒有 全能 服務器程序 重載 帶來 size 耐心 編程 Vue.js 是一套構建用戶界面的漸進式框架。他自身不是一個全能框架——只聚焦於視圖層。因此它非常容易學習，非常容易與其它庫或已有項目整合。在與相關工具和支持庫一起使用時，Vue.j
走入計算機的第三十四天（基於tcp和udp的套接字）
recv 設置 內存 tcp list dup lis 不知道 狀態 一 TCP套接字 1 low版TCP套接字 服務器端 客戶端 2、改進版tcp套接字 服務端
用匯編語言點亮LED（基於STC大學計劃實驗箱）
計劃 一次 delay start stc tar 雙向 大學 置0 P1M1 DATA 0x91 // =00--->準雙向口, 01--->推挽模式 =10--->輸入模式, 11--->開漏模式 P
3，ActiveMQ-入門（基於JMS發布訂閱模型）
監聽 int @override 技術 image 可持久化 發布訂閱模型 reat creat 一、Pub/Sub-發布/訂閱消息傳遞模型 在發布/訂閱消息模型中，發布者發布一個消息，該消息通過topic傳遞給所有的客戶端。在這種模型中，發布者和訂閱者彼此不知道對方，
機器學習：線性回歸——理論與代碼實現（基於正規方程與梯度下降）
overfit 返回 pen ear 隨機梯度 是否 很大的 建模 回歸 一 線性模型 給定由n個屬性描述的列向量\(f(\mathbf{x})={(x^{(1)};x^{(2)};...;x^{(n)})}\)，其中 \(x^{(j)}\)是\(\textbf{x}\)
學習筆記--配置DHCP服務器（基於接口的地址池）
mar huawei adb def exclude day sha png images 一，開啟DHCP功能，並且把相應端口加入VLAN,並且設置vlan網關1.開啟dhcp功能.[Huawei]dhcp enable 2.創建vlan 10 20[Huawei]vl
OAuth2.0（基於django2.1.2實現版本）
sqlit roo 本地ip pps 數據庫密碼 lan 1.0 服務器 hang 基於python3.7 0),你要先對OAuth2.0有一定的了解，建議先讀一下阮一峰的oauth2.0文章，直接看“授權碼模式”即可，帶著疑問再來讀本文效果更好。http://www.ru
四、佇列的使用（基於記憶體 和 基於資料庫）
轉載自：https://blog.csdn.net/yang5726685/article/details/54234569 今天跟大家來看看如何在專案中使用佇列。首先我們要知道使用佇列的目的是什麼？一般情況下，如果是一些及時訊息的處理，並且處理時間很短的情況下是不需要使用佇列的，直接阻
誰說菜鳥不會資料分析（工具篇）----- 學習筆記3（資料展現和日報月報自動化）
1、資料視覺化的意義 互動性：使用者能夠方便地通過互動介面實現資料的管理、計算與預測 多維性：可從資料的多個屬性或變數對資料進行切片、鑽取、旋轉等，以此剖析資料，從而能多角度、多方面分析資料 可視性：資料可用影象、二維圖形、三維圖形和動畫等方式來展現，並可對其模式和相互關係進行
git基本命令（基於廖雪峰的git教程）
建立版本庫(在合適的位置)： $ mkdir learngit(目錄名) $ cd learngit(檔名) 顯示當前目錄： $ pwd 將目錄變成Git可以管理的倉庫： $ git init 將檔案新增到倉庫： $ git add <file> 將檔
Linux下Mysql的資料庫備份（基於 CentOS 7.4 64位）
在做專案的時候，經常會需要對資料庫進行備份，基於Linux系統下的操作我還是第一次做，所以在網上查詢了很多資料，分別參考了https://www.cnblogs.com/batsing/p/4938986.html 和 ht
Linux 使用Mycat實現讀寫分離（基於Mysql的讀寫分離）
各位同學大家好，今天給大家分享一下用Mycat進行資料庫的讀寫分離，本篇文章是基於上一篇的mysql主從複製。Linux上實現Mysql的主從複製(為Mycat讀寫分離作準備) 在上一篇文章中，我們在兩個伺服器使用同版本的作業系統和mysql： 伺服器1：centos7.3，mysql5.6 伺服器
課程表的實現（基於強智科技教務系統）
課程表的實現（基於強智科技教務系統） 1，本小系統服務於在校大學生。使用者可以根據程式碼定製安裝自己的輕量級課程表app在手機上(當然，可以把網路請求部分修改移植到PC或者Web平臺上)。 2，好處：再也不用為了在手機上看課表而專門去下載30~60MB不等大小並且有各種干擾