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

666611430

在开发一个插件时，由于初学者，不知道怎么实现如下效果。请大佬出现帮忙，为此感激不尽。
1.在 ms word 离，有英文文章，手动选中了文章中的几个单词，如图所示。

2.要实现的效果，如图所示：



要求：如果有选中的内容，就对所选内容实现 图2所示的效果； 如果没有选中的内容，就对所有单词实现 图2 所示的效果，也就是说对每一个单词后，显示图2的效果。比如：file(file, 长度为:4), 括号里有单词本身，长度。

有如下几个要求：
1.有选中的内容（包括 ：单选，多选，连续选中，不连续选中），就对选中的内容实现上述效果。
2.如果没有选中内容，就对所有的内容要实现上述效果。
3.英文文章是以各种英文内容单词以标点符号隔开的，无论是哪一种选中，如果选中内容有标点符号，只对单词实现上述效果。
4.无论文字方向从左还是从右（有些语言是从右开始，有的从左开始）都能实现。




补充内容 (2020-5-3 10:29):
*问题已解决。感谢 ming0018，sylun 等老师们的关注和指点。

ming0018

如果有选中的内容，是单选还是多选？或者两者皆可？

666611430

ming0018 发表于 2020-4-30 08:44
如果有选中的内容，是单选还是多选？或者两者皆可？

谢谢你的回复。
  
两者都可以，只要有选中的内容只对选中的内容实现上述效果，如果没有选中任何内容，就对所有的单词进行上述效果。

希望你帮忙。

ming0018

666611430 发表于 2020-4-30 10:06
谢谢你的回复。
  
两者都可以，只要有选中的内容只对选中的内容实现上述效果，如果没有选中任何内容， ...

下午有空的时候看一下吧

666611430

ming0018 发表于 2020-4-30 11:38
下午有空的时候看一下吧

谢谢你抽空回复。因为能力有限，没法实现这个效果。英文文章内容特别多，能在速度上达到最快吗？这个有点急了，能不能分享思路？希望你尽快帮个忙一下。谢谢。

ming0018

666611430 发表于 2020-4-30 13:06
谢谢你抽空回复。因为能力有限，没法实现这个效果。英文文章内容特别多，能在速度上达到最快吗？这个有点 ...

1. Sub main()
   
2.     Dim doc As Document, Rng As Range, RngS As Range, WordStr As String, reg As Object, Par As Paragraph
   
3.     Set doc = ActiveDocument
   
4.     Set reg = CreateObject("VBSCRIPT.REGEXP")    'RegEx为建立正则表达式
   
5.     With reg
   
6.         .Global = True    '设置全局可用
   
7.         .Pattern = "[a-zA-Z]+"
   
8.     End With
   
9.     If Len(Selection.Range.Text) > 0 Then
   
10.         Set Rng = Selection.Range
    
11.         Do While Rng.Characters(1) = " " And Len(Rng.Text) > 0
    
12.             Rng.MoveStart wdCharacter, 1
    
13.         Loop
    
14.         If Len(Rng.Text) > 0 Then
    
15.             Rng.SetRange Rng.Words(1).Start, Rng.End
    
16.             Set RngS = doc.Range(Rng.End, Rng.End)
    
17.             Do While RngS.Start <> Rng.Start
    
18.                 RngS.Move wdWord, -1
    
19.                 WordStr = RTrim(RngS.Words(1).Text)
    
20.                 If reg.test(WordStr) Then
    
21.                     RngS.Words(1).Characters(Len(WordStr)).InsertAfter "(" & WordStr & ",长度为：" & Len(WordStr) & ")"
    
22.                 End If
    
23.             Loop
    
24.         End If
    
25.     Else
    
26.         For Each Par In doc.Paragraphs
    
27.             Set Rng = doc.Range(Par.Range.End - 1, Par.Range.End - 1)
    
28.             Do While Rng.Start <> Par.Range.Start
    
29.                 Rng.Move wdWord, -1
    
30.                 WordStr = RTrim(Rng.Words(1).Text)
    
31.                 If reg.test(WordStr) Then
    
32.                     Rng.Words(1).Characters(Len(WordStr)).InsertAfter "(" & WordStr & ",长度为：" & Len(WordStr) & ")"
    
33.                 End If
    
34.             Loop
    
35.         Next
    
36.     End If
    
37. End Sub

复制代码

没时间　随便写了一下　你先参考一下吧

666611430

ming0018 发表于 2020-4-30 15:08
没时间　随便写了一下　你先参考一下吧

谢谢大神抽空看了。我试了一下，结果是如果有不连续多选内容的话，只对最后一个选中单词有效果了。其他还是跟原来一样，你再看一下，大神。我先自己先参考参考。谢谢你

论坛里有一个“编码转换” 的帖子，我项参考那儿的代码，但始终没有成功。希望你再一次优化代码，提高运行速度，因为文章内容非常多，手动修改也很棘手。希望你再一次看一下，谢谢。

ming0018

666611430 发表于 2020-4-30 15:51
谢谢大神抽空看了。我试了一下，结果是如果有不连续多选内容的话，只对最后一个选中单词有效果了。其他还 ...

多选请大神来帮忙吧，小神的方法不是太效率。

666611430

ming0018 发表于 2020-4-30 16:04
多选请大神来帮忙吧，小神的方法不是太效率。

请你不要误会，我根本没有说你代码不太效率的意思，已经很不错了。这个代码已经很大程度上满足了我的要求，如果对多选情况也能实现就更好了。我已经老半天了没法完成。有你的代码，我先用一下。希望你再抽空优化一下代码，谢谢你了。

sylun

可试试如下代码：

1. Sub test()
   
2.     Dim i As Integer
   
3.    
   
4.     Application.ScreenUpdating = False
   
5.     Options.DefaultHighlightColorIndex = 7 'wdYellow
   
6.     With Selection
   
7.         If .Type = 1 Then  '无选中内容时
   
8.             For i = .Paragraphs.First.Range.Words.Count To 1 Step -1
   
9.                 With .Paragraphs.First.Range.Words(i)  '暂只针对光标所在段落
   
10.                     If Right(.Text, 1) = Chr(32) Then .End = .End - 1
    
11.                     '只针对含字母或数字的词，可自行调整
    
12.                     If .Text Like "*[0-9A-Za-z]*" Then
    
13.                         .Text = .Text & "(" & Trim(.Text) & "，长度为：" & Len(.Text) & ")"
    
14.                     End If
    
15.                 End With
    
16.             Next
    
17.         ElseIf .Type = 2 Then  '普通选定时
    
18.             Dialogs(742).Execute
    
19.             With ActiveDocument.Content.Find
    
20.                 .Highlight = True
    
21.                 Do While .Execute
    
22.                     With .Parent
    
23.                         If .Text Like "*[0-9A-Za-z]*" Then
    
24.                             If Right(.Text, 1) = Chr(32) Then .End = .End - 1
    
25.                             .Text = .Text & "(" & Trim(.Text) & "，长度为：" & Len(Trim(.Text)) & ")"
    
26.                             .Editors.Add -1
    
27.                             .Collapse 0
    
28.                         End If
    
29.                     End With
    
30.                 Loop
    
31.                 .Replacement.Highlight = False
    
32.                 .Parent.WholeStory
    
33.                 .Execute Replace:=2
    
34.                 ActiveDocument.SelectAllEditableRanges -1
    
35.                 ActiveDocument.DeleteAllEditableRanges -1
    
36.             End With
    
37.         End If
    
38.     End With
    
39.     Application.ScreenUpdating = True
    
40.     MsgBox "Ok!"
    
41. End Sub

复制代码