frmmain.frm

英文词频统计

VERSION 5.00
Object = "{3B7C8863-D78F-101B-B9B5-04021C009402}#1.2#0"; "RICHTX32.OCX"
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "mscomctl.ocx"
Begin VB.Form frmMain 
   Caption         =   "词频统计工具(英文版) v1.0"
   ClientHeight    =   5370
   ClientLeft      =   165
   ClientTop       =   735
   ClientWidth     =   7905
   LinkTopic       =   "Form1"
   ScaleHeight     =   5370
   ScaleWidth      =   7905
   StartUpPosition =   3  '窗口缺省
   Begin MSComctlLib.ProgressBar ProgressBar1 
      Height          =   135
      Left            =   1800
      TabIndex        =   6
      Top             =   120
      Width           =   3855
      _ExtentX        =   6800
      _ExtentY        =   238
      _Version        =   393216
      Appearance      =   1
   End
   Begin MSComctlLib.StatusBar StsBar1 
      Align           =   2  'Align Bottom
      Height          =   255
      Left            =   0
      TabIndex        =   5
      Top             =   5115
      Width           =   7905
      _ExtentX        =   13944
      _ExtentY        =   450
      _Version        =   393216
      BeginProperty Panels {8E3867A5-8586-11D1-B16A-00C0F0283628} 
         NumPanels       =   1
         BeginProperty Panel1 {8E3867AB-8586-11D1-B16A-00C0F0283628} 
         EndProperty
      EndProperty
   End
   Begin MSComctlLib.ListView ListView1 
      Height          =   2175
      Left            =   5040
      TabIndex        =   4
      Top             =   2760
      Width           =   2535
      _ExtentX        =   4471
      _ExtentY        =   3836
      LabelWrap       =   -1  'True
      HideSelection   =   -1  'True
      _Version        =   393217
      ForeColor       =   -2147483640
      BackColor       =   -2147483643
      BorderStyle     =   1
      Appearance      =   1
      NumItems        =   0
   End
   Begin VB.PictureBox picDrag 
      Appearance      =   0  'Flat
      BackColor       =   &H80000011&
      BorderStyle     =   0  'None
      FillColor       =   &H80000003&
      FillStyle       =   0  'Solid
      ForeColor       =   &H80000000&
      Height          =   5055
      Left            =   4680
      ScaleHeight     =   5055
      ScaleWidth      =   75
      TabIndex        =   3
      Top             =   0
      Width           =   75
   End
   Begin VB.FileListBox File1 
      Height          =   1890
      Left            =   480
      TabIndex        =   2
      Top             =   2760
      Width           =   4095
   End
   Begin VB.DirListBox Dir1 
      Height          =   2190
      Left            =   480
      TabIndex        =   1
      Top             =   360
      Width           =   3855
   End
   Begin RichTextLib.RichTextBox rtext1 
      Height          =   1815
      Left            =   4920
      TabIndex        =   0
      Top             =   480
      Width           =   2415
      _ExtentX        =   4260
      _ExtentY        =   3201
      _Version        =   393217
      Enabled         =   -1  'True
      ScrollBars      =   3
      TextRTF         =   $"frmMain.frx":0000
   End
   Begin VB.Menu mOperate 
      Caption         =   "操作"
      Begin VB.Menu mnuPreview 
         Caption         =   "切换界面"
         Checked         =   -1  'True
      End
      Begin VB.Menu mnu 
         Caption         =   "自定义词表"
      End
      Begin VB.Menu mnuGetKeyWords 
         Caption         =   "执行取词"
      End
   End
   Begin VB.Menu mnuHelp 
      Caption         =   "帮助"
      Begin VB.Menu mnuAbout 
         Caption         =   "关于"
      End
   End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'Option Compare Text
Dim wd As New Word.Application
Dim wdFile As Word.Document
Dim s As String, tmp As String

Dim fso As New FileSystemObject
Dim dict As New Scripting.Dictionary
Dim StopList As New Scripting.Dictionary
Public UserList As New Scripting.Dictionary
Public Chk As Boolean
Dim ts As TextStream

Dim ItemX As ListItem    '对ListItem对象的应用
Dim pnlX As Panel

Private Sub Form_Load()
    'Initialize Controls
    rtext1.Text = ""
    ListView1.Visible = False
    ProgressBar1.Visible = False
    picDrag.Visible = True:    picDrag.Left = rtext1.Left
    StatusBar_Initialize
    ListView1.View = lvwReport
   '添加ListView1的ColumnHeaders。列宽度等于控件宽度除以 ColumnHeader 对象的数目。
   '------------------------------------------------------------------------------------
    With ListView1.ColumnHeaders
        .Add , , "词语", ListView1.Width - TextWidth(" 词语 ")
        .Add , , "词频", TextWidth(" 词语 "), lvwColumnRight
        .Add , , "排序词频", 0    '此为辅助栏，帮助词频按数字大小排序。
'        .Item(2).Alignment = lvwColumnRight    'ColumnHeaders(1)即使ListItem
    End With
    
    '用户设置
    '-------------------------------------------
    frmMain.Caption = "词频统计工具 v1.0 "
    File1.Pattern = "*.doc;*.html;*.htm;*.rtf;*.TXT"
    Dir1.Path = App.Path
    '-------------------------------------------
    If fso.FileExists(App.Path & "\StopList.txt") Then BuildList "StopList.txt", StopList
    If fso.FileExists(App.Path & "\UserList.txt") Then BuildList "UserList.txt", UserList
End Sub

Sub BuildList(fName As String, d As Scripting.Dictionary)
    Dim tmpStr$
    Set ts = fso.OpenTextFile(App.Path & "\" & fName, ForReading)
    Do While ts.AtEndOfStream <> True
    tmpStr = ts.ReadLine
    d.Add tmpStr, ""
    Loop
    ts.Close
End Sub
Private Sub Form_Resize()
    Layout
End Sub

Private Sub Dir1_Change()
    File1.Path = Dir1.Path
End Sub

Private Sub File1_Click()
    On Error GoTo er1
    ChDrive File1.Path
    ChDir File1.Path
    
    s = File1.FileName
    tmp = fso.GetBaseName(s) & ".TXT"
    
    s = File1.Path & "\" & s
    tmp = File1.Path & "\" & tmp
    
    If Not fso.FileExists(tmp) Then
        Set wdFile = wd.Documents.Open(s)
        wdFile.SaveAs tmp, wdFormatText
        wdFile.Close
    End If
    
    rtext1.LoadFile tmp
    rtext1.Refresh
    Exit Sub
er1:
    MsgBox Err.Description, vbExclamation
End Sub


Private Sub mnu_Click()
    frmSetting.Show
End Sub

Private Sub mnuAbout_Click()
'    MsgBox "This software is for EVALUATION purpose only." _
'    & "If you have any comments or suggestions, please contact me at [e-mail]", vbOKOnly
    MsgBox "This software is specially created for Miss ChenXian." _
    & "If you have any comments or suggestions, please contact me at [e-mail]", vbOKOnly
End Sub

Private Sub mnupreview_Click()
    Dim flag As Boolean
    mnuPreview.Checked = Not mnuPreview.Checked
    flag = mnuPreview.Checked
    ListView1.Visible = Not flag
    rtext1.Visible = flag
    
End Sub

Private Sub mnuGetKeyWords_Click()
    Dim i&, KeyArray, ItemArray
    Dim StartTime As Single, TimeUsed As String
    Dim OutputS As String
    Dim printMax&
    If tmp = "" Then Exit Sub
    Layout
    printMax = 100
    frmMain.Caption = "正在取词，请稍候..."
    ProgressBar1.Visible = Not ProgressBar1.Visible
    StsBar1.Visible = Not StsBar1.Visible
    ListView1.Visible = Not ListView1.Visible
    rtext1.Visible = Not rtext1.Visible
    DoEvents: Me.Refresh
    StartTime = Timer
    '------------------------------------------------
    WREng tmp
    '------------------------------------------------
    TimeUsed = CStr(Round(Timer - StartTime, 2))
    ProgressBar1.Visible = Not ProgressBar1.Visible
    StsBar1.Visible = Not StsBar1.Visible
    frmMain.Caption = "取词完成"
    DoEvents: Me.Refresh
    
    KeyArray = dict.Keys: ItemArray = dict.Items
    ListView1.ListItems.Clear
    For i = 0 To dict.Count - 1
        Set ItemX = ListView1.ListItems.Add(, , KeyArray(i))
        ItemX.SubItems(1) = ItemArray(i)
        ItemX.SubItems(2) = Format(ItemArray(i), "0000")
    Next

    With ListView1
        .SortKey = 2
        .SortOrder = lvwDescending
        .Sorted = True
    End With

    If dict.Count < printMax Then printMax = dict.Count
    For i = 1 To printMax
        OutputS = OutputS & ListView1.ListItems(i).Text & vbTab & ListView1.ListItems(i).SubItems(1) & vbCrLf
    Next i

    rtext1.Text = OutputS
    
    With StsBar1
        .Panels(1).Text = "文长" & ProgressBar1.Max & "个字符"
        .Panels(2).Text = "找到" & dict.Count & "个词汇"
        .Panels(3).Text = "用时" & TimeUsed & "秒"
    End With

End Sub

Private Sub picDrag_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)

    ' start dragging with left button
    If Button <> 1 Then Exit Sub
    picDrag.Visible = True
    
    ' use trick so vertical movement is not visible
    picDrag.Height = 32000
    picDrag.Top = -10000
    picDrag.Drag

End Sub

Private Sub dir1_DragDrop(Source As Control, X As Single, Y As Single)
    rtext1.Left = X
    Layout
End Sub

Private Sub file1_DragDrop(Source As Control, X As Single, Y As Single)
    rtext1.Left = X
    Layout
End Sub

Private Sub rtext1_DragDrop(Source As Control, X As Single, Y As Single)

    'X对应的是相对于目标控件rText中的坐标，所有应该转换到绝对坐标
    rtext1.Left = X + rtext1.Left
    Layout
End Sub

Private Sub Layout()    '以rText1.left为标准对齐给控件
    On Error Resume Next
    With rtext1
        .Move .Left, 0, ScaleWidth - .Left, ScaleHeight
        Dir1.Move 0, 0, .Left, ScaleHeight / 2
        File1.Move 0, ScaleHeight / 2, .Left, ScaleHeight / 2
        picDrag.Move .Left - 25, 0, 50, ScaleHeight
        ListView1.Move .Left, .Top, .Width, .Height
    End With
    
    With picDrag
        .MousePointer = 9 'ccSizeEW  ' to show resizing cursor
        .BackColor = BackColor ' don't show this control, only the mouse cursor
    End With
    
    With StsBar1
        ProgressBar1.Move .Left, .Top, .Width, .Height
    End With
End Sub

Private Sub StatusBar_Initialize()
    Dim index&
   For index = 1 To 2 '第一个面板已存在。
      Set pnlX = StsBar1.Panels.Add()
   Next index
   
   '改变所有面板的 AutoSize。
   For index = 1 To 3
      StsBar1.Panels(index).AutoSize = sbrSpring
   Next index
   
   With StsBar1
        .Panels(1).Text = "总字数"
        .Panels(2).Text = "词数"
        .Panels(3).Text = "用时"
   End With
   
End Sub


Function IsChinese(CharX As String) As Boolean
    Dim i&
    i = Asc(CharX)
    If i < 0 Then
        Select Case i
            Case -24251 To -23400   '中文标点的范围
                IsChinese = False
            Case Else
                IsChinese = True
        End Select
    Else
        Select Case i
            Case 65 To 90, 97 To 122  '(A-Z,a-z) ；(0-9) 48 To 57,
                IsChinese = True
            Case Else
                IsChinese = False
        End Select
    End If
End Function                'Case "，", "。", "：", "；", "！", "？", "……", "”", "“", "‘", "’", "、", "－"


Sub WREng(ByVal fName As String)
'Const conWordLenMax = 10
    Dim Sall$
    Dim Counts&
    Dim NewWord$, iNext&
    Dim i&, j&
    
    Set ts = fso.OpenTextFile(fName, ForReading)
    dict.RemoveAll
    Sall = ts.ReadAll
    Sall = Trim(Sall)
    Sall = StrConv(Sall, vbProperCase)
    
    'Step 1: pre-Treatment(a)
    For i = 9 To 127
        Select Case i
            Case 9, 13, 40, 41  'Tab,Enter,(,)
                Sall = Replace(Sall, Chr(i), " ")
            Case 32, 45 To 47, 58, 64 To 90, 97 To 122
'                Stop
            Case Else
                Sall = Replace(Sall, Chr(i), "")
        End Select
        DoEvents
    Next
    
    Sall = Replace(Sall, "'s", "")
    Sall = Replace(Sall, ". ", " ")
    Sall = Replace(Sall, ": ", " ")
    DoEvents
    
    Do Until InStr(Sall, "  ") = 0
        Sall = Replace(Sall, "  ", " ")
        DoEvents
    Loop
    
    'UserList
    '----------------------------------------------------------------
    Dim A
    If UserList.Count <> 0 Then
        A = UserList.Keys
        For i = 0 To UBound(A)
            NewWord = A(i)
            iNext = InStr(Sall, NewWord)
            If iNext <> 0 Then
                Counts = 1
                Do
                    iNext = InStr(iNext + Len(NewWord), Sall, NewWord)
                    If iNext = 0 Then
                        Exit Do
                    Else
                        Counts = Counts + 1
                    End If
                Loop
                        
                '将新词加入词典
                dict.Add NewWord, Counts
                        
                '删除已取出的词汇
                Sall = Replace(Sall, NewWord, "")
            End If
            If i Mod 10 = 0 Then DoEvents
        Next
    End If
    
    If Chk Then Exit Sub
    Do Until InStr(Sall, "  ") = 0
        Sall = Replace(Sall, "  ", " ")
    Loop

    
    'Step 3: Main Procedure
    '-------------------------------------------------------------------
    j = 0   '计次
    Sall = Trim(Sall) & " "
    TotalLen = Len(Sall)
    ProgressBar1.Max = TotalLen
    i = 1   '词首位置
    iNext = InStr(i + 1, Sall, " ") '词尾位置
    Do Until i > TotalLen
       NewWord = Mid(Sall, i, iNext - i)
       If Len(NewWord) > 1 Then
            If dict.Exists(NewWord) Then
                 dict.Item(NewWord) = dict.Item(NewWord) + 1
            Else
                 dict.Add NewWord, 1
            End If
       End If
        
       i = iNext + 1
       iNext = InStr(i, Sall, " ")
       
       j = j + 1
       If j Mod 10 = 0 Then
            ProgressBar1.Value = i
            DoEvents
       End If
    Loop
    ProgressBar1.Value = TotalLen
End Sub