选项对齐（宏）最新更新 2022-10-01

tangqingfu · 发表于 2022-10-4 21:37

413191246se 发表于 2022-10-4 19:40
* sylun 兄：我用表格填充版心再减去两个 0.19 厘米（想起过去《表格处理》宏里面的 .padding=0.19）得到当 ...

能否请413191246se重新分享下处理 2、3、4、5 个选项的宏代码，忘记保存了
英文试卷可能涉及选项不一样情况，有些选择题是3个选项，有些是4个选项

sylun · 发表于 2022-10-5 00:17

tangqingfu 发表于 2022-10-4 21:34
sylun兄，用您的代码测试附件的文档，好像效果不好，是不是我操作不对

tang兄的新文档与之前提供的文档有两点不同：一是两节的页边距设置不同，导致wid值出错，前面我已表示忽略右缩进与节格式页边距差异，要考虑就得用Range对象的Information属性获取aRange对象所在的节编号，再获取该节的页边距信息，就新文档本例可将第6行代码改为With ActiveDocument.Sections(1).PageSetup。
二是文档中有的选项中隐藏了不可见的1号字符，不知从何而来的，十分奇怪。要先清除它，可将第67行代码改为：For Each Match In .Execute(Replace(aRange.Text, Chr(1), ""))

413191246se · 发表于 2022-10-5 01:51

tang 兄：还好，最近我保存了一些历史版本。在 9月30日的版本中找到了 2345 个选项对齐的宏。
sylun 兄：像示例文档中有两个不可见字符，我觉得不清除也可以，无非就是多占几行。
今晚，我又折腾了一下《公文排版、普通排版、条文排版》三个宏，前两个默认段后一行，后者段后空段。

Sub OptionAlign()
'选项对齐
Dim t As Table, i As Paragraph, TableWidth!, oTab!, Tab1!, Tab2!, Tab3!, Tab4!, OptionNum&
With ActiveDocument
.Tables.Add .Range(0, 0), 1, 1
TableWidth = Round(.Tables(1).Cell(1, 1).Width / 28.35, 2)
.Tables(1).Delete
.Content.Find.Execute "^l", , , 0, , , , , , "^p", 2
For Each t In .Tables
With t.Range.Rows
.WrapAroundText = False
.Alignment = wdAlignRowCenter
End With
Next
With .Content.Find
.Execute "(^13)([ 　^s^t]{1,})", , , 1, , , , , , "\1", 2
.Execute "([ 　^s^t]{1,})(^13)", , , 1, , , , , , "\2", 2
.Execute "([A-E])[.、]", , , 1, , , , , , "\1．", 2
.Execute "([ 　^s^t^13]{1,})([B-E]．)", , , 1, , , , , , "\2", 2
.Execute "(^13)([0-9]{1,})[.、]", , , 1, , , , , , "\1\2．", 2
.Execute "([B-E]．)", , , 1, , , , , , "^t\1", 2
End With
For Each i In .Paragraphs
With i.Range
If Not .Information(12) Then
If .Text Like "A．*" Then
With .Font
If .ColorIndex = wdRed Then .ColorIndex = wdBlue Else .ColorIndex = wdRed
.Bold = wdToggle
End With
If .Text Like "A．*B．*C．*D．*E．*" Then
OptionNum = 5
GoSub op
With .ParagraphFormat.TabStops
.ClearAll
.Add Position:=CentimetersToPoints(Tab1)
.Add Position:=CentimetersToPoints(Tab2)
.Add Position:=CentimetersToPoints(Tab3)
.Add Position:=CentimetersToPoints(Tab4)
End With
'cut
If .ComputeStatistics(1) = 2 Then
.Find.Execute "^t([CE]．)", , , 1, , , , , , "^p\1", 2
End If
ElseIf .Text Like "A．*B．*C．*D．*" Then
OptionNum = 4
GoSub op
With .ParagraphFormat.TabStops
.ClearAll
.Add Position:=CentimetersToPoints(Tab1)
.Add Position:=CentimetersToPoints(Tab2)
.Add Position:=CentimetersToPoints(Tab3)
End With
' 'cut
If .ComputeStatistics(1) = 2 Or .ComputeStatistics(1) = 3 Then
.Find.Execute "^t(C．)", , , 1, , , , , , "^p\1", 2
ElseIf .ComputeStatistics(1) = 4 Then
.Find.Execute "^t([BD]．)", , , 1, , , , , , "^p\1", 2
End If
'cuts
If .ComputeStatistics(1) = 2 Then
With .ParagraphFormat.TabStops
.ClearAll
.Add Position:=CentimetersToPoints(Tab2)
End With
ElseIf .ComputeStatistics(1) = 4 Then
.Find.Execute "^t([B-D]．)", , , 1, , , , , , "^p\1", 2
End If
ElseIf .Text Like "A．*B．*C．*" Then
OptionNum = 3
GoSub op
With .ParagraphFormat.TabStops
.ClearAll
.Add Position:=CentimetersToPoints(Tab1)
.Add Position:=CentimetersToPoints(Tab2)
End With
'cut
If .ComputeStatistics(1) = 2 Then
.Find.Execute "^t([BC]．)", , , 1, , , , , , "^p\1", 2
End If
ElseIf .Text Like "A．*B．*" Then
OptionNum = 2
GoSub op
With .ParagraphFormat.TabStops
.ClearAll
.Add Position:=CentimetersToPoints(Tab1)
End With
End If
With .ParagraphFormat
.CharacterUnitFirstLineIndent = 0
.FirstLineIndent = CentimetersToPoints(0)
.CharacterUnitLeftIndent = 0
.LeftIndent = CentimetersToPoints(0)
.CharacterUnitRightIndent = 0
.RightIndent = CentimetersToPoints(0)
.CharacterUnitFirstLineIndent = 2
End With
End If
End If
End With
Next
End With
Exit Sub
op:
If OptionNum = 4 Then
oTab = (Int((TableWidth - 2 * 0.19) * 2.7 + 0.5) - 2) / 4
Tab1 = Round((2 + 1 * oTab) / 2.7, 2)
Tab2 = Round((2 + 2 * oTab) / 2.7, 2)
Tab3 = Round((2 + 3 * oTab) / 2.7, 2)
ElseIf OptionNum = 3 Then
oTab = (Int((TableWidth - 2 * 0.19) * 2.7 + 0.5) - 2) / 3
Tab1 = Round((2 + 1 * oTab) / 2.7, 2)
Tab2 = Round((2 + 2 * oTab) / 2.7, 2)
ElseIf OptionNum = 2 Then
oTab = (Int((TableWidth - 2 * 0.19) * 2.7 + 0.5) - 2) / 2
Tab1 = Round((2 + 1 * oTab) / 2.7, 2)
ElseIf OptionNum = 5 Then
oTab = (Int((TableWidth - 2 * 0.19) * 2.7 + 0.5) - 2) / 5
Tab1 = Round((2 + 1 * oTab) / 2.7, 2)
Tab2 = Round((2 + 2 * oTab) / 2.7, 2)
Tab3 = Round((2 + 3 * oTab) / 2.7, 2)
Tab4 = Round((2 + 4 * oTab) / 2.7, 2)
End If
Return
'cm=char/2.7
End Sub

复制代码

wangweixiang11 · 发表于 2023-2-19 15:30

测试了下，最后一个选项如果过长的话不能将每个选项单独成行

文字控 · 发表于 2023-4-28 12:18

你好，如果有图的题目，选项都弄成一个选项一段，代码应该怎么修改呢？

413191246se · 发表于 2023-4-29 02:11

楼上朋友，你好！替换的话手动也可以，但有时测试时 Word 会崩溃；代码的好处是不易崩溃。
请试用下面的代码：

Sub a0001_answer_replace_ABCD()
ActiveDocument.Content.Find.Execute "([!^13])([BCD][.．、])", , , 1, , , , , , "\1^p\2", 2
End Sub

复制代码

		自动登录	找回密码
密码			免费注册

[分享] 选项对齐（宏）最新更新 2022-10-01