ABCD选项对齐工具代码

很久以前（第一个版本是在2011年），制作过一个ZSHUNJ工具箱。第三个版本（2012年）后就没有再更新了。

点击这里查看历史版本

我一直都在使用，而且我个人使用的版本偶尔还会增加一些内容，不过使用率最高的依然是ABCD选项对齐。

ABCD选项对齐，主要是针对于完形填空的选项排版。一键操作，排版后选项整齐美观，当然选择题部分（任何科目）也是可以使用。

随着office版本的升级（最初是2003，现在2016都有了），一些机制改变了，使用起来有些不方便。

有留言询问何时再更新，考虑之后，觉得使用一种容易操作的方式使得这个对齐功能能够使用就行。

操作步骤：点击这里查看图示版

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