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
      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
    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