把杂乱无章的符号及带圈序号按顺序排列

batmanbbs · 发表于 2023-5-2 00:38

改进一下，可以重复执行（原来的代码只能执行一次，执行第二次时识别就不准确了）

Sub 去乱码编序号()
Dim myPG As Paragraph
Dim oType%, No%, count%, i%, rStart&, rEnd&, RegEx$, rng$
Dim oRegEx As Object, myMatches As Object
Set oRegEx = CreateObject("VBSCRIPT.REGEXP")
With oRegEx
.IgnoreCase = False
.MultiLine = False
.Global = True
End With
RegEx = "[\uF022-\uF084]+|[^一-﨩，、；。“”]+"
oType = 0: No = 0
For Each myPG In ActiveDocument.Paragraphs
With myPG.Range
rng = Left(.Text, Len(.Text) - 1)
If Trim(Len(rng)) <> 0 Then
If rng = "【原文】" Then
oType = 1: No = 0
ElseIf rng = "【校注】" Then
oType = 2: No = 0
ElseIf rng = "【理论阐释】" Then
oType = 0: No = 0
ElseIf oType = 1 Then
If .Text Like "*[一-﨩]*" Then
With oRegEx
.Pattern = RegEx
Set myMatches = .Execute(rng)
End With
count = myMatches.count
If myMatches.count > 0 Then
No = No + count
For i = count - 1 To 0 Step -1
rStart = .Start + myMatches(i).FirstIndex
rEnd = rStart + myMatches(i).Length
With ActiveDocument.Range(rStart, rEnd)
.Text = Chr(33 + (No - count + i + 1))
.Font.ColorIndex = wdRed
.Font.Bold = False
.Font.Name = "Numbers & Pinyin"
End With
Next i
End If
End If
ElseIf oType = 2 Then
For i = 1 To 3
If .Characters(i) Like "[一-" & ChrW(-4063) & ChrW(-3963) & "-﨩]" Then
No = No + 1
rStart = .Start
rEnd = rStart + i - 1
With ActiveDocument.Range(rStart, rEnd)
.Text = Chr(33 + No) & "、"
.Font.ColorIndex = wdRed
.Font.Bold = False
.Font.Name = "Numbers & Pinyin"
End With
Exit For
End If
Next i
End If
End If
End With
Next myPG
Set myPG = Nothing
Set oRegEx = Nothing
Set myMatches = Nothing
End Sub

复制代码

batmanbbs · 发表于 2023-5-2 08:55

本帖最后由 batmanbbs 于 2023-5-2 08:59 编辑

还有两个回复没有通过审核

相见是缘8 · 发表于 2023-5-2 15:02

batmanbbs 发表于 2023-5-2 00:38
改进一下，可以重复执行（原来的代码只能执行一次，执行第二次时识别就不准确了）

batmanbbs 老师，好！

感谢你的代码！感谢你的辛勤付出！

代码，刚在“附件”上，测试了，完美达愿，但在实际文档（含有多张图片、表格等）中，测试出现如下图所示，把“附件”中，加入了一张图片，测试也出现如下图所示，老师可否有办法？

batmanbbs · 发表于 2023-5-2 18:01

本帖最后由 batmanbbs 于 2023-5-2 18:30 编辑

该问题已经修正，因为审核起来非常费时间，所以就没有再发修正的内容
我之前又改进了两个地方，一个就是你截图中的问题，当时没有考虑段落长度的问题；二是分类的时候，除了【原文】和【校注】外，再次遇到【】包括起来的内容都会重复计算序号，不必非要【理论阐释】。

我修改后，有图片的那个段落如果需要编号，而且图片在段落首，会被删除掉。你会不会有图片的段落也需要编号呢？建议你考虑出所有问题，再提供附件，因为我只会参考你附件进行处理，不可能总是修改，见谅。

另外，图片还分嵌入式和非嵌入式，定位的算法也不一样。

batmanbbs · 发表于 2023-5-2 18:02

本帖最后由 batmanbbs 于 2023-5-2 20:33 编辑

Sub 去乱码编序号()

Dim myPG As Paragraph
Dim oType%, No%, count%, i%, rStart&, rEnd&, RegEx$, rng$
Dim oRegEx As Object, myMatches As Object
Set oRegEx = CreateObject("VBSCRIPT.REGEXP")
With oRegEx
      .IgnoreCase = False
      .MultiLine = False
      .Global = True
End With

RegEx = "[\uF022-\uF084]+|[^一-﨩，、；。“”]+"
oType = 0: No = 0
For Each myPG In ActiveDocument.Paragraphs
      With myPG.Range
         rng = Left(.Text, Len(.Text) - 1)
         If Trim(Len(rng)) <> 0 Then
            If Trim(rng) = "【原文】" Then
                  oType = 1: No = 0
            ElseIf Trim(rng) = "【校注】" Then
                  oType = 2: No = 0
            ElseIf Trim(rng) Like "【*】" Then
                  oType = 0: No = 0
            ElseIf oType = 1 Then
                  If rng Like "*[一-﨩]*" Then
                     With oRegEx
                        .Pattern = RegEx
                        Set myMatches = .Execute(rng)
                     End With
                     count = myMatches.count
                     If count > 0 Then
                        No = No + count
                        For i = count - 1 To 0 Step -1
                              rStart = .Start + myMatches(i).FirstIndex
                              rEnd = rStart + myMatches(i).Length
                              With ActiveDocument.Range(rStart, rEnd)
                                 .Text = Chr(33 + (No - count + i + 1))
                                 .Font.ColorIndex = wdRed
                                 .Font.Bold = False
                                 .Font.Name = "Numbers & Pinyin"
                              End With
                        Next i
                     End If
                  End If
            ElseIf oType = 2 Then
                  If Len(rng) >= 3 Then
                     For i = 1 To 3
                        If .Characters(i) Like "[一-" & ChrW(-4063) & ChrW(-3963) & "-﨩]" Then
                              No = No + 1
                              rStart = .Characters(1).Start
                              rEnd = rStart + i - 1
                              With ActiveDocument.Range(rStart, rEnd)
                                 .Text = Chr(33 + No) & "、"
                                 .Font.ColorIndex = wdRed
                                 .Font.Bold = False
                                 .Font.Name = "Numbers & Pinyin"
                              End With
                              Exit For
                        End If
                     Next i
                  End If
            End If
         End If
      End With
Next myPG

Set myPG = Nothing
Set oRegEx = Nothing
Set myMatches = Nothing

End Sub

相见是缘8 · 发表于 2023-5-2 19:12

batmanbbs 发表于 2023-5-2 18:01
该问题已经修正，因为审核起来非常费时间，所以就没有再发修正的内容
我之前又改进了两个地方，一个就是你 ...

batmanbbs 老师，好！
不需要了，你修改后的代码可以了，完美的解决了困扰我多日的难题，衷心感谢老师！谢谢！

batmanbbs · 发表于 2023-5-2 19:42

相见是缘8 发表于 2023-5-2 19:12
batmanbbs 老师，好！
不需要了，你修改后的代码可以了，完美的解决了困扰我多日的难题，衷心感谢老师！ ...

你能看到我修改后的代码？我自己都看不到啊，怎么回事

相见是缘8 · 发表于 2023-5-3 06:34

batmanbbs 发表于 2023-5-2 19:42
你能看到我修改后的代码？我自己都看不到啊，怎么回事

batmanbbs 老师，好！
昨天你代码发上来后，能看到，我在 16 楼回复你时，是看不到了，今天可以看到。
老师，你不但技术好，还认真负责的提示和指教！真难得！再次感谢你！

相见是缘8 · 发表于 2023-5-15 07:14

本帖最后由相见是缘8 于 2023-5-15 07:16 编辑

batmanbbs 发表于 2023-5-2 00:38
改进一下，可以重复执行（原来的代码只能执行一次，执行第二次时识别就不准确了）

batmanbbs 老师，好！

今天才发现：

像【原文】中，类似有这个 “䪼” 字及序号的，运行代码后，会删除了这个字及序号的情况，如下图2所示。

而在这个【校注】中，类似有这个 “䪼” 字及序号的，运行代码后，却不能正常的排序，不知是什么原因？

老师你可否有办法？

batmanbbs · 发表于 2023-5-15 08:47

没有听明白，你是不是想保留这个"䪼"字？

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

[求助] 把杂乱无章的符号及带圈序号按顺序排列