对非连续文本区域的研究与探索:
本主题探索在WORD VBA中,返回或选定多个非连续区域的文本内容.
我研究了两个方法:一是利用剪贴板与DATAOBJECT的转换,并通过数组取得全部或者指定文本;二是利用在原文档中的粘贴和撤消功能来完成.
第二个问题,是如何选定多个指定的非连续区域,也许对于实际操作而言,没有实际意义,只要在循环中找到该RANGE对象,便可执行相应操作;但这是一个研究和探索.在WORD中,通常有两种方法可以完成:一是查找操作,将指定的文本进行查找并突出显示,便可全部选定,但可惜的是,我未找到相应的代码(方法语句)支持;第二种便是通过选择格式相似的文本命令,进行操作,但一直有个问题,就是在连续代码中,会出现不是你想要的结果,而是需要手动运行第二个过程(SSF过程),也许这是一个BUG,我不知道.
'* ＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋
'* Created By I Love You_Word!@ExcelHome 2005-2-25 12:28:36
'仅测试于System: Windows NT Word: 10.0 Language: 2052
'^The Code CopyIn [ThisDocument-ThisDocument]^'
'* －－－－－－－－－－－－－－－－－－－－－－－－－－－－－
Option Explicit
Sub GetmultiRange1()
'要求返回所选定文本的区域数(非连续选定块),并取得所有文本的连续内容
Dim TxtString() As String, OldEndRange As Long, NewEndRange As Long
Dim MyRange As Range, aString As Variant, MyString As String, SelCount As Integer
With ActiveDocument
OldEndRange = .Content.End - 1 ''获得原文档的终点位置(不包括最后的段落标记)
With Selection
If .Type = wdSelectionIP Then Exit Sub '如果是光标则退出
Application.ScreenUpdating = False '关闭屏幕更新
.Copy '复制
.EndKey wdStory '移动到文档末尾
.Paste '粘贴
End With
NewEndRange = .Content.End - 1 '获得新文档的终点位置(不包括最后的段落标记)
Set MyRange = .Range(OldEndRange, NewEndRange) '定义一个新的Range对象
TxtString = VBA.Split(MyRange, Chr(13)) '以段落标记为分隔符生成一个一维数组
.Undo 1 '撤消一次操作(即粘贴)
For Each aString In TxtString '在含有所选内容的数组中循环
MyString = MyString & aString '文本累加
Next
SelCount = UBound(TxtString) '取得上标(下标为零开始的数组)+1
If SelCount = 0 Then
MsgBox "您选定了一块区域!", vbOKOnly + vbInformation, "Microsoft Word"
Else
MsgBox "您选定了" & SelCount & "块不连续区域!", vbOKOnly + vbInformation, "Microsoft Word"
End If
MsgBox MyString '取得选定内容
Application.ScreenUpdating = True '恢复屏幕更新
End With
End Sub
'----------------------
'注意:运行此过程(GetmultiRange2)前必须引用MSForms
'即VBE/工具/引用:Microsoft Forms 2.0 Object Library (C:\WINNT\system32\FM20.DLL)
Sub GetmultiRange2()
Dim MyData As DataObject, MyString As String
Dim MyText() As String, aString As Variant, SelText As String
If Selection.Type = wdSelectionIP Then Exit Sub '如果未选中则退出程序
Set MyData = New DataObject '引用新的DataOject
Selection.Copy '选定内容复制
MyData.GetFromClipboard '从剪贴板复制数据到 DataObject
MyString = MyData.GetText(1) '获得DataObject的无格式文本
MyText = VBA.Split(MyString, vbCrLf) '取得一个以VBCRLF为分隔符的数组
For Each aString In MyText '在该数组中循环
SelText = SelText & aString '取得所有选定的文本内容
Next
MsgBox SelText
End Sub
'----------------------
Sub Sample()
'要求将文档同所有相同内容的文本选定,并计数
Dim SearchText As String, i As Integer
SearchText = "我" '指定搜索内容
With ActiveDocument.Content.Find
.ClearFormatting
.Font.Color = wdColorAutomatic
.Text = SearchText
With .Replacement
.ClearFormatting
.Text = SearchText
.Font.Color = wdColorWhite
End With
Do While .Execute(Replace:=wdReplaceOne)
i = i + 1 '循环计数
Loop
End With
MsgBox "WORD找到了" & i & "个指定搜索项目!", vbOKOnly + vbInformation, "Microsoft Word"
' Call SSF'这里有个BUG,只能手工运行SSF,可选定该指定查找项目
End Sub
'----------------------
Sub SSF()
'选定全部带红色底纹的字体格式的文本
With Selection
.HomeKey wdStory '移到文档首
With .Find
.ClearFormatting '清除格式
'查找字体底纹为红色格式
.Font.Color = wdColorWhite
.Format = True
End With
.Find.Execute '查找
End With
Application.Run "SelectSimilarFormatting"
End Sub
'----------------------
Sub FindText()
Dim MyDialog As Dialog
On Error Resume Next
'清除格式
ActiveDocument.Content.Find.ClearFormatting
Set MyDialog = Application.Dialogs(112) '查找对话框
Application.ScreenUpdating = False '关闭屏幕更新
With MyDialog
.Find = "Test"
SendKeys "{TAB}", False '预置
SendKeys "+{+}", False '预置(突出显示所有在该范围内找到的项目)
SendKeys "f", False '预置(查找全部)
SendKeys "{ESC}", False '预置取消
.Show '开启
End With
'恢复屏幕更新
Application.ScreenUpdating = True
End Sub
'----------------------
[此贴子已经被konggs于2006-8-30 9:13:10编辑过] | 
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2005-2-25 12:28
