怎么对选中的每一个单词实现如下效果(不知能否实现)？

666611430 · 发表于 2020-4-30 22:50

sylun 发表于 2020-4-30 20:58
可试试如下代码：

非常感谢兄弟，这代码可以基本上完成了我的工作了。
就唯一一个部分是：如果连续选中的话它对整个选中内容实现效果了。我的工作是这样的，对于连续选中内容也对单词实现效果。如图所示

如图所示，对连续选中的内容，也对单个单词完成上述效果。大佬，有空再看一下。谢谢。

sylun · 发表于 2020-5-1 13:48

楼主如果在原示范图片中的多个选定内容中至少有一个是选定两个以上单词，就不会产生这样的误导。我前面的代码中对无选定内容时就是针对多个单词进行处理的，楼主可参考该处理方法对选定情形的查找代码段中的文本内容进行处理，其实就是对Range对象的的words集合的处理

666611430 · 发表于 2020-5-1 14:27

sylun 发表于 2020-5-1 13:48
楼主如果在原示范图片中的多个选定内容中至少有一个是选定两个以上单词，就不会产生这样的误导。我前面的代 ...

因自己疏忽将把这个情况给漏掉了。我对words集合处理不太熟悉，望兄弟再帮我修改一下。我这个工作非常需要这个代码了。谢谢兄弟。

666611430 · 发表于 2020-5-1 22:51

我自己调试了老半天也没调试出来。请兄弟帮我忙一个了，让你再次费心了。先谢谢你

sylun · 发表于 2020-5-1 23:26

重新修改了代码，楼主可试试

Sub test2()
Dim oRange As Range
Application.ScreenUpdating = False
Options.DefaultHighlightColorIndex = 7 'wdYellow
With Selection
If .Type = 1 Then
Set oRange = .Range
.Expand 4 '暂扩展到段落；如到全文，参数6
Inserting .Range
oRange.Select
ElseIf .Type = 2 Then
Dialogs(742).Execute
With ActiveDocument.Content.Find
.Highlight = True
Do While .Execute
With .Parent
If .Text Like "*[0-9A-Za-z]*" Then
.End = Inserting(.Duplicate)
.Editors.Add -1
.Collapse 0
End If
End With
Loop
.Replacement.Highlight = False
.Parent.WholeStory
.Execute Replace:=2
End With
ActiveDocument.SelectAllEditableRanges -1
ActiveDocument.DeleteAllEditableRanges -1
End If
End With
Application.ScreenUpdating = True
MsgBox "Ok!"
End Sub
Function Inserting(myRange As Range) As Long
Dim i As Integer
With myRange
If .Characters.First = Chr(32) Then .Start = .Start + 1
For i = .Words.Count To 1 Step -1
With .Words(i)
If Right(.Text, 1) = Chr(32) Then .End = .End - 1
If .Text Like "*[0-9A-Za-z]*" Then
.Text = .Text & "(" & Trim(.Text) & "，长度为：" & Len(.Text) & ")"
End If
End With
Next
Inserting = .End
End With
End Function

复制代码

666611430 · 发表于 2020-5-2 10:08

sylun 发表于 2020-5-1 23:26
重新修改了代码，楼主可试试

谢谢兄弟的关注和协助。
现在两种情况，完美解决了，即1.无选中任何内容2。连续选中。

但是对于如图所示的情况不对了。请指示一下代码怎么修改。最好让兄弟亲自修改一下。谢谢

sylun · 发表于 2020-5-2 22:48

666611430 发表于 2020-5-2 10:08
谢谢兄弟的关注和协助。
现在两种情况，完美解决了，即1.无选中任何内容2。连续选中。

15楼代码确实有问题，修改如下，请再测试：

Sub test2()
Dim i As Integer
Dim oRange As Range
Application.ScreenUpdating = False
Options.DefaultHighlightColorIndex = 7 'wdYellow
With Selection
If .Type = 1 Then
Set oRange = .Range
.Expand 4 '暂扩展到段落；如到全文，参数6
Inserting .Range
oRange.Select
ElseIf .Type = 2 Then
Dialogs(742).Execute
With ActiveDocument.Content.Find
.Highlight = True
Do While .Execute
With .Parent
If .Text Like "*[0-9A-Za-z]*" Then
.End = Inserting(.Duplicate).End
.Editors.Add -1
.Collapse 0
End If
End With
Loop
.Replacement.Highlight = False
.Parent.WholeStory
.Execute Replace:=2
End With
ActiveDocument.SelectAllEditableRanges -1
ActiveDocument.DeleteAllEditableRanges -1
End If
End With
Application.ScreenUpdating = True
MsgBox "Ok!"
End Sub
Function Inserting(myRange As Range) As Range
Dim i As Integer
Dim n As Integer
With myRange
If .Characters.First = Chr(32) Then .Start = .Start + 1
n = .Words.Count
For i = n To 1 Step -1
With .Words(i)
If Right(.Text, 1) = Chr(32) Then .End = .End - 1
If .Text Like "*[0-9A-Za-z]*" Then
.Text = .Text & "(" & Trim(.Text) & "，长度为：" & Len(.Text) & ")"
End If
If i = n Then Set Inserting = .Duplicate
End With
Next
End With
End Function

复制代码

666611430 · 发表于 2020-5-2 23:25

sylun 发表于 2020-5-2 22:48
15楼代码确实有问题，修改如下，请再测试：

谢谢兄弟关注和协助。问题已解决！

666611430 · 发表于 2020-5-21 15:56

sylun 发表于 2020-4-30 20:58
可试试如下代码：

现在头儿又让我把效果修改成如下。由于自己编写能力很差劲，捣鼓了好几天，也没有把效果实现了。希望兄弟再一次帮忙我一下，我的工作非常需要的，麻烦你了。为此表示不胜感激。真的很需要兄弟的帮忙。新要求如下。

--------------------------------------------------------
***正文最后显示效果***
1.单词的选择方式与本帖选中方式一样。
2.加序号
3.若有重复单词，只保留一个。
4.加对单词拆分，效果如上图所示。
5.如图红线所示距离以一个TAB隔开
6.选中单词的出现次数
----------------------------------------------------------
期待兄弟帮我修改一下代码。等你回复。

666611430 · 发表于 2020-5-30 20:21

本帖最后由 666611430 于 2020-5-30 20:22 编辑

sylun 发表于 2020-5-2 22:48
15楼代码确实有问题，修改如下，请再测试：

兄弟，真的很需要你再一次抽空帮我实现以下19楼的效果。真的很期待你帮忙。这对我的工作非常需要的。谢谢。

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

[求助] 怎么对选中的每一个单词实现如下效果(不知能否实现)？