module1.bas

英文和蒙古文单词提取程序! 供少数民族怨言研究者参考使用! 还请多多请教!

Attribute VB_Name = "Module1"
Option Explicit '强制声明所有变量

'API内存方式交换变量,经测试,此例中比直接交换还要慢 :(
'Public Declare Sub CopyMemory Lib "Kernel32" Alias "RtlMoveMemory" _
(Destination As Any, Source As Any, ByVal Length As Long)

'API调用打开和保存的对话框
Public Declare Function GetOpenFileName Lib "comdlg32.dll" Alias _
"GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long

'上面的API所需要的类型声明
Type OPENFILENAME
lStructSize As Long
hwndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type

'几个自定义的变量,打开文件的位置,存储文件的位置,时间初值,临时数组
Public OFilePath$, SFilePath$, Stime!, tmp2$()


'===代码部分================================================

Public Function GFileName() As String '打开文件对话框
On Error GoTo NikeeError '错误跳转

Dim ofn As OPENFILENAME
Dim rtn As Long

ofn.lStructSize = Len(ofn)        '下面一行是文件类型↓
ofn.lpstrFilter = "文本文件 (*.txt)" & Chr$(0) & "*.txt" & Chr$(0)
ofn.lpstrFile = Space(254)
ofn.nMaxFile = 255
ofn.lpstrFileTitle = Space(254)
ofn.nMaxFileTitle = 255
' ofn.lpstrInitialDir = App.Path
ofn.flags = 6148
ofn.lpstrTitle = "请选择需要提取单词的文本文件..." '提示窗口标题
rtn = GetOpenFileName(ofn) '得到文件名

If rtn >= 1 Then '返回1的话,说明不是按取消键返回的
    GFileName = Trim(ofn.lpstrFile) '去除文件名2端的空格
    GFileName = Replace(GFileName, Chr(0), "") '去除尾部的chr0分隔符
End If

Exit Function
NikeeError: '错误跳转
MsgBox "未知原因导致操作失败!", 48, " 错误提示:"
End Function


Public Sub Main()
OFilePath$ = GFileName() '通过自定义的GFileName函数得到打开文件的路径
If Len(OFilePath$) = 0 Then Exit Sub '如果文件名为空退出程序

SFilePath$ = OFilePath$ '根据得到的打开文件名,生成保存文件名

    If Right(LCase(SFilePath$), 4) <> ".txt" Then
      SFilePath$ = SFilePath$ & ".txt"
    End If '如果文件名尾部不是txt,则置为txt
     
    '生成文件名的尾部标识
SFilePath$ = Replace(SFilePath$, ".txt", "_提取单词.txt")

If Len(SFilePath$) = 0 Then Exit Sub '如果保存文件名为空退出程序
Call EwordsTQ '进入自定义的提取过程
End Sub


Public Sub EwordsTQ() '提取单词函数

'一堆的变量,分别为:得到的文本字符串,文本长度,单词标识符,
'           临时字符串变量,计数i,计数j,临时数组,最终存放单词的数组
Dim tmp1$, TxtLen&, Ese As Boolean, s$, i&, j&, Ewords$()

'如果找不到需要打开的文件,则提示错误并退出
If Len(Dir(OFilePath$)) = 0 Then
MsgBox "未知原因导致操作失败!", 48, " 错误提示:"
Exit Sub
End If

'打开文件,将所有文本存放到tmp1变量中
Open OFilePath$ For Binary As #1
tmp1 = Space(LOF(1)) '用空格填充tmp1变量
Get #1, , tmp1        '用Get语句获取文件全部内容
Close #1

'去除前后空格,并转换字母为小写
tmp1 = Trim(LCase(tmp1))

TxtLen = Len(tmp1) '得到字符串长度

'如果得到字符串为空,刚提示错误并退出
If TxtLen = 0 Then
MsgBox "这个文件里面好象没啥内容呀!!", 48, " 特别提示:"
Exit Sub
End If

'准备进入提取阶段
Stime = Timer      '开始计时

ReDim tmp2$(TxtLen) '用字符串长度先来声明临时变量数组下标
Ese = False '置标志位为否

For i = 1 To TxtLen& '从第1个字符循环到文件尾
    s = Mid(tmp1, i, 1) '得到1个字符,放入临时变量s
      If s Like "[a-z]" Then '如果s是小写字母
      
        If Ese = False Then '如果原标志位是否
          tmp2$(j) = s '得到第1个字母
          j = j + 1 '数组标志+1
          Ese = True '标志位为是
        Else '如果标志位为是,则说明是连续字母
          tmp2$(j - 1) = tmp2$(j - 1) & s '叠加此字母到刚刚的数组中
        End If
        
      Else
        If Ese = True Then Ese = False '如果不是字母,且标志位是,则置标志位否
      End If '完成此字符判断
      
Next '循环下一个字母,直至文件尾

'如果计数标志是大于1的,将临时数组tmp2尾部多余元素删除
If j > 1 Then ReDim Preserve tmp2$(j - 1)

Call QuickSort(tmp2, 0, j - 1) '快速排序法排序所有单词

ReDim Ewords$(j - 1) '为最终存放单词的数组,重定义下界

Ewords$(0) = tmp2$(0) '取出第1个单词放入数组
j = 1 '单词计数为1

For i = 1 To UBound(tmp2) '循环从数组中取出每个单词和最终数组中的上个单词比较
    If tmp2$(i) <> Ewords$(j - 1) Then '不等则
      Ewords$(j) = tmp2$(i) '添加入最终数组
      j = j + 1 '数组标识位+1
    End If
Next

If j > 1 Then ReDim Preserve Ewords$(j - 1) '清除数组尾部空白元素

'生成保存文件的头部字符串和所有得到的单词
tmp1 = vbCrLf & String(40, "=") & vbCrLf
tmp1 = tmp1 & " 文本单词提取 V 2.01 By sir *^-^*" & vbCrLf
tmp1 = tmp1 & String(40, "=") & vbCrLf & vbCrLf
tmp1 = tmp1 & " 完成提取单词!!" & vbCrLf
tmp1 = tmp1 & " 一共提取出了" & UBound(Ewords$) + 1 & "个单词!!" & vbCrLf
tmp1 = tmp1 & " 本次提取用时:" & Format(Timer - Stime, "0.0000") & "秒!!"
tmp1 = tmp1 & vbCrLf & vbCrLf & vbCrLf & Join(Ewords$, vbCrLf)

'保存文件
Open SFilePath$ For Output As #1
Print #1, tmp1
Close #1

'置空数组,释放内容
ReDim tmp2$(0), Ewords$(0)

'提示完成
MsgBox "提取完毕!", 48, " sir提示:"

'打开记事本,并显示生成的文件
Shell "notepad.exe " & SFilePath$, 1
End Sub


Public Sub QuickSort(tmp2$(), L&, R&) '快速排序子过程
If Not IsArray(tmp2$) Then Exit Sub
Dim i&, j&, x$, y$, m&
i = L
j = R
m = (L + R) / 2
' Call CopyMemory(x, tmp2(m), 4) '尝试过使用api来交换变量
x = tmp2(m) '得到分界值
While i <= j '先分区
   While tmp2(i) < x And i < R
     i = i + 1
   Wend
   While x < tmp2(j) And j > L
     j = j - 1
   Wend
If i <= j Then
     y = tmp2(i)
     tmp2(i) = tmp2(j)
     tmp2(j) = y
'     Call CopyMemory(y, tmp2(i), 4)
'     Call CopyMemory(tmp2(i), tmp2(j), 4)
'     Call CopyMemory(tmp2(j), y, 4)
    i = i + 1
    j = j - 1
End If
Wend
If L < j Then Call QuickSort(tmp2, L, j)
If i < R Then Call QuickSort(tmp2, i, R)
End Sub




'===============END====================