ABCD选项对齐工具代码：一键让完形填空选项排版更轻松
很久以前（第一个版本是在2011年），制作过一个ZSHUNJ工具箱。第三个版本（2012年）后就没有再更新了。
我一直都在使用，而且我个人使用的版本偶尔还会增加一些内容，不过使用率最高的依然是ABCD选项对齐。
ABCD选项对齐，主要是针对于完形填空的选项排版。一键操作，排版后选项整齐美观，当然选择题部分（任何科目）也是可以使用。
随着office版本的升级（最初是2003，现在2016都有了），一些机制改变了，使用起来有些不方便。
有留言询问何时再更新，考虑之后，觉得使用一种容易操作的方式使得这个对齐功能能够使用就行。
1以word 2016 版本为例，开发工具-宏-宏名-创建
2复制如下代码到下图中到位置，保存。
Sub ABCD选项对齐()
Dim myFind() As Variant, myReplace As String
Dim aArray As Variant, mySet As String, n As Integer, M As Integer
Dim myRange As Range, myBk As Bookmark
myFind = Array("A", "B", "C", "D", "E", "F", "G", "Ａ", "Ｂ", "Ｃ", "Ｄ")
If Selection.Type = wdSelectionIP Then Exit Sub
Application.ScreenUpdating = False
Set myBk = ActiveDocument.Bookmarks.Add(Name:="Temp", Range:=Selection.Range)
With myBk.Range
With .ParagraphFormat
.CharacterUnitLeftIndent = 0
.CharacterUnitRightIndent = 0
.CharacterUnitFirstLineIndent = 0
.LeftIndent = CentimetersToPoints(0)
.RightIndent = CentimetersToPoints(0)
.FirstLineIndent = CentimetersToPoints(0)
.TabStops.ClearAll
.LineSpacingRule = wdLineSpaceExactly
.LineSpacing = 20
End With
With .Font
.NameFarEast = "宋体"
.NameAscii = "Times New Roman"
.NameOther = "Times New Roman"
.Name = "Times New Roman"
.Size = 15
End With
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Wrap = wdFindStop
.MatchWildcards = False
.Execute findtext:="^t", replacewith:="", Replace:=wdReplaceAll
End With
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "([!a-zA-Z])[ " & ChrW(160) & "]{1,}"
.MatchWildcards = True
.Wrap = wdFindStop
.Font.Underline = False
.Execute replacewith:="\1", Replace:=wdReplaceAll
End With
With .Find
.ClearFormatting
.Format = True
.Replacement.ClearFormatting
.Replacement.ParagraphFormat.LineSpacingRule = wdLineSpaceExactly
.Replacement.ParagraphFormat.LineSpacing = 20
.MatchWildcards = True
.Wrap = wdFindStop
.Text = "[一-龥]{5,}"
.Execute replacewith:="", Replace:=wdReplaceAll
End With
With .Find
.ClearFormatting
With .Replacement
.ClearFormatting
.ParagraphFormat.TabStops.Add Position:=CentimetersToPoints(1.11)
.ParagraphFormat.TabStops.Add Position:=CentimetersToPoints(5.11)
.ParagraphFormat.TabStops.Add Position:=CentimetersToPoints(10.11)
.ParagraphFormat.TabStops.Add Position:=CentimetersToPoints(15.11)
End With
.Text = "[A-G Ａ-Ｄ][.、．]"
.Replacement.Text = "^t^&"
.Wrap = wdFindStop
.Format = True
.MatchWildcards = True
.Execute Replace:=wdReplaceAll
End With
Set myRange = myBk.Range
NR1: With myRange.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "A[.、．][!^13]@B[.、．][!^13]@^13^tC[.、．]*D[.、．]*^13"
.MatchWildcards = True
Do While .Execute
With myRange
.ParagraphFormat.TabStops.ClearAll
.ParagraphFormat.TabStops.Add CentimetersToPoints(1.11)
.ParagraphFormat.TabStops.Add CentimetersToPoints(10.11)
.SetRange .End, myBk.Range.End
GoTo NR1
End With
Loop
End With
Set myRange = myBk.Range
NR2: With myRange.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "Ａ[.、．][!^13]@Ｂ[.、．][!^13]@^13^tＣ[.、．]*Ｄ[.、．]*^13"
.MatchWildcards = True
Do While .Execute
With myRange
.ParagraphFormat.TabStops.ClearAll
.ParagraphFormat.TabStops.Add CentimetersToPoints(1.11)
.ParagraphFormat.TabStops.Add CentimetersToPoints(10.11)
.SetRange .End, myBk.Range.End
GoTo NR2
End With
Loop
End With
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.MatchWildcards = True
.Execute findtext:="[\(（][\)）]", replacewith:="(^32^32^32) ", Replace:=wdReplaceAll
End With
With .ParagraphFormat
.LineUnitBefore = 0
.LineUnitAfter = 0
.SpaceBefore = 0
.SpaceAfter = 0
.SpaceBeforeAuto = False
.SpaceAfterAuto = False
End With
mySet = VBA.InputBox(Prompt:="请选择选项样式,1为'A.',2为'A．',3为 'A、',单击取消退出替换!", Title:="选项样式设置", Default:=1)
Select Case mySet
Case ""
myBk.Delete
Exit Sub
Case 1
myReplace = ". "
n = 64
Case 2
myReplace = "．"
n = 64
Case 3
myReplace = "、"
n = 64
Case Else
myReplace = aArray
If aArray = "[A-G]．" Then
n = -23616
Else
n = 64
End If
End Select
For Each aArray In myFind
M = M + 1
If M = 8 Then M = 1
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.MatchWildcards = True
.Wrap = wdFindStop
.Execute findtext:=aArray & "[.、．]", replacewith:=VBA.Chr(M + n) & myReplace, Replace:=wdReplaceAll
End With
Next
myBk.Delete
End With
Application.ScreenUpdating = True
End Sub
3为达到更好效果，建议页面设置为左右上下边距为2。
4使用时，选定ABCD，ALT+F8 调出如下界面，点击运行就行了。
5ABCD对齐之后再统一设置字体等排版操作。
由于office版本不同或电脑配置不同，运行时可能会出现一些错误提示。基本上按确定就可以。
如有其他问题，请留言。
欢迎转发，让更多的英语教师排版轻松，快捷。
点击阅读原文查看历史版本