Sub 批量抠出下划线文字为答案()
Dim daanAll As String
Dim i, i1, j, k, k1, l As Integer
j = Selection.Range.Start'保存选中区域的范围
k = Selection.Range.End
If j = k Then
Exit Sub
End If
Selection.SetRange Start:=k, End:=k
查找选中下划线文字向上
k1 = Selection.Range.End '记录最后一个下划线的末端位置
Selection.SetRange Start:=j, End:=j
Do
查找选中下划线文字
l = Selection.Range.End
daanAll = daanAll & Selection.Range.Text & ";"
Debug.Print daanAll
i = i + 1
Loop Until l >= k1
Selection.SetRange Start:=k, End:=k '回到选中区域的末端
Selection.TypeParagraph '回车
Selection.TypeParagraph '回车
Selection.MoveUp Unit:=wdLine, Count:=1, Extend:=wdMove '光标上移一位
Selection.Font.Color = 236
Selection.TypeText Text:="【答案】" & daanAll
'下划线字替换为下划线空格
Selection.SetRange Start:=j, End:=j '回到开始的地方
l = j
Do
选中单个下划线字
l = Selection.Range.End
'Selection.SetRange Start:=l, End:=l '回到上一次替换横线的地方
输入下划线空格
If l >= k1 Or i1 > 1000 Then
Exit Do
Else
k1 = k1 + 1
i1 = i1 + 1
End If
Loop
Selection.SetRange Start:=k, End:=k
MsgBox ("已抠出" & i & "处答案")
Debug.Print "已抠出" & i & "处答案"
End Sub
Function 查找选中下划线文字()
' Macro1 Macro
' 宏由 ZPL 录制,时间: 2022/11/26
'
'
ActiveDocument.Range(0, 1).Start = 1
ActiveDocument.Range(1, 1).End = 1
With Selection.Find.Font
.Underline = 9999999
.EmphasisMark = 9999999
.Underline = wdUnderlineSingle
.Underline = wdUnderlineSingle
.SmallCaps = 0
.AllCaps = 0
.DisableCharacterSpaceGrid = False
.NameFarEast = ""
.NameAscii = ""
.NameOther = ""
.NameBi = ""
.Bold = wdUndefined
.Italic = wdUndefined
.BoldBi = wdUndefined
.ItalicBi = wdUndefined
.Subscript = wdUndefined
.Superscript = wdUndefined
.StrikeThrough = wdUndefined
.DoubleStrikeThrough = wdUndefined
.SmallCaps = wdUndefined
.AllCaps = wdUndefined
.Hidden = wdUndefined
.Scaling = wdUndefined
End With
With Selection.Find
.Text = ""
.Forward = True
.Wrap = wdFindContinue
.MatchCase = False
.MatchByte = True
.MatchWildcards = False
.MatchWholeWord = False
.MatchFuzzy = False
.Replacement.Text = ""
End With
With Selection.Find
.Style = ""
.Highlight = wdUndefined
With .Replacement
.Style = ""
.Highlight = wdUndefined
End With
End With
Selection.Find.Execute Replace:=wdReplaceNone
End Function
Function 选中单个下划线字()
'
' 选中单个下划线字 Macro
' 宏由 ZPL 录制,时间: 2022/11/27
Selection.Find.Font.Reset
Selection.Find.ParagraphFormat.Reset
Selection.Find.Font.Underline = wdUnderlineSingle
With Selection.Find.Font
.Underline = wdUnderlineSingle
.SmallCaps = 0
.AllCaps = 0
.DisableCharacterSpaceGrid = False
.NameFarEast = ""
.NameAscii = ""
.NameOther = ""
.NameBi = ""
.Bold = wdUndefined
.Italic = wdUndefined
.BoldBi = wdUndefined
.ItalicBi = wdUndefined
.Subscript = wdUndefined
.Superscript = wdUndefined
.StrikeThrough = wdUndefined
.DoubleStrikeThrough = wdUndefined
.SmallCaps = wdUndefined
.AllCaps = wdUndefined
.Hidden = wdUndefined
.Scaling = wdUndefined
End With
With Selection.Find.Font
.Underline = wdUnderlineSingle
.SmallCaps = 0
.AllCaps = 0
.DisableCharacterSpaceGrid = False
.NameFarEast = ""
.NameAscii = ""
.NameOther = ""
.NameBi = ""
.Bold = wdUndefined
.Italic = wdUndefined
.BoldBi = wdUndefined
.ItalicBi = wdUndefined
.Subscript = wdUndefined
.Superscript = wdUndefined
.StrikeThrough = wdUndefined
.DoubleStrikeThrough = wdUndefined
.SmallCaps = wdUndefined
.AllCaps = wdUndefined
.Hidden = wdUndefined
.Scaling = wdUndefined
End With
With Selection.Find
.Text = "?"
.Forward = True
.Wrap = wdFindContinue
.MatchCase = True
.MatchByte = True
.MatchWildcards = True
.MatchWholeWord = False
.MatchFuzzy = False
.Replacement.Text = " "
End With
With Selection.Find
.Style = ""
.Highlight = wdUndefined
With .Replacement
.Style = ""
.Highlight = wdUndefined
End With
End With
Selection.Find.Execute Replace:=wdReplaceNone
Selection.Find.Replacement.Text = " "
End Function
Function 输入下划线空格()
'
' 输入下划线空格 Macro
' 宏由 ZPL 录制,时间: 2022/11/27
With Selection.Font
.Underline = wdUnderlineSingle
.UnderlineColor = wdColorAutomatic
End With
Selection.TypeText Text:=" "
End Function
Function 查找选中下划线文字向上()
' Macro1 Macro
' 宏由 ZPL 录制,时间: 2022/11/26
ActiveDocument.Range(0, 1).Start = 1
ActiveDocument.Range(1, 1).End = 1
With Selection.Find.Font
.Underline = 9999999
.EmphasisMark = 9999999
.Underline = wdUnderlineSingle
.Underline = wdUnderlineSingle
.SmallCaps = 0
.AllCaps = 0
.DisableCharacterSpaceGrid = False
.NameFarEast = ""
.NameAscii = ""
.NameOther = ""
.NameBi = ""
.Bold = wdUndefined
.Italic = wdUndefined
.BoldBi = wdUndefined
.ItalicBi = wdUndefined
.Subscript = wdUndefined
.Superscript = wdUndefined
.StrikeThrough = wdUndefined
.DoubleStrikeThrough = wdUndefined
.SmallCaps = wdUndefined
.AllCaps = wdUndefined
.Hidden = wdUndefined
.Scaling = wdUndefined
End With
With Selection.Find
.Text = ""
.Forward = False
.Wrap = wdFindContinue
.MatchCase = False
.MatchByte = True
.MatchWildcards = False
.MatchWholeWord = False
.MatchFuzzy = False
.Replacement.Text = ""
End With
With Selection.Find
.Style = ""
.Highlight = wdUndefined
With .Replacement
.Style = ""
.Highlight = wdUndefined
End With
End With
Selection.Find.Execute Replace:=wdReplaceNone
End Function
下面是运行前后的图