您所在位置：主题：[原创]编写超级记事本必需的十六个功能源代码（四）
一江秋水
[专家分：9680] 发布于 2007-09-20 11:06:00
十三、文本分割
如果一篇长篇大论的文章中有许多章节，可使用这种方式分割成若干个小文件（最多分割成15个小
文件，当然，对代码稍加改动就可分割得更多），以方便阅读。
代码中的关键字是分割的依据，例如：章、节、回、篇、部，等等，都可作为关键字。
如果原文章是以阿拉伯数字或罗马数字来标示章节的，请一律替换成中文的数字。如：“第1章”
替换为“第一章”，“第2章”替换为“第二章”……，“第1回”替换为“第一回”，“第2回”替换
为“第二回”……，等等
分割保存的文件自动以递增的数字为文件名，如：“第一章”保存的文件名为“001.txt”，“第
二章”保存的文件名为“002.txt”，等等
分割的文件保存在记事本主程序文件所在的文件夹，你可以稍加修改便能保存在任何地方
'输入参数：欲分割的文本，关键字
Sub TextDivision(TextST As String, KeyWord As String)
Dim TPlace As Long '关键字的位置
Dim TName As String '保存的文件名
Dim sh(16) As String
Dim j As Long, BJ As Boolean
sh(1) = "第一" & KeyWord: sh(2) = "第二" & KeyWord: sh(3) = "第三" & KeyWord
sh(4) = "第四" & KeyWord: sh(5) = "第五" & KeyWord: sh(6) = "第六" & KeyWord
sh(7) = "第七" & KeyWord: sh(8) = "第八" & KeyWord: sh(9) = "第九" & KeyWord
sh(10) = "第十" & KeyWord: sh(11) = "第十一" & KeyWord: sh(12) = "第十二" & KeyWord
sh(13) = "第十三" & KeyWord: sh(14) = "第十四" & KeyWord: sh(15) = "第十五" & KeyWord
sh(16) = "第十六" & KeyWord
TName = App.Path & "\"
TPlace = 1
For i = 1 To 16
TPlace = InStr(TPlace, TextST, sh(i))
If TPlace > 0 Then
If BJ Then GoSub 100 Else j = TPlace: BJ = True
TPlace = TPlace + Len(sh(i))
Else
If BJ Then TPlace = Len(TextST): GoSub 100: Exit For Else TPlace = 1
End If
Next
Exit Sub
100
TName = ST & Right$("000" & i - 1, 3) & ".txt"
Open TName For Output As #1
Print #1, Mid$(TextST, j, TPlace - j)
Close
j = TPlace
Return
End Sub
十四、文件拖放
文件拖放有两个含义：
1.一拖即开：可以将文本文件拖放到文本框窗口，如果只有一个文件，就打开该文件，如果有多个文件，
就进行文本合并；
2.一拖即存：首先选定一段文本，然后按住鼠标右键拖动至窗口外，就可将该段文本存盘，存盘路径与
打开的现有文件相同，存盘文件名是在现有文件名后面自动加上序数。
代码中用到了一个检测鼠标位置的API函数 GetCursorPos。该函数只有一个参数，即POINTAPI结构，
它用于检测选中的文本是否拖出了窗体。
设置文本框属性：DLEDropMode＝1
另外，窗体上还要添加一个计时器
Option Explicit
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Type POINTAPI
X1 As Long
Y1 As Long
End Type
Dim FileName As String
Private Sub Text1_OLEDragOver(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single, State As Integer)
If Right(UCase(Data.Files.Item(1)), 3) = "TXT" Then '如果拖入的是文本文件
Effect = vbDropEffectCopy And Effect '显示可以放下的带小加号的图标
Else
Effect = vbDropEffectNone '否则显示不可放下的圆圈加斜线的图标
End If
End Sub
Private Sub Text1_OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim i As Integer, ST As String
For i = 1 To Data.Files.Count
FileName = Data.Files.Item(i) '获取文件名
If Right(UCase(Data.Files.Item(1)), 3) = "TXT" Then '如果拖入的是文本文件
ST = Space(FileLen(FileName))
Open FileName For Binary As #1
Get #1, , ST
Close
Text1 = Text1 & ST ' 如果拖放了多个文件进行文本合并
End If
Next
End Sub
Private Sub Text1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = 2 Then Text1.Enabled = False: Text1.Enabled = True
End Sub
Private Sub Text1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = 2 And Text1.SelLength > 0 Then Timer1.Enabled = True: Screen.MousePointer = 15 '显示十字形的鼠标
End Sub
Private Sub Text1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = 1 Then Clipboard.SetText Text1.SelText '将选中的文本送入剪贴板
If Timer1.Enabled Then Timer1.Enabled = False: Screen.MousePointer = 0 '如果鼠标没有拖出窗口就松开则关闭计时器并复原鼠标
End Sub
Private Sub Timer1_Timer()
Dim PO As POINTAPI
GetCursorPos PO '检测鼠标位置
If (PO.X1 < Left \ 15 Or PO.X1 > (Left + Width) \ 15 Or PO.Y1 < Top \ 15 Or PO.Y1 > (Top + Height) \ 15) And Text1.SelLength > 0 Then '如果剪贴板不为空，并且鼠标移出窗体外
Static Num As Integer
Dim sFileName As String, i As Integer
If FileName = "" Then FileName = App.Path & "\1.txt" '如果没有文件名，就以1.txt为名保存到当前路径
Num = Num + 1: i = InStr(1, FileName, ".")
sFileName = Left(FileName, i - 1) & "(" & Format(Num) & ")" & Mid(FileName, i) '在原FileName添加序号作为新FileName
Open sFileName For Output As #1
Print #1, Text1.SelText '将内容存入文件
Close
Timer1.Enabled = False: Screen.MousePointer = 0 '鼠标复原
End If
End Sub
以上代码中，OLEDragOver事件和OLEDragDrop事件的作用是处理拖进来的文本文件，3个鼠标事件和
计时器事件处理拖出去的文本。其中：
Text1_MouseDown事件的作用是不显示文本框的右键弹出菜单
MouseMove事件判断如果是右键拖动，就启动计时器
Timer1_Timer事件判断如果鼠标移出窗口，就将选定文本保存。其中的有关数据除以 15 的目的是保
持计量单位的统一（API函数用“像素”，VB默认用“缇”，1像素＝15缇）。
十五、提取文件名
这个功能将某个文件夹下用户所选中的文件名全部提取出来，形成列表，也许这正是你所需要的。
当然，提取的不仅仅是文件名，还有该文件的部分属性值。
在主文本框所在的窗体上添加一个菜单项，标题是“提取文件名”，名称是“mExtractFileName”。
代码如下：
Sub mExtractFileName_Click()
On Error GoTo 100
Dim FolderPath As String '文件夹路径
Dim fName As String '文件名
Dim fNameAll As String '所有文件名
Dim ST As String, z As String, i As Integer, k As Integer
With CommonDialog1
.MaxFileSize = 3200 '加大文件名缓冲区
.Flags = &H1204
.Filter = "*.txt|*.txt"
.ShowOpen
z = .FileName
End With
FolderPath = CurDir & "\" '获取路径
fNameAll = Mid$(z, InStrRev(z, "\") + 2) & Chr(32) '获取去除路径后的所有文件名
ST = "顺号 文件名" & Space(38) & "大小（KB） 属性 最后修改时间" & vbCrLf & String(92, "-") & vbCrLf
Do While Len(fNameAll) > 0
k = k + 1
i = InStr(fNameAll, Chr(32))
fName = Left$(fNameAll, i - 1)
fNameAll = Mid$(fNameAll, i + 1)
z = fName: Do While lstrlen(z) > 45: z = Left$(z, Len(z) - 1): Loop '修理文件名，不使它超过规定长度
ST = ST & Right$("000" & Format(k), 4) & " " & z & Space(44 - lstrlen(z)) & GetFileATR(FolderPath & fName) & vbCrLf '文件名累加
Loop
Text1 = ST
100
End Sub
Function GetFileATR(Nam As String) As String '获取文件属性
Dim fLen As Long, attr As Integer, zat As String
fLen = FileLen(Nam)
zat = Format(fLen / 1024, "###,##0.00")
zat = Right$(Space(9) & zat, 9)
attr = GetAttr(Nam)
If attr And 1 Then zat = zat & " 只读"
If attr And 2 Then zat = zat & " 隐藏"
If attr And 4 Then zat = zat & " 系统"
zat = zat & Space(24 - lstrlen(zat)) & FileDateTime(Nam)
GetFileATR = zat
End Function
十六、提取文本标题
这个功能将某个文件夹下用户所选中的文本文件的标题全部提取出来，形成列表，也许这正是你所
需要的。
在主文本框所在的窗体上添加一个菜单项，标题是“提取文本标题”，名称是
“ExtractTextCaption”，代码如下：
Sub ExtractTextCaption_Click()
On Error GoTo inerr
Dim FolderPath As String '文件夹路径
Dim fName As String '文件名
Dim fNameAll As String '所有文件名
Dim ST1 As String, ST2 As String, ST3 As String, z As String, i As Integer, k As Integer
With CommonDialog1
.MaxFileSize = 3200 '加大文件名缓冲区
.Flags = &H1204
.Filter = "*.txt|*.txt"
.ShowOpen
z = .FileName
End With
FolderPath = CurDir & "\" '获取路径
fNameAll = Mid$(z, InStrRev(z, "\") + 2) & Chr(32) '获取去除路径后的所有文件名
Do While Len(fNameAll) > 0
i = InStr(fNameAll, Chr(32))
fName = Left$(fNameAll, i - 1)
fNameAll = Mid$(fNameAll, i + 1)
ST1 = ""
On Error Resume Next '防止下面读空文件时出错退出
Open FolderPath & fName For Input As #1
Do While ST1 = ""
Line Input #1, ST1
If ST1 <> "" Or EOF(1) Then Exit Do
Loop
Close
On Error GoTo inerr
fName = Mid$(fName, InStrRev(fName, "\") + 1)
fName = Left$(fName, InStr(fName, ".") - 1)
Do While lstrlen(fName) > 40: fName = Left$(fName, Len(fName) - 2): Loop '修理文件名，使它不超过规定长度
fName = Left$(fName & Space(41 - lstrlen(fName)), 40)
If ST1 <> "" Then
ST1 = Trim(ST1)
Do While Left$(ST1, 1) = " ": ST1 = Mid$(ST1, 2): Loop '修理标题，使它不超过规定长度
ST2 = ST2 & fName & ST1 & vbCrLf & "〇"
Else: ST2 = ST2 & fName & "无标题" & vbCrLf & "〇"
End If
Loop
z = "文件名" & Space(35) & "标 题" & vbCrLf & String(92, 45) & vbCrLf
Do While Len(ST2) > 0: i = InStr(ST2, "〇"): ST1 = Left$(ST2, i - 1): ST2 = Mid$(ST2, i + 1): z = z & ST1: Loop
Text1 = z
inerr:
Close
End Sub
如果一篇长篇大论的文章中有许多章节，可使用这种方式分割成若干个小文件（最多分割成15个小
文件，当然，对代码稍加改动就可分割得更多），以方便阅读。
代码中的关键字是分割的依据，例如：章、节、回、篇、部，等等，都可作为关键字。
如果原文章是以阿拉伯数字或罗马数字来标示章节的，请一律替换成中文的数字。如：“第1章”
替换为“第一章”，“第2章”替换为“第二章”……，“第1回”替换为“第一回”，“第2回”替换
为“第二回”……，等等
分割保存的文件自动以递增的数字为文件名，如：“第一章”保存的文件名为“001.txt”，“第
二章”保存的文件名为“002.txt”，等等
分割的文件保存在记事本主程序文件所在的文件夹，你可以稍加修改便能保存在任何地方
'输入参数：欲分割的文本，关键字
Sub TextDivision(TextST As String, KeyWord As String)
Dim TPlace As Long '关键字的位置
Dim TName As String '保存的文件名
Dim sh(16) As String
Dim j As Long, BJ As Boolean
sh(1) = "第一" & KeyWord: sh(2) = "第二" & KeyWord: sh(3) = "第三" & KeyWord
sh(4) = "第四" & KeyWord: sh(5) = "第五" & KeyWord: sh(6) = "第六" & KeyWord
sh(7) = "第七" & KeyWord: sh(8) = "第八" & KeyWord: sh(9) = "第九" & KeyWord
sh(10) = "第十" & KeyWord: sh(11) = "第十一" & KeyWord: sh(12) = "第十二" & KeyWord
sh(13) = "第十三" & KeyWord: sh(14) = "第十四" & KeyWord: sh(15) = "第十五" & KeyWord
sh(16) = "第十六" & KeyWord
TName = App.Path & "\"
TPlace = 1
For i = 1 To 16
TPlace = InStr(TPlace, TextST, sh(i))
If TPlace > 0 Then
If BJ Then GoSub 100 Else j = TPlace: BJ = True
TPlace = TPlace + Len(sh(i))
Else
If BJ Then TPlace = Len(TextST): GoSub 100: Exit For Else TPlace = 1
End If
Next
Exit Sub
100
TName = ST & Right$("000" & i - 1, 3) & ".txt"
Open TName For Output As #1
Print #1, Mid$(TextST, j, TPlace - j)
Close
j = TPlace
Return
End Sub
十四、文件拖放
文件拖放有两个含义：
1.一拖即开：可以将文本文件拖放到文本框窗口，如果只有一个文件，就打开该文件，如果有多个文件，
就进行文本合并；
2.一拖即存：首先选定一段文本，然后按住鼠标右键拖动至窗口外，就可将该段文本存盘，存盘路径与
打开的现有文件相同，存盘文件名是在现有文件名后面自动加上序数。
代码中用到了一个检测鼠标位置的API函数 GetCursorPos。该函数只有一个参数，即POINTAPI结构，
它用于检测选中的文本是否拖出了窗体。
设置文本框属性：DLEDropMode＝1
另外，窗体上还要添加一个计时器
Option Explicit
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Type POINTAPI
X1 As Long
Y1 As Long
End Type
Dim FileName As String
Private Sub Text1_OLEDragOver(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single, State As Integer)
If Right(UCase(Data.Files.Item(1)), 3) = "TXT" Then '如果拖入的是文本文件
Effect = vbDropEffectCopy And Effect '显示可以放下的带小加号的图标
Else
Effect = vbDropEffectNone '否则显示不可放下的圆圈加斜线的图标
End If
End Sub
Private Sub Text1_OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim i As Integer, ST As String
For i = 1 To Data.Files.Count
FileName = Data.Files.Item(i) '获取文件名
If Right(UCase(Data.Files.Item(1)), 3) = "TXT" Then '如果拖入的是文本文件
ST = Space(FileLen(FileName))
Open FileName For Binary As #1
Get #1, , ST
Close
Text1 = Text1 & ST ' 如果拖放了多个文件进行文本合并
End If
Next
End Sub
Private Sub Text1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = 2 Then Text1.Enabled = False: Text1.Enabled = True
End Sub
Private Sub Text1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = 2 And Text1.SelLength > 0 Then Timer1.Enabled = True: Screen.MousePointer = 15 '显示十字形的鼠标
End Sub
Private Sub Text1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = 1 Then Clipboard.SetText Text1.SelText '将选中的文本送入剪贴板
If Timer1.Enabled Then Timer1.Enabled = False: Screen.MousePointer = 0 '如果鼠标没有拖出窗口就松开则关闭计时器并复原鼠标
End Sub
Private Sub Timer1_Timer()
Dim PO As POINTAPI
GetCursorPos PO '检测鼠标位置
If (PO.X1 < Left \ 15 Or PO.X1 > (Left + Width) \ 15 Or PO.Y1 < Top \ 15 Or PO.Y1 > (Top + Height) \ 15) And Text1.SelLength > 0 Then '如果剪贴板不为空，并且鼠标移出窗体外
Static Num As Integer
Dim sFileName As String, i As Integer
If FileName = "" Then FileName = App.Path & "\1.txt" '如果没有文件名，就以1.txt为名保存到当前路径
Num = Num + 1: i = InStr(1, FileName, ".")
sFileName = Left(FileName, i - 1) & "(" & Format(Num) & ")" & Mid(FileName, i) '在原FileName添加序号作为新FileName
Open sFileName For Output As #1
Print #1, Text1.SelText '将内容存入文件
Close
Timer1.Enabled = False: Screen.MousePointer = 0 '鼠标复原
End If
End Sub
以上代码中，OLEDragOver事件和OLEDragDrop事件的作用是处理拖进来的文本文件，3个鼠标事件和
计时器事件处理拖出去的文本。其中：
Text1_MouseDown事件的作用是不显示文本框的右键弹出菜单
MouseMove事件判断如果是右键拖动，就启动计时器
Timer1_Timer事件判断如果鼠标移出窗口，就将选定文本保存。其中的有关数据除以 15 的目的是保
持计量单位的统一（API函数用“像素”，VB默认用“缇”，1像素＝15缇）。
十五、提取文件名
这个功能将某个文件夹下用户所选中的文件名全部提取出来，形成列表，也许这正是你所需要的。
当然，提取的不仅仅是文件名，还有该文件的部分属性值。
在主文本框所在的窗体上添加一个菜单项，标题是“提取文件名”，名称是“mExtractFileName”。
代码如下：
Sub mExtractFileName_Click()
On Error GoTo 100
Dim FolderPath As String '文件夹路径
Dim fName As String '文件名
Dim fNameAll As String '所有文件名
Dim ST As String, z As String, i As Integer, k As Integer
With CommonDialog1
.MaxFileSize = 3200 '加大文件名缓冲区
.Flags = &H1204
.Filter = "*.txt|*.txt"
.ShowOpen
z = .FileName
End With
FolderPath = CurDir & "\" '获取路径
fNameAll = Mid$(z, InStrRev(z, "\") + 2) & Chr(32) '获取去除路径后的所有文件名
ST = "顺号 文件名" & Space(38) & "大小（KB） 属性 最后修改时间" & vbCrLf & String(92, "-") & vbCrLf
Do While Len(fNameAll) > 0
k = k + 1
i = InStr(fNameAll, Chr(32))
fName = Left$(fNameAll, i - 1)
fNameAll = Mid$(fNameAll, i + 1)
z = fName: Do While lstrlen(z) > 45: z = Left$(z, Len(z) - 1): Loop '修理文件名，不使它超过规定长度
ST = ST & Right$("000" & Format(k), 4) & " " & z & Space(44 - lstrlen(z)) & GetFileATR(FolderPath & fName) & vbCrLf '文件名累加
Loop
Text1 = ST
100
End Sub
Function GetFileATR(Nam As String) As String '获取文件属性
Dim fLen As Long, attr As Integer, zat As String
fLen = FileLen(Nam)
zat = Format(fLen / 1024, "###,##0.00")
zat = Right$(Space(9) & zat, 9)
attr = GetAttr(Nam)
If attr And 1 Then zat = zat & " 只读"
If attr And 2 Then zat = zat & " 隐藏"
If attr And 4 Then zat = zat & " 系统"
zat = zat & Space(24 - lstrlen(zat)) & FileDateTime(Nam)
GetFileATR = zat
End Function
十六、提取文本标题
这个功能将某个文件夹下用户所选中的文本文件的标题全部提取出来，形成列表，也许这正是你所
需要的。
在主文本框所在的窗体上添加一个菜单项，标题是“提取文本标题”，名称是
“ExtractTextCaption”，代码如下：
Sub ExtractTextCaption_Click()
On Error GoTo inerr
Dim FolderPath As String '文件夹路径
Dim fName As String '文件名
Dim fNameAll As String '所有文件名
Dim ST1 As String, ST2 As String, ST3 As String, z As String, i As Integer, k As Integer
With CommonDialog1
.MaxFileSize = 3200 '加大文件名缓冲区
.Flags = &H1204
.Filter = "*.txt|*.txt"
.ShowOpen
z = .FileName
End With
FolderPath = CurDir & "\" '获取路径
fNameAll = Mid$(z, InStrRev(z, "\") + 2) & Chr(32) '获取去除路径后的所有文件名
Do While Len(fNameAll) > 0
i = InStr(fNameAll, Chr(32))
fName = Left$(fNameAll, i - 1)
fNameAll = Mid$(fNameAll, i + 1)
ST1 = ""
On Error Resume Next '防止下面读空文件时出错退出
Open FolderPath & fName For Input As #1
Do While ST1 = ""
Line Input #1, ST1
If ST1 <> "" Or EOF(1) Then Exit Do
Loop
Close
On Error GoTo inerr
fName = Mid$(fName, InStrRev(fName, "\") + 1)
fName = Left$(fName, InStr(fName, ".") - 1)
Do While lstrlen(fName) > 40: fName = Left$(fName, Len(fName) - 2): Loop '修理文件名，使它不超过规定长度
fName = Left$(fName & Space(41 - lstrlen(fName)), 40)
If ST1 <> "" Then
ST1 = Trim(ST1)
Do While Left$(ST1, 1) = " ": ST1 = Mid$(ST1, 2): Loop '修理标题，使它不超过规定长度
ST2 = ST2 & fName & ST1 & vbCrLf & "〇"
Else: ST2 = ST2 & fName & "无标题" & vbCrLf & "〇"
End If
Loop
z = "文件名" & Space(35) & "标 题" & vbCrLf & String(92, 45) & vbCrLf
Do While Len(ST2) > 0: i = InStr(ST2, "〇"): ST1 = Left$(ST2, i - 1): ST2 = Mid$(ST2, i + 1): z = z & ST1: Loop
Text1 = z
inerr:
Close
End Sub