mtxtparse.bas

vb做的网易评论自动采集软件

Attribute VB_Name = "mTxtParse"
Option Explicit


Public Function GetParaText(ByVal sText As String, ByVal lParagraph As Long, Optional ByVal lCharThreshold As Long = 10) As String
    Dim sReturn         As String '返回
    Dim lChar           As Long '当前字符
    Dim lPreChar        As Long '上次字符
    Dim i               As Long
    Dim lBlankCount     As Long '空白符号个数
    Dim lStartPos       As Long '段落开始
    Dim lEndPos         As Long '段落结束
    Dim lStartCount     As Long '段落开始次数
    Dim lEndCount       As Long '段落结束次数
    
    For i = 1 To Len(sText)
        lChar = Asc(Mid(sText, i, 1))
        If lChar = 9 Or lChar = 10 Or lChar = 13 Or lChar = 32 Then
            '空白字符
            lBlankCount = lBlankCount + 1
            If lBlankCount > lCharThreshold And lStartCount - lEndCount = 1 Then
                lEndPos = i - lBlankCount + 1
                lEndCount = lEndCount + 1
                lBlankCount = 0
                If lEndCount = lParagraph Then Exit For
            End If
        Else
            '非空白字符，前面出现的空白字符超过阈值
            If lBlankCount > lCharThreshold And lStartCount = lEndCount Then
                lStartPos = i
                lStartCount = lStartCount + 1
            End If
            lBlankCount = 0
        End If
        lPreChar = lChar
    Next
    'If lEndPos - lStartPos <= 100 Then lEndPos = lStartPos + 100
    If lStartPos > 0 And lEndPos > 0 Then sReturn = Mid(sText, lStartPos, lEndPos - lStartPos)
    GetParaText = sReturn
End Function

Public Function Html2Txt(ByVal sHtml As String) As String
    Dim lBracketPos As Long      ' <位置
    Dim lBracketPos2 As Long     ' >位置，识别tag
    Dim lBlankPos As Long        ' 空格位置，识别tag
    Dim sTag As String           ' 标签
    Dim sText As String          ' 返回的Txt
    Dim lTextStart As Long       ' Txt起始位置
    Dim lTextEnd As Long         ' Txt结束位置
    Dim bComment As Boolean      ' 注释或脚本段
    lBracketPos = InStr(1, sHtml, "<")
    While lBracketPos > 0
        bComment = True
        lBracketPos2 = InStr(lBracketPos + 1, sHtml, ">")
        lBlankPos = InStr(lBracketPos + 1, sHtml, " ")
        If lBlankPos > lBracketPos2 Then lBlankPos = InStr(lBracketPos + 1, sHtml, vbCrLf)
        If lBlankPos < lBracketPos2 And lBlankPos <> 0 Then
            sTag = LCase(Mid(sHtml, lBracketPos + 1, lBlankPos - lBracketPos - 1))
        Else
            sTag = LCase(Mid(sHtml, lBracketPos + 1, lBracketPos2 - lBracketPos - 1))
        End If
        If Left(sTag, 3) = "!--" Then
            lTextEnd = InStr(lBracketPos + 1, sHtml, "-->")
        ElseIf sTag = "script" Then
            lTextEnd = InStr(lBracketPos2 + 1, sHtml, "/script>", vbTextCompare)
        ElseIf sTag = "style" Then
            lTextEnd = InStr(lBracketPos2 + 1, sHtml, "/style>", vbTextCompare)
        Else
            lTextEnd = InStr(lBracketPos2 + 1, sHtml, "<")
            bComment = False
        End If
        lTextStart = lBracketPos2 + 1
        If bComment Then
            lBracketPos = InStr(lTextEnd + 1, sHtml, "<")
        Else
            If lTextEnd = 0 Then
                lBracketPos = -1
            Else
                sText = sText & Mid(sHtml, lTextStart, lTextEnd - lTextStart)
                lBracketPos = InStr(lTextEnd + 1, sHtml, "<")
            End If
        End If
    Wend
    sText = Replace(sText, "&nbsp;", " ")
    sText = Replace(sText, vbCrLf & vbCrLf, vbCrLf)
    sText = Replace(sText, "&lt;", "<")
    sText = Replace(sText, "&gt;", ">")
    sText = Replace(sText, "<br>", vbCrLf, , , vbTextCompare)
    Html2Txt = sText
End Function

Public Function FetchBetween(ByVal sSource As String, ByVal sStart As String, ByVal sEnd As String) As String
    Dim lStartPos As Long
    Dim lEndPos As Long
    Dim sReturn As String
    lStartPos = InStr(1, sSource, sStart)
    lEndPos = InStr(1, sSource, sEnd)
    If lStartPos > 0 And lEndPos > 0 And lEndPos - lStartPos > 0 Then
        sReturn = Mid(sSource, lStartPos, lEndPos - lStartPos)
    End If
    FetchBetween = sReturn
End Function