VBA将选项对齐

sylun · 发表于 2024-3-4 22:05

本帖最后由 sylun 于 2024-3-4 22:40 编辑

可以试试如下代码，采用平分制表位定位：

Sub test()
'试题选项对齐（最多6个选项），仅针对纯文本文档
Dim i%, j%, k%, fontsize%, colwidth!, maxlen%, tabwidth!
Dim qs, opt, olen
Dim Reg As Object, Matches As Object, Match As Object, aRange As Range
Set Reg = CreateObject("vbscript.regexp")
With Reg
.Global = True
.MultiLine = True
.Pattern = "^\d+\.\s.+?([A-F].+?)\r+(【答案】[A-F]+\r+)*(?=(^\d+\.|$))"
Set Matches = .Execute(ActiveDocument.Content.Text)
ReDim qs(2, Matches.Count - 1)
For Each Match In Matches
With Match
qs(0, i) = .firstindex + InStr(.Value, Chr(13))
qs(1, i) = qs(0, i) + Len(.SubMatches(0))
qs(2, i) = Trim(.SubMatches(0))
i = i + 1
End With
Next
With ActiveDocument.Range(qs(0, 0), qs(0, 0))
fontsize = .Font.Size
colwidth = .PageSetup.TextColumns(1).Width
End With
.Pattern = "(?:^|[\s　]+)([A-F])[\.．]"
For i = i - 1 To 0 Step -1
qs(2, i) = Replace(qs(2, i), Chr(9), " ") '预防性替换
qs(2, i) = .Replace(qs(2, i), Chr(9) & "$1．")
qs(2, i) = Replace(qs(2, i), Chr(13), "")
qs(2, i) = Mid(qs(2, i), 2)
opt = Split(qs(2, i), Chr(9))
ReDim olen(UBound(opt))
For j = 0 To UBound(olen)
olen(j) = Len(opt(j))
Next
maxlen = 0
For j = 0 To UBound(olen)
If olen(j) > maxlen Then maxlen = olen(j)
Next
Application.ScreenUpdating = False
Set aRange = ActiveDocument.Range(qs(0, i), qs(1, i))
With aRange
With .ParagraphFormat '根据字符数最多的选项设置制表位
.TabStops.ClearAll
Select Case fontsize * (maxlen - 2)
Case Is > (colwidth - 2 * fontsize) / 2
qs(2, i) = Replace(qs(2, i), Chr(9), Chr(13))
Case Is > (colwidth - 2 * fontsize) / 4 Or j = 2
.TabStops.Add (colwidth + 2 * fontsize) / 2
If j > 2 Then qs(2, i) = Replace(qs(2, i), Chr(9) & "C．", Chr(13) & "C．")
If j > 4 Then qs(2, i) = Replace(qs(2, i), Chr(9) & "E．", Chr(13) & "E．")
Case Is < (colwidth - 2 * fontsize) / 3 And j <> 4
.TabStops.Add (colwidth + 4 * fontsize) / 3
.TabStops.Add 2 * (colwidth + fontsize) / 3
If j > 3 Then qs(2, i) = Replace(qs(2, i), Chr(9) & "D．", Chr(13) & "D．")
Case Else '暂不考虑一行可容纳五六个选项的情形
.TabStops.Add 2 * fontsize + (colwidth - 2 * fontsize) / 4
.TabStops.Add 2 * fontsize + (colwidth - 2 * fontsize) / 2
.TabStops.Add 2 * fontsize + 3 * (colwidth - 2 * fontsize) / 4
End Select
End With
.Text = qs(2, i)
.End = .End + 1
k = (UBound(olen) + 1) / .ComputeStatistics(4)
tabwidth = .ParagraphFormat.TabStops(1).Position - 2 * fontsize
If .ComputeStatistics(1) <> .ComputeStatistics(4) And InStr(.Text, Chr(9)) <> 0 Then _
setOptionSpacing .Duplicate, maxlen, k, tabwidth, olen '行段数不一致则调整字符间距
.ParagraphFormat.LeftIndent = 0 '假设无其他段落缩进
.ParagraphFormat.CharacterUnitLeftIndent = 2
End With
Next
End With
Application.ScreenUpdating = True
End Sub

复制代码

原来漏了一段：

Sub setOptionSpacing(myRange As Range, maxlen%, pcount%, tabwidth!, olen)
Dim i%, j%, k%, n%
For i = 1 To myRange.ComputeStatistics(4)
With myRange.Paragraphs(i).Range
If .ComputeStatistics(1) <> .ComputeStatistics(4) Then
Do
k = k + 1
If j Mod pcount = 0 Then .End = .Start + olen(j) + 1 _
Else .SetRange .End, .End + .MoveEndUntil(vbTab & Chr(13))
If maxlen - olen(j) < 2 Then
Do While .Characters.Last.Information(5) - .Information(5) > tabwidth _
Or .Characters.Last.Information(5) < .Information(5)
.Font.Spacing = -0.1 * n
If n < 6 Then n = n + 1 Else Exit Do
Loop
n = 0
End If
j = j + 1
Loop Until k = pcount
k = 0
Else
j = j + UBound(olen) / pcount
End If
End With
Next
End Sub

复制代码

小花鹿 · 发表于 2024-3-5 07:39

sylun 发表于 2024-3-4 22:05
可以试试如下代码，采用平分制表位定位：
原来漏了一段：

好，我测试一下，先谢谢

小花鹿 · 发表于 2024-3-5 11:57

sylun 发表于 2024-3-4 22:05
可以试试如下代码，采用平分制表位定位：
原来漏了一段：

我手动可以设置成这种效果：

batmanbbs · 发表于 2024-3-5 15:27

本帖最后由 batmanbbs 于 2024-3-5 15:35 编辑

小花鹿发表于 2024-3-5 11:57
我手动可以设置成这种效果：

固定就是4个选项没有问题。分别就是一行1个选项，2个选项，4个选项。
先判断4个，每个选项的字数之和+3，小于页面宽度，一行放4个；
否则，判断第1选项和第3选项字符数取大，第2选项和第4选项字符数取大，两个大者相加+1，小于页面宽度，一行放2个，制表位就是第一组取大+1的位置；
否则，一行一个。

PS：这种方法不是平分方法，有时会显得比较乱，我还是喜欢用平分的方法

小花鹿 · 发表于 2024-3-5 20:55

batmanbbs 发表于 2024-3-5 15:27
固定就是4个选项没有问题。分别就是一行1个选项，2个选项，4个选项。
先判断4个，每个选项的字数之和+3 ...

等待高手的出现

sylun · 发表于 2024-3-5 21:43

小花鹿发表于 2024-3-5 11:57
我手动可以设置成这种效果：

前面代码只是按全角字符对选项长度进行推算，对半角字符较多的选项有较大误差。现对代码稍作修改，并兼顾一行可平均排列五六个选项的情形，每题选项数6个以内不限。请楼主再测试，原9号题4选项本身可一行排满，如确需分两个段落，可修改代码。当然，代码并不适用于需要保留原字符格式或有图片图形的情形。

Sub test2()
'试题选项对齐（最多6个选项），仅针对纯文本文档
Dim i%, j%, k%, fontsize%, colwidth!, maxlen%, tabwidth!
Dim qs, opt, olen
Dim Reg As Object, Matches As Object, Match As Object, aRange As Range
Set Reg = CreateObject("vbscript.regexp")
With Reg
.Global = True
.MultiLine = True
.Pattern = "^\d+[\.．]\s?.+?([A-F].+?)\r+(【答案】[A-F]+\r+)*(?=(^\d+\.|$))"
Set Matches = .Execute(ActiveDocument.Content.Text)
ReDim qs(2, Matches.Count - 1)
For Each Match In Matches
With Match
qs(0, i) = .firstindex + InStr(.Value, Chr(13))
qs(1, i) = qs(0, i) + Len(.SubMatches(0))
qs(2, i) = Trim(.SubMatches(0))
i = i + 1
End With
Next
With ActiveDocument.Range(qs(0, 0), qs(0, 0))
fontsize = .Font.Size
colwidth = .PageSetup.TextColumns(1).Width
End With
.Pattern = "(?:^|[\s　]+)([A-F])[\.．]"
For i = i - 1 To 0 Step -1
qs(2, i) = Replace(qs(2, i), Chr(9), " ") '预防性替换
qs(2, i) = .Replace(qs(2, i), Chr(9) & "$1．")
qs(2, i) = Replace(qs(2, i), Chr(13), "")
qs(2, i) = Mid(qs(2, i), 2)
opt = Split(qs(2, i), Chr(9))
ReDim olen(UBound(opt))
For j = 0 To UBound(olen)
olen(j) = Len(opt(j))
Next
maxlen = 0
For j = 0 To UBound(opt)
If LenB(StrConv(opt(j), vbFromUnicode)) > maxlen Then maxlen = LenB(StrConv(opt(j), 128))
Next
Application.ScreenUpdating = False
Set aRange = ActiveDocument.Range(qs(0, i), qs(1, i))
With aRange
With .ParagraphFormat '根据字符数最多的选项设置制表位
.TabStops.ClearAll
Select Case fontsize * (maxlen / 2 - 2)
Case Is > (colwidth - 2 * fontsize) / 2
qs(2, i) = Replace(qs(2, i), Chr(9), Chr(13))
Case Is > (colwidth - 2 * fontsize) / 4 Or j = 2
.TabStops.Add (colwidth + 2 * fontsize) / 2
If j > 2 Then qs(2, i) = Replace(qs(2, i), Chr(9) & "C．", Chr(13) & "C．")
If j > 4 Then qs(2, i) = Replace(qs(2, i), Chr(9) & "E．", Chr(13) & "E．")
Case Is < (colwidth - 2 * fontsize) / 6 And j = 6
For k = 1 To 5
.TabStops.Add 2 * fontsize + k * (colwidth - 2 * fontsize) / 6
Next
Case Is < (colwidth - 2 * fontsize) / 5 And j = 5
For k = 1 To 4
.TabStops.Add 2 * fontsize + k * (colwidth - 2 * fontsize) / 5
Next
Case Is < (colwidth - 2 * fontsize) / 3 And j <> 4
.TabStops.Add (colwidth + 4 * fontsize) / 3
.TabStops.Add 2 * (colwidth + fontsize) / 3
If j > 3 Then qs(2, i) = Replace(qs(2, i), Chr(9) & "D．", Chr(13) & "D．")
Case Else
For k = 1 To 4
.TabStops.Add 2 * fontsize + k * (colwidth - 2 * fontsize) / 4
Next
End Select
End With
.Text = qs(2, i)
.End = .End + 1
k = (UBound(olen) + 1) / .ComputeStatistics(4)
tabwidth = .ParagraphFormat.TabStops(1).Position - 2 * fontsize
If .ComputeStatistics(1) <> .ComputeStatistics(4) And InStr(.Text, Chr(9)) <> 0 Then _
setOptionSpacing .Duplicate, maxlen, k, tabwidth, olen '行段数不一致则调整字符缩放
.ParagraphFormat.LeftIndent = 0 '假设无其他段落缩进格式
.ParagraphFormat.CharacterUnitLeftIndent = 2 '选项段落统一左缩进2字符
End With
Next
End With
Application.ScreenUpdating = True
End Sub
Sub setOptionSpacing(myRange As Range, maxlen%, pcount%, tabwidth!, olen)
Dim i%, j%, k%
For i = 1 To myRange.ComputeStatistics(4)
With myRange.Paragraphs(i).Range
If .ComputeStatistics(1) <> .ComputeStatistics(4) Then
Do
k = k + 1
If j Mod pcount = 0 Then .End = .Start + olen(j) + 1 _
Else .SetRange .End, .End + .MoveEndUntil(vbTab & Chr(13))
If maxlen / 2 - olen(j) < 0 Then .FitTextWidth = tabwidth - .Font.Size
j = j + 1
Loop Until k = pcount
k = 0
Else
j = j + UBound(olen) / pcount
End If
End With
Next
End Sub

复制代码

batmanbbs · 发表于 2024-3-6 13:17

本帖最后由 batmanbbs 于 2024-3-6 19:29 编辑

已打包，见楼下附件

batmanbbs · 发表于 2024-3-6 13:25

小花鹿发表于 2024-3-5 20:55
等待高手的出现

非高手，基于sylun老师代码修改，非平分定位

小花鹿 · 发表于 2024-3-6 17:42

batmanbbs 发表于 2024-3-6 13:25
非高手，基于sylun老师代码修改，非平分定位

好，大家测试一下

小花鹿 · 发表于 2024-3-9 10:56

我找到完美解决方案了，就是先把选项转换成表格，再把表格转换成文本，分割符为制表符，就可以做到选项对齐了，不限选项个数，也能适用于格式文档（非纯文本）。

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

[求助] VBA将选项对齐

评分

评分