批量提取下划线内容 代码

geryjun

实现效果：
1、下划线内容替换为________
2、下划线的内容复制到文件的最后部分。

以上问题已经解决了，代码请看10楼。

不过发现有个别的题目是一题有一个以上的下划线，所以求助如何修改这个代码。

geryjun

不知这种思路可否行得通:  直接读取每行的序号。

sqhsqhli

Sub text()
Dim s As String, a As String
With ActiveDocument.Content.Find
.Text = "[0-9]@."
.Forward = True
.MatchWildcards = True
Do While .Execute
.Parent.Font.Underline = wdUnderlineSingle
Loop
End With
With ActiveDocument.Content.Find
.Font.Underline = wdUnderlineSingle
Do While .Execute(FindText:="", Format:=True)
If Val(.Parent) <> 0 And InStr(.Parent, ".") <> 0 Then a = Chr(13) & .Parent Else a = .Parent & "  "
s = s & a
Loop
End With
With ActiveDocument.Content.Find
.Text = "[0-9]@."
.Forward = True
.MatchWildcards = True
Do While .Execute
.Parent.Font.Underline = wdUnderlineNone
Loop
End With
With ActiveDocument.Content.Find
.Font.Underline = wdUnderlineSingle
.Execute FindText:="", ReplaceWith:=Space(9), Format:=True, Replace:=wdReplaceAll, Forward:=False'此处有个bug，替换成9个空格。当下划线文字位于边缘时会失去下划线显示
End With
ActiveDocument.Range.InsertAfter s
End Sub

geryjun

sqhsqhli 发表于 2012-4-19 15:55
Sub text()
Dim s As String, a As String
With ActiveDocument.Content.Find

非常感谢，这个效果很好。

lxlhbxy

谢谢您的代码！
请教一下，提出后，再还原回去要怎么写呢？谢谢！

ww0000

sqhsqhli 发表于 2012-4-17 16:11
Sub Find_Underline()
Dim s As String, a As Integer
With ActiveDocument.Content.Find

如何做到反过来的效果？也就是将文档后的答案填入下划线！

ww0000

sqhsqhli 发表于 2012-4-19 15:55
Sub text()
Dim s As String, a As String
With ActiveDocument.Content.Find

如何做到反过来的效果？也就是将文档后的答案填入下划线！

weiyingde

413191246se 发表于 2012-4-10 16:43
我抄微软帮助，也解决了第一个问题，第二个问题也解决不了！

Sub Find_Underline()

ReplaceWith:=Space(9)
在实际应用中，要根据实际的字符数来确定空格的多少。是否可以增加一个判断原下划线格式下的字符数来确定呢？这样可能会增强它的实用性。