mgetcommentnetease.bas

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

Attribute VB_Name = "mGetCommentNetease"
Option Explicit

'针对163.com截取评论

Public Function getComment(ByRef sHtml As String, Optional bIncludeHidden As Boolean = False)
    '163.com评论
    Dim sbReturn As New CStringBuffer
    Const BLOCK_BEGIN = "JavaScript"">"
    Const BLOCK_END = "</script>"
    Const LINE_BEGIN = "replyData["""
    Const LINE_END = "chargeData["""
    Const COMMENT_BEGIN = "{""f"":"""",""b"":"""
    Const COMMENT_END = ""","""
    '审核的评论 <div id="hidden_body">
    Dim lLineBegin As Long
    Dim lLineEnd As Long
    Dim lBegin As Long
    Dim lEnd As Long
    Dim lHiddenPos As Long
    '截取 <div class="review">  </div> 之间的字符
    Dim lCurPos As Long
    Dim lBlockBegin As Long
    Dim lBlockEnd As Long
    lCurPos = InStr(1, sHtml, BLOCK_BEGIN)
    While lCurPos > 0
        lBlockBegin = lCurPos + Len(BLOCK_BEGIN)
        If lBlockBegin <= 0 Then GoTo EXIT_WHILE
        
        lBlockEnd = InStr(lBlockBegin, sHtml, BLOCK_END) - 1
        If lBlockEnd <= 0 Then GoTo EXIT_WHILE

        lLineBegin = InStr(lBlockBegin, sHtml, LINE_BEGIN)
        If lLineBegin <= lBlockBegin Or lLineBegin > lBlockEnd Then GoTo EXIT_WHILE

        lLineEnd = InStr(lLineBegin, sHtml, LINE_END)
        If lLineEnd <= lBlockBegin Or lLineBegin > lBlockEnd Then GoTo EXIT_WHILE

        lBegin = InStr(lLineBegin, sHtml, COMMENT_BEGIN) + Len(COMMENT_BEGIN)
        If lBegin > lLineBegin Then
            lEnd = InStr(lBegin, sHtml, COMMENT_END)
        Else
            '例外情况
            'replyData["4C2O8QUS0001124J_4C31580B"] = '内容';
            lBegin = InStr(lLineBegin, sHtml, "= '") + 3
            lEnd = InStr(lBegin, sHtml, "';")
        End If
        If lBegin <= lLineBegin Or lBegin > lLineEnd Then GoTo EXIT_WHILE
        If lEnd <= lLineBegin Or lEnd > lLineEnd Then GoTo EXIT_WHILE


        '是否包含正在审核的评论
        If lBegin < lEnd Then
            sbReturn.AddString SkipQuote(Mid(sHtml, lBegin, lEnd - lBegin))
        End If
EXIT_WHILE:
        If lBlockEnd > 0 Then
            lCurPos = InStr(lBlockEnd, sHtml, BLOCK_BEGIN)
        Else
            lCurPos = 0
        End If
    Wend
    g_lCommentCount = g_lCommentCount + sbReturn.Length
    getComment = sbReturn.JoinString(vbCrLf)
    
End Function


'跳过Html代码及引用回复
Private Function SkipQuote(ByRef sHtml As String) As String
    Const TABLE_BEGIN = "<table"
    Const TABLE_END = "</table>"
    Dim sReturn As String
    Dim lLength As Long
    Dim lCurPos As Long
    Dim lBegin As Long
    Dim lEnd As Long
    lLength = Len(sHtml)
    lBegin = InStr(1, sHtml, TABLE_BEGIN)
    lEnd = InStrRev(sHtml, TABLE_END) + Len(TABLE_END)
    If lBegin > 0 And lEnd > 0 Then
        sReturn = Mid(sHtml, lEnd)
    Else
        sReturn = sHtml
    End If
    'sReturn = sHtml
    sReturn = Replace(sReturn, "<br>", "")
    sReturn = Replace(sReturn, "&quot;", """")
    sReturn = Replace(sReturn, "&nbsp;", "")
    sReturn = Replace(sReturn, "&lt;", "<")
    sReturn = Replace(sReturn, "&gt;", ">")
    sReturn = Replace(sReturn, vbCrLf, "")
    SkipQuote = sReturn
End Function