@LimingX - 写了个提取文本的小程序

刚才闲来无事,翻出来之前的一个小程序改了改,基本功能是这样的:

可以从指定的任意文本文件中,提取含有指定字符的整行内容,并将这些内容转存至指定的任意文件中。这一版本加入了对正则表达式的支持。

这个东东在某些情况下,还是比较有用的。例如:要从数GB的网站日志中提取某个SPIDER的抓取记录、要从数百MB的词表中抽取符合特定规则的内容等等。

编译后的程序只有28KB(压缩包为6KB),可以点击这里(已失效)下载。需要说明的是,这程序还只是一个基本的结构,有些细节的考虑暂时没有加上,例如错误处理与错误信息之类。

运行时的界面:

TextExtra1.0.jpg

下附源代码(以VB6实现,很久不写,有点可碜):

'代码开始***********************************************************************
'程序相关信息(名称、版本、更新日期等)
Private Const PRG_NAME As String = "TextExtra"
Private Const PRG_VERSION As String = "1.0"
Private Const PRG_DATE As String = "2006.07.08"


Private Sub cmdBrowIn_Click()
    CommonDialog1.ShowOpen
    If CommonDialog1.FileName <> "" Then txtInput.Text = CommonDialog1.FileName
End Sub

Private Sub cmdBrowOut_Click()
    CommonDialog1.ShowOpen
    If CommonDialog1.FileName <> "" Then txtOutput.Text = CommonDialog1.FileName
End Sub

Private Sub cmdQuit_Click()
    End
End Sub


Private Sub Form_Load()
    
    frmMain.Caption = PRG_NAME & " " & PRG_VERSION & " build " & PRG_DATE
    CommonDialog1.Filter = "文本文件|*.txt|日志文件|*.log|所有文件|*.*"

End Sub


Private Sub cmdRun_Click()
    txtShow.Text = "正在提取操作中,请稍候……"
    Select Case chkRegExp.Value
        Case Checked    '正则表达式方式
            txtShow.Text = FindText(txtInput.Text, txtOutput.Text, txtQuery.Text, True)
        Case Unchecked '纯文本方式
            txtShow.Text = FindText(txtInput.Text, txtOutput.Text, txtQuery.Text, False)
        Case Else   '留待扩展
            MsgBox "未知错误……"
            End
    End Select
End Sub


Function FindText(strInputFile As String, strOutputFile As String, strQuery As String, bolRegExp As Boolean) As String
    
    Dim fs, objInputFile, objOutputFile
    Set fs = CreateObject("Scripting.FileSystemObject")    '创建一个fso对象
    Set objInputFile = fs.OpenTextFile(strInputFile)     '打开原始文件
    Set objOutputFile = fs.CreateTextFile(strOutputFile, True)    '创建目标文件
    Dim strCurrentLine As String    '当前读入的一行
    
    
    
    '统计信息
    startT = Timer '记录开始时间
    Dim lngLinage As Long       '用于统计文件的总行数
    Dim lngRecall As Long       '用于统计查找到的行数
    
    
    Select Case bolRegExp
        Case True   '正则表达式方式
            Do While objInputFile.AtEndOfStream <> True         '开始处理原始文件,直到文件结束。
                strCurrentLine = objInputFile.readline
                If TestRegExp(strQuery, strCurrentLine) = True Then '如果匹配到内容
                    objOutputFile.WriteLine (strCurrentLine)   '输出到文件
                    lngRecall = lngRecall + 1
                End If
                lngLinage = lngLinage + 1
                DoEvents
            Loop
        Case False '纯文本方式
            Do While objInputFile.AtEndOfStream <> True         '开始处理原始文件,直到文件结束。
                strCurrentLine = objInputFile.readline
                If TestInStr(strQuery, strCurrentLine) = True Then '如果匹配到内容
                    objOutputFile.WriteLine (strCurrentLine)   '输出到文件
                    lngRecall = lngRecall + 1
                End If
                lngLinage = lngLinage + 1
                DoEvents
            Loop
        Case Else   '留待升级
            MsgBox "未知错误……"
            End
    End Select
    
    '处理完成,关闭文件
    objOutputFile.Close
    objInputFile.Close
    
    
    endT = Timer    '记录结束时间
    wastingT = endT - startT    '计算消耗时间
    
    FindText = "文本提取操作成功完成!统计信息如下:" & vbNewLine & vbNewLine & _
               "本操作时间 : " & Now & vbNewLine & _
               "数据来源于 : " & strInputFile & vbNewLine & _
               "保存结果至 : " & strOutputFile & vbNewLine & _
               "查找内容为 : " & strQuery & vbNewLine & _
               "正则表达式 : " & bolRegExp & vbNewLine & _
               "全部数据共 : " & lngLinage & "行。" & vbNewLine & _
               "有效提取到 : " & lngRecall & "行。" & vbNewLine & _
               "消耗时间约 : " & wastingT & "秒。"
End Function


'*******************************************************************************
'函数名称:TestRegExp
'接收参数:myPattern、myString as string
'返 回 值:True、False as boolean
'功能说明:在 myString 中通过正则表达式 myPattern 进行匹配,如果找到返回True,否
'          则返回False。
'
'   下面是 RegExp 提供的属性。
'   这些属性用于设置那些用来比较传递给 RegExp 实例的字符串的模式。
'   Pattern:一个字符串,用来定义正则表达式。
'   IgnoreCase:一个布尔值属性,指示是否必须对一个字符串中的所有可能的匹配进行正
'               则表达式测试。
'   Global:设置一个布尔值或返回一个布尔值,该布尔值指示一个模式是必须匹配整个搜
'           索字符串中的所有搜索项还是只匹配第一个搜索项。
'   RegExp:提供以下方法以确定字符串是否与正则表达式的特定模式相匹配:
'          Test:返回一个布尔值,该值指示正则表达式是否与字符串成功匹配。
'          Execute:返回一个 MatchCollection 对象,该对象包含每个成功匹配的
'                   Match 对象。
    '正则表达式举例:
    '匹配中文字符:     [\u4e00-\u9fa5]
    '匹配三个数字:     \d{3}
'*******************************************************************************

Function TestRegExp(myPattern As String, myString As String) As Boolean
   
   'Create objects.
    Dim objRegExp As RegExp
    Dim objMatch As Match
    Dim colMatches As MatchCollection
    Dim RetStr As String
   
    ' Create a regular expression object.
    Set objRegExp = New RegExp

    'Set the pattern by using the Pattern property.
    objRegExp.Pattern = myPattern

    ' Set Case Insensitivity.
    objRegExp.IgnoreCase = True

    'Set global applicability.
    objRegExp.Global = True

   'Test whether the String can be compared.
    If (objRegExp.Test(myString) = True) Then
        TestRegExp = True

'    另一种用法:显示每一个匹配的项。
'    Get the matches.
'    Set colMatches = objRegExp.Execute(myString)   ' Execute search.

'    For Each objMatch In colMatches   ' Iterate Matches collection.
'      RetStr = RetStr & "Match found at position "
'      RetStr = RetStr & objMatch.FirstIndex & ". Match Value is '"
'      RetStr = RetStr & objMatch.Value & "'." & vbCrLf
'    Next
    
    Else
        TestRegExp = False

'       RetStr = "String Matching Failed"
    
    End If

'   TestRegExp = RetStr

End Function

'*******************************************************************************
'函数名称:TestInStr
'接收参数:strKeyword、strSource as string
'返 回 值:True、False as boolean
'功能说明:在 strSource 中通过查找字符 strKeyword 进行匹配,如果找到返回True,否
'          则返回False。
'*******************************************************************************

Private Function TestInStr(strKeyword As String, strSource As String) As Boolean
    If InStr(1, strSource, strKeyword, 1) > 0 Then
        TestInStr = True
    Else
        TestInStr = False
    End If
End Function

'代码结束***********************************************************************
Tagged by 百度空间旧事  
上一篇:点名游戏:召唤搜索高手 下一篇:名人就是名人,不服不行.

Post a new comment