从HTML网页文件中提取纯文本的代码
从HTML网页文件中提取纯文本的代码 网上时常有些评论说VB写的程序运行速度慢，特别是字符串操作更是慢的无法与其他开发工具相提并论。我对此一向持反对意见，VB很多时候是为了照顾到代码的简洁、方便、安全，而相应牺牲了一些执行速度。这正是有得必有失的道理。在真正需要速度的场合，VB也是可以快起来的，方法就是进入到API中，直接拷贝内存来操作字符串，你会看到，VB的速度毫不逊色于其他任何工具，当然相应的，要牺牲掉简洁、安全这些优势，你必须像编写C代码一样小心翼翼，因为直接操作内存是很危险的，它脱离了VB的安全保护，一个疏忽就会导致严重的后果。
下面这段提取网页纯文本的代码用了字符串操作的优化技巧，可供参考，同时欢迎批评指正。
需要注意的是，这段代码优化的宗旨是够用就好，没有达到最大的优化，如果要完全发挥出VB的潜能，达到骨灰级优化，还可以从以下两方面入手来做进一步的优化：
1.不要使用双缓冲，可以用动态数组变量直接借用字符串s的内存，这样可以减少瞬时内存占用。缺点是代码变得复杂，可读性下降。
2.replace空格的那一段是最慢的，可把它整合到下方的For循环的算法中，可以提高速度。缺点是代码变得复杂，可读性下降。
Option Explicit
'*************************************************************************
'这个模块从网页文件中提取纯文本(只保留基本的格式，不是严格的原样，比如表格等不被支持)
'*************************************************************************
Private Declare Sub CopyMemory Lib 'kernel32' Alias _
'RtlMoveMemory' (Destination As Any, Source As Any, ByVal Length As Long)
Public Function GetHTMLText(ByVal sFQFilename As String) As String
'从网页文件中提取纯文本
'INPUT------------------------------------------------------------
'sFQFilename 网页文件的全路径名
'OUTPUT-----------------------------------------------------------
'Return Value 提取的纯文本
'-----------------------------------------------------------------
Const ASCW_LTS As Integer = 60 'ASCW('<'),LTS means Little Than Sign
Const ASCW_GTS As Integer = 62 'ASCW('>')
Dim fn As Integer, s As String 'file number , string buffer
Dim aBufIn() As Integer, aBufOut() As Integer 'input buffer,output buffer
Dim lBufOutPtr As Long 'output buffer pointer
Dim i As Long, lLTSDepth As Long '进入 less than sign 的深度
Dim tmr As Single '计时器
try: On Error GoTo catch
'{
fn = FreeFile
Open sFQFilename For Input Access Read As #fn
tmr = Timer
s = StrConv(InputB$(LOF(fn), fn), vbUnicode)
'picOD.Print 'Read From file,use time:' & Timer - tmr
tmr = Timer
'将传统字符去处,在HTML格式中都是无效的字符
s = Replace$(s, vbCrLf, '')
'picOD.Print Timer - tmr
tmr = Timer
s = Replace$(s, ' ', '')
s = Replace$(s, ' ', '')
s = Replace$(s, ' ', '')
s = Replace$(s, ' ', '')
s = Replace$(s, ' ', '')
s = Replace$(s, ' ', '')
s = Replace$(s, ' ', '')
'picOD.Print Timer - tmr
tmr = Timer
'将HTML特殊字符替换为传统字符
s = Replace$(s, '<br>', vbCrLf, , , vbTextCompare)
s = Replace$(s, '<p>', vbCrLf & vbCrLf, , , vbTextCompare)
'picOD.Print 'Replace use time:' & Timer - tmr & ' ' & Len(s)
tmr = Timer
ReDim aBufIn(0 To Len(s) - 1) '分配输入缓冲区的空间，与字符串s,等长
CopyMemory ByVal VarPtr(aBufIn(0)), ByVal StrPtr(s), Len(s) * 2 '复制s
s = '' '释放空间，尽量的保证持续占用空间最小
'分配输出缓冲区的空间
ReDim aBufOut(LBound(aBufIn) To UBound(aBufIn)) 's已释放，不能再用len(s)规定范围
lBufOutPtr = 0: lLTSDepth = 0
'picOD.Print 'allocate memory use time:' & Timer - tmr
tmr = Timer
For i = LBound(aBufIn) To UBound(aBufIn) '遍例输入缓冲区的unicode码
If aBufIn(i) = ASCW_LTS Then '如果当前为<
lLTSDepth = lLTSDepth + 1 '那么深度加1
ElseIf aBufIn(i) = ASCW_GTS Then '如果当前为>
lLTSDepth = lLTSDepth - 1 '那么深度减1
Else '其它字符
If lLTSDepth = 0 Then '如果深度为0，表示不在<>中
aBufOut(lBufOutPtr) = aBufIn(i) '投入输出缓冲区.
'输出缓冲区指针指向当前要投放数据的位置，同时指示了缓冲区中有多少有效数据
lBufOutPtr = lBufOutPtr + 1
End If
End If
Next i
'完成了纯文本抽取，输入缓冲区已经没有用了
Erase aBufIn '擦除输入缓冲区，以保证瞬时内存占用最小
If lBufOutPtr > 0 Then '如果输出缓冲区的有效元素个数不是0
s = Space$(lBufOutPtr) '分配字符串，其大小为lBufOutPtr个字符(Unicode)
'把数组缓冲拷贝到字符串的字符数组空间里
CopyMemory ByVal StrPtr(s), ByVal VarPtr(aBufOut(0)), lBufOutPtr * 2
End If
tmr = Timer
'后期处理
s = Replace$(s, '<', '<', , , vbTextCompare)
s = Replace$(s, '>', '>', , , vbTextCompare)
s = Replace$(s, '&', '&', , , vbTextCompare)
s = Replace$(s, ' ', ' ', , , vbTextCompare)
'picOD.Print 'replace after trim use time:' & Timer - tmr & ' ' & Len(s)
GetHTMLText = s
'}
GoTo finally
catch:
'{
GetHTMLText = ''
'}
finally:
'{
Close #fn
Erase aBufIn
Erase aBufOut
'}
End Function
