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

413191246se · 发表于 2022-10-1 20:58

顶一下。。

常扬帆 · 发表于 2022-10-2 12:39

效果很好，楼主辛苦了！
您看看下面这个要不要考虑分成两排？另为颜色保持不变是不是好点？

413191246se · 发表于 2022-10-2 12:50

你好！你图片中所示的结果，是用 1 楼最新宏代码运算出来的结果吗？在我的 Word2019 中是正常的。

常扬帆 · 发表于 2022-10-2 13:12

413191246se 发表于 2022-10-2 12:50
你好！你图片中所示的结果，是用 1 楼最新宏代码运算出来的结果吗？在我的 Word2019 中是正常的。

你好！是的，我的是office 2016。

413191246se · 发表于 2022-10-2 20:05

扬帆朋友，你好！一是请重新再试试；二是如果有条件，换一台电脑换一个 Word 版本试试。
因为，我的宏都是在 Word 2019 中反复测试后才上传的，在我这里效果很好。

sylun · 发表于 2022-10-3 00:08

结合楼主与tangqingfu兄的附件文档试写了个宏，只做了简单测试。对中英文字符只做了简单判断，有5个与6个选项的情形不作处理。假设段落与字符格式常规。

Sub test()
Dim i%, n%, wid!
Dim myRange As Range
Dim oRange As Range
With ActiveDocument.PageSetup
wid = .PageWidth - .LeftMargin - .RightMargin - .Gutter
End With
With ActiveDocument.Content.Find
.Text = "[^13^s^t．　][A-F][.．]"
.MatchWildcards = True
Do While .Execute
With .Parent
Set oRange = .Duplicate
If .Characters(2) = "A" Then
Set oRange = .Duplicate
If myRange Is Nothing Then
Set myRange = oRange.Characters(2)
Else
myRange.End = .Start
myRange.End = FindLastOption(myRange.Duplicate).End
OptionsSetting i, wid, myRange
Set myRange = oRange.Characters(2)
End If
i = 0
n = n + 1
End If
End With
i = i + 1
Loop
myRange.End = oRange.End
myRange.End = FindLastOption(myRange.Duplicate).End
OptionsSetting i, wid, myRange
End With
MsgBox "共处理了" & n & "题。"
End Sub
Function FindLastOption(aRange As Range) As Range
With aRange.Find
.Text = "[^13^s^t 　][B-F][.．]"
.MatchWildcards = True
.Forward = False
If .Execute Then
Set FindLastOption = .Parent
FindLastOption.EndOf wdParagraph, 1
Else
MsgBox "异常选项！请检查文档内容"
End If
End With
End Function
Sub OptionsSetting(i As Integer, wid As Single, aRange As Range)
Dim n%, s%, t%, st&, aIndent!, pos!, info$()
Dim TF As Boolean
Dim Reg As Object
Dim Match As Object
With aRange.Paragraphs.First
aIndent = .LeftIndent + .FirstLineIndent
End With
Set Reg = CreateObject("VBScript.RegExp")
With Reg
.Global = True
.MultiLine = True
.Pattern = "(\b[A-F][.．][^\r]+?)[\s　]*?(?=[A-F][.．]|$)"
For Each Match In .Execute(aRange.Text)
ReDim Preserve info(n)
info(n) = Match.submatches(0)
If Len(info(n)) > s Then s = Len(info(n))
n = n + 1
Next
End With
Application.ScreenUpdating = False
With aRange
.End = .End - 1
st = .Start - .Paragraphs(1).Range.Start
If st > 0 Then aIndent = aIndent + st * .Font.Size
Reg.Pattern = "[\u4e00-\u9fa5]"
If Reg.test(.Text) Then TF = True
If TF = True Then t = 1 Else t = 2
.ParagraphFormat.TabStops.ClearAll
Select Case i
Case 4
If (wid - aIndent) / 4 * t > (s + 1) * .Font.Size Then
pos = (wid - aIndent) / 4
For n = 1 To 3
.ParagraphFormat.TabStops.Add pos * n + aIndent
Next
.Text = Join(info, vbTab)
ElseIf (wid - aIndent) / 2 * t > (s + 1) * .Font.Size Then
pos = (wid - aIndent) / 2 + .Font.Size
For n = 1 To 2
.ParagraphFormat.TabStops.Add pos * n + aIndent
Next
.Text = Join(info, vbTab)
Reg.Pattern = "(\t[^\t]+)\t([\w\W]+$)"
.Text = Reg.Replace(.Text, "$1" & Chr(13) & "$2")
If st > 0 Then .Paragraphs(2).Range.InsertBefore String(st, .Paragraphs(1).Range.Characters(1))
End If
Case 3
If (wid - aIndent) / 3 * t > (s + 1) * .Font.Size Then
pos = (wid - aIndent) / 3
For n = 1 To 2
.ParagraphFormat.TabStops.Add pos * n + aIndent
Next
.Text = Join(info, vbTab)
ElseIf (wid - aIndent) / 2 * t > (s + 1) * .Font.Size Then
pos = (wid - aIndent) / 2 + .Font.Size
.ParagraphFormat.TabStops.Add pos + aIndent
.Text = Join(info, vbTab)
Reg.Pattern = "(\t[^\t]+)\t([\w\W]+$)"
.Text = Reg.Replace(.Text, "$1" & Chr(13) & "$2")
If st > 0 Then .Paragraphs(2).Range.InsertBefore String(st, .Paragraphs(1).Range.Characters(1))
End If
Case 2
If (wid - aIndent) / 2 * t > (s + 1) * .Font.Size Then
pos = (wid - aIndent) / 2
.ParagraphFormat.TabStops.Add pos * n + aIndent
.Text = Join(info, vbTab)
End If
Case Else
'5、6个选项时自定义（略）
End Select
.HighlightColorIndex = wdYellow
TF = False
End With
Application.ScreenUpdating = True
End Sub

复制代码

413191246se · 发表于 2022-10-3 11:14

* sylun 兄：多谢！辛苦！你的代码很高深，我看得一知半解的。正则、函数都不懂。
* 针对测试结果，不好意思，我觉得有必要提一提。
* 当选项为 2 行时，应该与 1 行时的选项对齐，B 与 C 对齐。
* 还有，兄上次给相见是缘8 朋友写的代码，里面有 .screenupdating 语句，我前几天测试时（因为我给他添加了宏运行时间语句），也没好好看，直接就运行了好几次。昨天晚上，看到兄的代码，发现有 .screenupdating 语句，可吓坏我了！我不敢用这条语句，怕的就是万一程序运行到半道出差错了，显示器会不会搞坏？就是 false 这种情况设置了，结果半道出错，没有及时 true，显示器会不会有问题？——所以，我一直不敢用 .screenupdating 屏幕刷新这两句代码。兄可否给我解释一下会不会有问题？
* 兄的代码高级，无可挑剔！但最近我喜欢小代码，感觉兄的代码太多了，超我一倍。可否请兄试用一下我 1 楼的代码？是我前几天最新更新的。
* 下面是兄的代码与我的代码分别测试后的对比情况：（请注意看 BD 与 C 的对齐情况）。
不过，我觉得判断制表位的位置数据，我的不一定对，可能是兄的更对；但表面看起来，似乎我的处理结果更好看。

sylun · 发表于 2022-10-4 12:22

早上查看了我的代码，确实存在问题：是对一行两个选项的情形时制表位值多加了一个字符的长度，即原第93行和110行代码应改为：pos = (wid - aIndent) / 2
另外，该种情形只需加一个自定义制表位即可，第二个是多余的。

总的说来，1.我的制表位参数依据是文档的版心宽度减去左边缩进值（以空格作缩进也算，忽略右缩进及节格式页边距差异）；2.每题以其中有效最多字符的选项为判断选项排列依据；3.处理时不修改原段落的缩进格式，但其中的个别特殊文本格式不会保留；4.如果各选项均没有中文字符，字符宽度按半角字符减半计算；5.根据每题选项数及其有效字符长度进行相应排列设置（暂处理2到4个的）。
因处理方式不同，se兄的代码确实短很多，一般情况下可行。对有的情形，如各选项的字符长度差别太大，可能导致以段落自然行数为选项排列唯一判断标准出现误差。因段落自定义制表位只有三个，之后的制表符只对齐默认制表位即可。另外，如果需要磅值与厘米的度量单位转换，可用PointsToCentimeters或CentimetersToPoints方法获得。
至于ScreenUpdating属性设置问题，一般用于需要实际修改word文档内容或格式等情形，以提高程序运行速度。楼主可以亲自测试的，比如在每次运行本宏前添加一句显示该属性性，看看是不是一样，不管中途是否改变过其属性值。

413191246se · 发表于 2022-10-4 19:40

* sylun 兄：我用表格填充版心再减去两个 0.19 厘米（想起过去《表格处理》宏里面的 .padding=0.19）得到当前版心宽度，就是怕遇到分栏时计算的烦琐（图省事）。
* 前些天，我也编了一个儿能处理 2、3、4、5 个选项的宏；然而，前几天，我觉得平时大家并不怎么处理有这些选项的试卷，代码大而无用，我就将其重新编写为仅处理四个选项的宏，这个比较常用，代码量大大减少。
* 今天上午，我重新就一篇示例文档，重新探究公文自动排版，测试时间是 0.22 秒（未完善）。平时，这篇文档正常都是 0.63/0.67/1.02 秒等处理完毕。我在想，各个标题编号是否需要自动编号？如果不自动编号，会不会减少不少时间？我现在想减少过度排版。
* 我的代码，兄是否观看了？可能不会有一个宏被兄看好吧？水平太低了。大多数是我自编的，都是基本 VBA 代码，不少是在录制宏的基础上修改的。

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

本帖最后由 tangqingfu 于 2022-10-4 21:38 编辑

sylun 发表于 2022-10-3 00:08
结合楼主与tangqingfu兄的附件文档试写了个宏，只做了简单测试。对中英文字符只做了简单判断，有5个与6个选 ...

sylun兄，用您的代码测试附件的文档，好像效果不好，是不是我操作不对

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

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