获取不连续区域的文本

loquat · 发表于 2015-6-25 23:03

本帖最后由 loquat 于 2015-6-25 23:10 编辑

看这个帖子中守柔大侠的代码有感，写了个获取不连续区域文本的宏：
http://club.excelhome.net/forum.php?mod=viewthread&tid=200648&page=1#pid1322412
刚好也有朋友问到怎么不使用剪贴板实现这个代码的功能：

Sub 获取不连续字符()
On Error Resume Next
Dim MyData As Object
Set MyData = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
Selection.Copy
MyData.GetFromClipboard
t = MyData.GetText
For i = 0 To UBound(Split(t, Chr(13))) - 1
t1 = t1 & Split(t, Chr(13) & Chr(10))(i)
Next i
MsgBox t1
Set MyData = Nothing
End Sub

复制代码

以上代码为liuhoubin168提供
以下是小弟loquat的代码：
以下代码一：执行效率还行，但是有个问题，执行完毕后不会恢复代码执行前的选取状态
以下代码二：执行效率比较低，但是没有上述不足之处
以上代码都有个BUG：当选取包含了文档末尾的段落标记时，运行将会出错。
容后有空再修正。

Sub 获取不连续区域文本一()
Dim aRange As Word.Range, docEnd&, aBool As Boolean, aStr$
If Application.Version < 11 Then Exit Sub '判断当前Word应用程序版本,如低于2003则退出
If Selection.type <> wdSelectionNormal Then Exit Sub '如果所选内容为非常规文本则退出
With ActiveDocument
If .ProtectionType <> wdNoProtection Then Exit Sub '如果文档处于保护状态时则退出
Application.ScreenUpdating = False
aBool = .ActiveWindow.View.ShowHiddenText
.ActiveWindow.View.ShowHiddenText = True '显示隐藏文字
.ActiveWindow.View.ShadeEditableRanges = False '不显示用户可编辑区域的底纹
Set aRange = .Content
docEnd = aRange.End - 1
With aRange.Find
.ClearFormatting '清除查找格式
.Font.Hidden = True '查找隐藏文字
Do While .Execute = True '成功查找时
Set aRange = .Parent '重置Range对象,为查找到的目标区域
aRange.Editors.Add wdEditorEveryone '使用可编辑区域保存原始隐藏文字
aRange.Font.Hidden = False '取消隐藏文字属性
aRange.SetRange aRange.End, docEnd '重置Range对象
Loop
End With
Selection.Font.Hidden = True '设置选择区域隐藏文字属性
Set aRange = .Content '再次全文搜索
With aRange.Find
.ClearFormatting
.Font.Hidden = True '查找隐藏文字
Do While .Execute = True
Set aRange = .Parent
aStr = aStr & aRange.Text
aRange.Font.Hidden = False '恢复原选区隐藏文字属性
aRange.SetRange aRange.End, docEnd '重置Range对象
Loop
End With
MsgBox aStr '返回原选区文字
.SelectAllEditableRanges
Selection.Font.Hidden = True '恢复原始的隐藏文字
.DeleteAllEditableRanges wdEditorEveryone '删除所有可编辑区域
.ActiveWindow.View.ShowHiddenText = aBool
Application.ScreenUpdating = True
End With
End Sub

复制代码

Sub 获取不连续区域文本二()
Dim aRange As Word.Range, docEnd&, aBool As Boolean, aStr$
Dim aBookmark As Word.Bookmark, k&
If Application.Version < 11 Then Exit Sub '判断当前Word应用程序版本,如低于2003则退出
If Selection.type <> wdSelectionNormal Then Exit Sub '如果所选内容为非常规文本则退出
With ActiveDocument
If .ProtectionType <> wdNoProtection Then Exit Sub '如果文档处于保护状态时则退出
Application.ScreenUpdating = False
aBool = .ActiveWindow.View.ShowHiddenText
.ActiveWindow.View.ShowHiddenText = True '显示隐藏文字
.ActiveWindow.View.ShadeEditableRanges = False '不显示用户可编辑区域的底纹
Set aRange = .Content
docEnd = aRange.End - 1
With aRange.Find
.ClearFormatting '清除查找格式
.Font.Hidden = True '查找隐藏文字
Do While .Execute = True '成功查找时
Set aRange = .Parent '重置Range对象,为查找到的目标区域
aRange.Editors.Add wdEditorCurrent '使用当前用户可编辑区域保存原始隐藏文字
aRange.Font.Hidden = False '取消隐藏文字属性
aRange.SetRange aRange.End, docEnd '重置Range对象
Loop
End With
Selection.Font.Hidden = True '设置选择区域隐藏文字属性
Set aRange = .Content '再次全文搜索
With aRange.Find
.ClearFormatting
.Font.Hidden = True '查找隐藏文字
k = 0
Do While .Execute = True
Set aRange = .Parent
aStr = aStr & aRange.Text '保存原选区文字
aRange.Bookmarks.Add "_myTemp" & Format(k, "000"), aRange '使用书签保存原始选区
aRange.Font.Hidden = False '恢复原选区隐藏文字属性
aRange.SetRange aRange.End, docEnd '重置Range对象
k = k + 1
Loop
End With
.SelectAllEditableRanges wdEditorCurrent
.DeleteAllEditableRanges wdEditorCurrent '删除当前用户可编辑区域
Selection.Font.Hidden = True '恢复原始的隐藏文字
For Each aBookmark In .Bookmarks
If Left(aBookmark.Name, 7) = "_myTemp" Then
aBookmark.Range.Editors.Add wdEditorCurrent
aBookmark.Delete '删除书签
End If
Next
.SelectAllEditableRanges wdEditorCurrent '恢复原始选区
.DeleteAllEditableRanges wdEditorCurrent '删除当前用的可编辑区域
.ActiveWindow.View.ShowHiddenText = aBool '恢复隐藏文字是否显示选项
Application.ScreenUpdating = True
End With
MsgBox aStr '返回原选区文字
End Sub

复制代码

笑熬浆糊1486 · 发表于 2015-7-28 08:52

mark。。。。。。。

weiyingde · 发表于 2020-2-24 21:45

盼望完善，继续关注后续行动，向大虾学习了！！

相见是缘8 · 发表于 2020-2-25 10:16

写代码的老师不少，代码后带中文注释的不多，这是我等小白的福音！
老师如有空，请帮忙看一下，下面网址9楼上，我这个问题有不有办法解决，这个问题 weiyingde 老师也几次援手，不知什么原因我这儿就是运行不了。谢谢！
http://club.excelhome.net/thread-1486524-1-2.html

sylun · 发表于 2020-2-27 23:03

可以试试如下借助文本格式（突出显示）处理的办法，如果文档中原有突出显示的，则原突出显示内容也被提取，此时可考虑用其他格式，如底纹，但用底纹格式的复原效果似乎不一样。只做了简单测试，未知其适应性。

Sub test()
'提取不连续区域的选定文本
Dim i As Integer
Dim selectiontext As String
Options.DefaultHighlightColorIndex = wdYellow
Application.Run "highlight" '借助应用突出显示格式对选定文本做标记
If Selection.Type <> wdSelectionNormal Then
MsgBox "请选定区域！", vbCritical
Exit Sub
End If
With ActiveDocument.Range.Find
.ClearFormatting
.Highlight = True
Do While .Execute
i = i + 1
selectiontext = selectiontext & vbCrLf & String(3, ChrW(8251)) & .Parent.Text
Loop
End With
MsgBox "共选定了" & i & "个不连续区域，字符如下：" & vbCrLf & selectiontext
Application.ActiveDocument.Undo '恢复原状
End Sub

复制代码

相见是缘8 · 发表于 2020-2-28 07:16

sylun 发表于 2020-2-27 23:03
可以试试如下借助文本格式（突出显示）处理的办法，如果文档中原有突出显示的，则原突出显示内容也被提取， ...

老师好！
你这个思路很别致！还有不有办法不让它包含段落符在内，把段落符排除在外？

		自动登录	找回密码
密码			免费注册

[原创] 获取不连续区域的文本

评分