以下是引用我爱婷婷在2005-8-19 11:48:45的发言：
1至100000怎么样快速设置为带圈字符，以此类推，请教了。
最近由于我在写书，一直没有时间考虑。
今天，我抽空考虑了一下，快速设置，大量字符，1~100000，手动设置是没有意义的。
做了一个自动执行的程序，注意：
一，文档中的数字（需带圈的字符）一个文档中，不得超过32000个。
二，目前只能设置1~99999，再大没有意义了，一样做
三，请在低宏下打开文档，如果宏安全性为高或中，请设置为低后重启WORD，再打开。
四，请运行常用工具栏中的第一个命令“带圈字符”，将会新建一个文档，将原文档文本和数据以文本和带圈字符的形式出现。
6NGOmMEq.zip
(16.25 KB, 下载次数: 136)
以下代码供参考：
'* ＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋
'* Created By I Love You_Word!@ExcelHome 2005-9-5 16:55:18
'仅测试于System: Windows NT Word: 10.0 Language: 2052
'№ 0006^The Code CopyIn [ThisDocument-ThisDocument]^'
'* －－－－－－－－－－－－－－－－－－－－－－－－－－－－－
Option Explicit
Sub Example()
Dim myRange As Range, myString As String, i As Range, myDoc As Document
Dim myFind() As Variant, oFind As Variant, mySize() As Variant, N As Byte
Dim Temp As String, Pos As Integer
On Error Resume Next '忽略错误
Application.ScreenUpdating = False '关闭屏幕更新
myString = "○," '带圈字符"
Temp = ")" '左括号
'定义一个需要查找的数组,各元素分别代表5位数,四位数,三位数,二位数,一位数,一位数,和左括号
myFind = Array("^#^#^#^#^#", "^#^#^#^#", "^#^#^#", "^#^#", "^#", "^#", ")")
'定义一个需要替换的字号数组
mySize = Array(34.5, 29.5, 18.5, 15.5, 14.5, 9.5, 10.5)
'定义一个新文档
Set myDoc = Documents.Add
With myDoc
For Each i In Me.Words '在本文档的词中循环
If VBA.IsNumeric(i) Then '如果是数值型文本
If i < 100000 Then '如果数值<10万
'定义一个Range对象,始终为新文档(活动文档)的最后位置(结束标记前一个字符位置)
Set myRange = .Range(.Content.End - 1, .Content.End - 1)
'此文档最后增加一个EQ域,其域代码为带圈字符的域代码,其中的数字取出I值
.Fields.Add Range:=myRange, Type:=wdFieldEmpty, Text:= _
"EQ \O(" & myString & Trim(i) & ")", PreserveFormatting:=False
End If
Else
.Content.InsertAfter i '如果不是数值型,直接写入活动文档
End If
Next
.ActiveWindow.View.ShowFieldCodes = True '活动文档显示域代码,以便查找与替换
For N = 0 To 6 '进行一个循环
Select Case N
Case 0
Pos = -5 '字体降低的磅值
Case 1
Pos = -4
Case 2
Pos = -1
Case Else
Pos = 0
End Select
If N > 4 Then myString = "": Temp = ""
'指定查找与替换
With .Content.Find
.ClearFormatting
.Text = myString & myFind(N) & Temp
.Format = True
.Replacement.Font.Size = mySize(N)
.Replacement.Font.Position = Pos
.Execute Replace:=wdReplaceAll
End With
Next
.ActiveWindow.View.ShowFieldCodes = False '显示域结果
End With
Application.ScreenUpdating = True '恢复屏幕更新
End Sub
'----------------------
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2005-8-19 11:48
