请教守柔版主关于VB问题

zoushiru

请教守柔版主，下面的要求，用VB如何实现？

任意一篇WORD文档，首先统计文档中某些标点符号的总数（假设需统计的标点为“，”“。”“？”即中文标点逗号、句号和问号），设为sum1。

一个2进制序列（例如：011000100111001010101100）计算它的位数（本例为24）sum2。此2进制序列来自于VB中的自定义函数，可认为是随机值。

如果sum1<sum2，则提示信息“操作无法完成！”

如果sum1>=sum2，则根据2进制序列，对WORD文档进行如下操作：在文档中出现的第一个“，”或者“。”或者“？”后插入属性为上标、字号为15磅的0，第二个“，”或者“。”或者“？”后插入属性为下标、字号为15磅的1，第三个“，”或者“。”或者“？”后插入属性为下标、字号为15磅的1，第四个“，”或者“。”或者“？”后插入属性为上标、字号为15磅的0......以此类推。（也就是说把2进制序列中的0换成属性为上标、字号为15磅的0，把1换成属性为下标、字号为15磅的1，依次插入到文档中指定的标点符号后）。

最后，对于任意一篇WORD文档，先检查有没有按此方式插入的0和1的字符（即属性为上标、字号为15磅的0和属性为下标、字号为15磅的1，且位置是在相应标点符号之后。），如果没有则提示“没有发现！”。如果有，则将2进制序列整理出来，输出到.txt文件。

作为示例的文件已上传。

我是VBA的初学者，希望能得到版主的指点。我所使用的系统是WindowsXP、office2000、VB6.0。

ny1pTlET.rar (6.14 KB, 下载次数: 17)

2005-2-21 20:31 上传

点击文件名下载附件
请教守柔版主关于VB问题

守柔

注意，你的处理后的文档，有一个标点符号漏标。另外，应该在标点符号后面设置上下标。（按实例）

请按代码头提示进行粘贴和运行以下代码：

'* ＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋ '* Created By I Love You_Word!@ExcelHome 2005-2-22 07:28:29 '仅测试于System: Windows NT Word: 10.0 Language: 2052 '^The Code CopyIn [ThisDocument-ThisDocument]^' '* －－－－－－－－－－－－－－－－－－－－－－－－－－－－－

Sub InterpunctionCount() Dim MyIptBox As String, MyArray() As String, aArray As Variant, N As Integer Dim BinString As String, I As Range, UpDown As String N = 0: BinString = "011000100111001010101100" '初始化变量 MyIptBox = InputBox("请输入您想要查找/统计的标点符号,以/(斜杠)号分隔!") If MyIptBox = "" Then Exit Sub '如果为""或者按下取消键则退出程序 MyArray = VBA.Split(MyIptBox, "/") '以"/"分隔取得数组 Application.ScreenUpdating = False '关闭屏幕更新 For Each aArray In MyArray '在数组中循环 With ActiveDocument.Content.Find '查找指定的标点符号数量 .ClearFormatting '清除查找格式 Do While .Execute(FindText:=aArray, Forward:=True, MatchCase:=True) = True N = N + 1 '累加 Loop End With Next ' MsgBox N If N < Len(BinString) Then MsgBox "此操作不可完成!", vbOKOnly + vbCritical, "Warning" _ : Exit Sub For Each I In ActiveDocument.Words '在词中循环并着色 If InStr(MyIptBox, I) > 0 Then I.Bold = True: I.Font.Color = wdColorRed Next N = 0 Selection.HomeKey wdStory '移到文档首位置 With Selection.Find '设置查找条件 .ClearFormatting '清除查找格式 .Font.Color = wdColorRed '设置为红色 .Font.Bold = True '设置为粗本 .Text = "" While .Execute N = N + 1 '累加 UpDown = Mid(BinString, N, 1) If N > Len(BinString) Then '当超过二进制文本长度时 With .Replacement '设置一次性替换 .ClearFormatting '清除替换格式 .Font.Bold = False '替换为常规字体 .Font.Color = wdColorAutomatic '自动颜色(黑色) End With .Execute FindText:="", ReplaceWith:="", Format:=True, _ Replace:=wdReplaceAll '将剩余格式恢复 Application.ScreenUpdating = True '恢复屏幕更新 End '终止程序 End If With Selection .InsertAfter UpDown '插入指定的二进制值 .Font.Bold = False '恢复常规字体 .Font.Color = wdColorAutomatic '自动颜色 '如果为1则为下标,如果为0则为上标 If UpDown = 1 Then .Characters(2).Font.Subscript = True _ Else .Characters(2).Font.Superscript = True .Characters(2).Font.Size = 15 '设置字号 .HomeKey wdStory '移到文档首 End With Wend End With Application.ScreenUpdating = True '恢复屏幕更新 End Sub '---------------------- 检查一下是否有问题，再作交流，包括检查是否有上下标的事宜，宜在此基础上深入。

由于使用大量的单个查找与替换，以及在词循环，以及反复插入与字体设置，受CPU和内存影响，运行速度及代码效率不是很高（也许有更好地办法），此程序运行需要一定时间。

zoushiru

非常感谢守柔版主这么快就给予了解答，我好好研究代码先！

THANK

守柔

引用[最后，对于任意一篇WORD文档，先检查有没有按此方式插入的0和1的字符（即属性为上标、字号为15磅的0和属性为下标、字号为15磅的1，且位置是在相应标点符号之后。），如果没有则提示“没有发现！”。如果有，则将2进制序列整理出来，输出到.txt文件。]

请参以下代码：

'* ＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋ '* Created By I Love You_Word!@ExcelHome 2005-2-23 07:15:16 '仅测试于System: Windows NT Word: 10.0 Language: 2052 '^The Code CopyIn [ThisDocument-ThisDocument]^' '* －－－－－－－－－－－－－－－－－－－－－－－－－－－－－

Sub CheckAndWriteBinInTxt() Dim I As Range, MyString As String, FS As Object, NewTxt As Object, Fodler As String FileName = "C:\Test\TestFile.txt" '预置一个文件名 For Each I In ActiveDocument.Words '在词中循环 If I.Font.Subscript Or I.Font.Superscript Then '如果字体为上标或者下标 If I = "1" Or I = "0" Then '1或0 MyString = MyString & I '累加数据 End If End If Next ' MsgBox MyString '如果未找到则提示,当然此处可以接着运行InterpunctionCount过程 If MyString = "" Then MsgBox "Word 没有发现指定的搜索内容,按OK后退出程序运行!", vbOKOnly + vbInformation: Exit Sub Set FS = CreateObject("Scripting.FileSystemObject") '创建系统文件夹 Set NewTxt = FS.CreateTextFile(FileName, True) '新建一个文本文件 NewTxt.WriteLine MyString '将数据写入 NewTxt.Close '关闭文本文件 End Sub '----------------------