form1.frm

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

VERSION 5.00
Begin VB.Form Form1 
   BorderStyle     =   3  'Fixed Dialog
   Caption         =   "网易评论采集"
   ClientHeight    =   6330
   ClientLeft      =   45
   ClientTop       =   450
   ClientWidth     =   7365
   BeginProperty Font 
      Name            =   "Tahoma"
      Size            =   8.25
      Charset         =   0
      Weight          =   400
      Underline       =   0   'False
      Italic          =   0   'False
      Strikethrough   =   0   'False
   EndProperty
   Icon            =   "Form1.frx":0000
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   422
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   491
   StartUpPosition =   3  '窗口缺省
   Begin VB.CheckBox chkAppend 
      Caption         =   "附加到文件尾(&A)"
      Height          =   375
      Left            =   5520
      TabIndex        =   16
      Top             =   2640
      Visible         =   0   'False
      Width           =   2535
   End
   Begin VB.CommandButton btnBrowse 
      Caption         =   "..."
      Height          =   330
      Left            =   5040
      TabIndex        =   15
      Top             =   2640
      Width           =   330
   End
   Begin VB.TextBox txtEnd 
      Height          =   285
      Left            =   2280
      TabIndex        =   12
      Text            =   "20"
      Top             =   2040
      Width           =   735
   End
   Begin VB.TextBox txtBegin 
      Height          =   285
      Left            =   1080
      TabIndex        =   11
      Text            =   "1"
      Top             =   2040
      Width           =   735
   End
   Begin VB.TextBox txtFilename 
      Height          =   285
      Left            =   1080
      TabIndex        =   9
      Text            =   "c:\comment.txt"
      Top             =   2640
      Width           =   3855
   End
   Begin VB.CommandButton btnDetail 
      Caption         =   "详细(&D) >>"
      Height          =   330
      Left            =   120
      TabIndex        =   7
      Top             =   3720
      Width           =   1245
   End
   Begin VB.CommandButton btnEnd 
      Caption         =   "终止(&E)"
      Height          =   330
      Left            =   6120
      TabIndex        =   6
      Top             =   3720
      Visible         =   0   'False
      Width           =   1125
   End
   Begin VB.TextBox txtThreadCount 
      Height          =   285
      Left            =   1080
      TabIndex        =   4
      Text            =   "5"
      Top             =   3240
      Width           =   735
   End
   Begin VB.TextBox txtURL 
      Height          =   975
      Left            =   1080
      MultiLine       =   -1  'True
      ScrollBars      =   2  'Vertical
      TabIndex        =   2
      Text            =   "Form1.frx":0E42
      Top             =   720
      Width           =   6255
   End
   Begin VB.CommandButton btnBegin 
      Caption         =   "开始(&S)"
      Height          =   330
      Left            =   4920
      TabIndex        =   1
      Top             =   3720
      Width           =   1125
   End
   Begin VB.ListBox List1 
      Height          =   2010
      Left            =   120
      TabIndex        =   0
      Top             =   4200
      Width           =   7095
   End
   Begin VB.Label Label7 
      Caption         =   "仅用于采集网易评论"
      BeginProperty Font 
         Name            =   "Tahoma"
         Size            =   8.25
         Charset         =   0
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      ForeColor       =   &H00C00000&
      Height          =   255
      Left            =   360
      TabIndex        =   17
      Top             =   240
      Width           =   3735
   End
   Begin VB.Line Line1 
      BorderColor     =   &H80000015&
      X1              =   -128
      X2              =   746
      Y1              =   240
      Y2              =   240
   End
   Begin VB.Line Line2 
      BorderColor     =   &H80000014&
      X1              =   0
      X2              =   874
      Y1              =   241
      Y2              =   241
   End
   Begin VB.Label Label6 
      Caption         =   "到"
      Height          =   255
      Left            =   1920
      TabIndex        =   14
      Top             =   2040
      Width           =   495
   End
   Begin VB.Label Label5 
      Caption         =   "页码:"
      Height          =   255
      Left            =   120
      TabIndex        =   13
      Top             =   2040
      Width           =   855
   End
   Begin VB.Label Label4 
      Caption         =   "通配符(*)"
      Height          =   255
      Left            =   5040
      TabIndex        =   10
      Top             =   1800
      Width           =   1815
   End
   Begin VB.Label Label3 
      Caption         =   "文件名:"
      Height          =   255
      Left            =   120
      TabIndex        =   8
      Top             =   2640
      Width           =   855
   End
   Begin VB.Label Label2 
      Caption         =   "线程数:"
      Height          =   195
      Left            =   120
      TabIndex        =   5
      Top             =   3240
      Width           =   600
   End
   Begin VB.Label Label1 
      Caption         =   "URL"
      BeginProperty Font 
         Name            =   "Tahoma"
         Size            =   8.25
         Charset         =   0
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   195
      Left            =   120
      TabIndex        =   3
      Top             =   720
      Width           =   1530
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private Const LB_SETHORIZONTALEXTENT = &H194
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private m_lListBoxWidth     As Long

Private oThread()           As CAxThread

Private m_sURLs             As Variant      'URL数组
Private m_lCurURL           As Long         '当前处理到的URL
Private m_lURLCount         As Long         'URL数量
Private m_sRunningThread    As String       '正在运行的线程

Private Sub AddRunningThread(ByVal id As Long)
    m_sRunningThread = m_sRunningThread & "," & id & ","
End Sub

Private Sub RemoveRunningThread(ByVal id As Long)
    m_sRunningThread = Replace(m_sRunningThread, "," & id & ",", "")
End Sub

Private Function IsRunningThread() As Boolean
    If Len(Replace(m_sRunningThread, ",", "")) > 0 Then
        IsRunningThread = True
    Else
        IsRunningThread = False
    End If
End Function

Public Sub AddLog(ByVal sText As String)
    Dim lTextWidth As Long
    lTextWidth = Me.TextWidth(sText) * 2
    If m_lListBoxWidth < lTextWidth Then
        SendMessage List1.hwnd, LB_SETHORIZONTALEXTENT, lTextWidth + 10, ByVal 0&
        m_lListBoxWidth = lTextWidth
    End If
    List1.AddItem sText
End Sub

'设置按钮状态
Public Sub SwitchButton(Optional ByVal bEnd As Boolean = False)
    If bEnd Then _
        If IsRunningThread Then Exit Sub
    btnBegin.Enabled = bEnd
    btnEnd.Enabled = Not bEnd
    If Not bEnd Then
        AddLog "任务开始"
    Else
        AddLog "任务完成"
        MsgBox "页面:" & g_lPageCount & vbCrLf & _
                "评论:" & g_lCommentCount _
                , vbInformation, "任务完成"
    End If
End Sub

Public Sub OnThreadFinished(ByVal id As Long)
    Form1.AddLog "#" & id & "完成"
    g_lPageCount = g_lPageCount + 1
    RemoveRunningThread id
    mTextFile.WriteTextFile txtFilename.Text, mGetCommentNetease.getComment(oThread(id).Thread.Html), True
    If m_lCurURL >= m_lURLCount Then
        SwitchButton True
        Exit Sub
    End If
    '判断URL地址有效性
    While LCase(Left(m_sURLs(m_lCurURL), 7)) <> "http://"
        m_lCurURL = m_lCurURL + 1
        If m_lCurURL >= m_lURLCount Then
            SwitchButton True
            Exit Sub
        End If
    Wend
    '继续使用线程#id下载
    With oThread(id).Thread
        .Download m_sURLs(m_lCurURL)
        AddRunningThread id
        AddLog "#" & id & "下载:" & m_sURLs(m_lCurURL)
    End With
    m_lCurURL = m_lCurURL + 1
End Sub

Private Sub generateURLs()
    Dim lBegin As Long
    Dim lEnd As Long
    Dim lLength As Long
    Dim sURL As String
    lBegin = Val(txtBegin.Text)
    lEnd = Val(txtEnd.Text)
    lLength = lEnd - lBegin
    sURL = txtURL.Text
    sURL = Replace(sURL, vbCrLf, "")
    If lLength < 0 Or lLength > 500 Then
        MsgBox "页码范围错误", vbInformation
        Exit Sub
    End If
    ReDim m_sURLs(lLength) As String
    Dim i As Long
    Dim lCount As Long
    For i = lBegin To lEnd
        m_sURLs(lCount) = Replace(sURL, "(*)", CStr(i))
        lCount = lCount + 1
    Next
End Sub

Private Sub btnBegin_Click()
    SwitchButton False
    
    g_lCommentCount = 0
    g_lPageCount = 0
    
    'URL
    Call generateURLs
    m_lURLCount = UBound(m_sURLs) + 1
    
    If chkAppend.Value <> vbChecked Then
        '清空文本文件
        mTextFile.WriteTextFile txtFilename.Text, "", False
    End If
    
    Dim lThreadCount As Long
    lThreadCount = Val(txtThreadCount.Text)
    '限制线程数100
    If lThreadCount > 100 Then lThreadCount = 100
    ReDim oThread(lThreadCount)
    
    If lThreadCount > m_lURLCount Then
        lThreadCount = m_lURLCount
    End If
    m_lCurURL = 0
    Dim i As Long
    For i = 0 To lThreadCount - 1
        '判断所有URL已下载
        If m_lCurURL >= m_lURLCount Then
            SwitchButton True
            Exit Sub
        End If
        '判断URL地址有效性
        If LCase(Left(m_sURLs(m_lCurURL), 7)) = "http://" Then
            '初始化线程
            Set oThread(i) = New CAxThread
            AddRunningThread i
            With oThread(i).Thread
                .id = i
                .Download m_sURLs(m_lCurURL)
                AddLog "#" & i & "开始:" & m_sURLs(m_lCurURL)
            End With
            m_lCurURL = m_lCurURL + 1
        End If
    Next
    
End Sub

Private Sub btnBrowse_Click()
    Dim sFilename As String
    sFilename = mOpenFileDlg.SaveFileDlg("文本文件(*.txt)|*.txt|所有文件(*.*)|*.*", _
    "保存", , Me.hwnd)
    If Len(sFilename) > 0 Then
        txtFilename = sFilename
    End If
End Sub

Private Sub btnDetail_Click()
    If btnDetail.Caption = "详细(&D) >>" Then
        Me.Height = 6700
        btnDetail.Caption = "详细(&D) <<"
    Else
        Me.Height = 4500
        btnDetail.Caption = "详细(&D) >>"
    End If
End Sub