Word2003VBA 通用模板宏（2019元旦版）更新：2018-12-29

413191246se · 发表于 2019-1-21 19:24

翼★虎，你好！——在 2003 中，“插入”菜单——数字——键入一个数字，如 5，确定——将此过程录下来发现，有一个叫 ChineseNum3 的也许是函数，我也不懂，你看你能否在你的 2010 中重复此过程？
——我建议不要轻易放弃《Title2345AutoNum》这个宏，因为有它就可以不用校对公文标题四个层次的编号（序号）了！否则每个文档编号都要人工目视校对。——这个宏，原来我以为很难搞，但一动手发现，也不是太难，轻松突破。

翼★虎 · 发表于 2019-1-22 13:47

413191246se 老师好，我看了你以前的帖子，有一篇关于序号连续判断的帖子，借鉴杜先生的帖子做了修改基本达到了目的。我增加了序号转文本后，标题为“1.XX,2.XX”时候，全篇连续编排，不会被“一、XX,二、XX”及“（一）XX 、（二）、XX”打断重拍。另外，标题与正文不分段时候会整段识别为标题“（二）主要目标。进一步明确规范……”→ “（二）主要目标。进一步明确规范……”最近电脑无法上传附件，沟通起来稍显不便，老师见谅。

Sub Title2345AutoNum()
Dim a, b, j&, ksr$, x&, sr$, r1$, r2$, r3$, r4$
Call ListTitle(ActiveDocument)
ActiveDocument.content.Find.Execute "^11", , , 1, , , , , , "^p", 2
ActiveDocument.content.Find.Execute "^p^w", , , 0, , , , , , "^p", 2
sr$ = "〇一二三四五六七八九十百千万亿"
r1$ = "[" & sr & "]@、": r2$ = "[(（][" & sr & "]@[)）]"
r3$ = "[0-9]@[、.．]": r4$ = "[(（][0-9]@[)）]"
a = Array(r1, r2, r3, r4)
b = Array("标题 2", "标题 3", "标题 4", "标题 5")
For j = 0 To UBound(a)
With ActiveDocument.content.Find
Do While .Execute(a(j), , , 1)
With .Parent
If Not .Information(wdWithInTable) Then
x = Len(.Text): ksr = .Text
.Expand 4: .Collapse
If .MoveWhile(ksr, x) = x Then
.MoveStart , -x: .Text = Empty
.Style = ActiveDocument.Styles("" & b(j) & "")
Else
.Move 4, 1
End If
End If
End With
Loop
ActiveDocument.content.ListFormat.ConvertNumbersToText
End With
Next
End Sub
Sub ListTitle(doc As Document)
Dim LtTemp As ListTemplate, i As Integer, a
Set LtTemp = doc.ListTemplates.Add(True)
a = Array(6, 5, 2, 11)
For i = 2 To 5
With LtTemp.ListLevels(i)
If i = 2 Then .NumberFormat = "%2、": .NumberStyle = 37
If i = 3 Then .NumberFormat = "（%3）": .NumberStyle = 37
If i = 4 Then .NumberFormat = "%4.": .NumberStyle = 0
If i = 5 Then .NumberFormat = "（%5）": .NumberStyle = 0
.TrailingCharacter = 2: .StartAt = 1: .ResetOnHigher = True
.NumberPosition = InchesToPoints(0.2 * (i - 1))
.TextPosition = InchesToPoints(0.2 * i)
.LinkedStyle = "标题 " & i
doc.Styles("标题 " & i).Font.ColorIndex = a(i - 2)
doc.Fields.Update
doc.Fields.Unlink
End With
Next
End Sub

复制代码

413191246se · 发表于 2019-1-22 14:13

翼★虎：我昨晚重新为你做了一个新的《Title2345AutoNum》宏（包括处理标题2/3时用新编《Num2Chn》宏，共2个宏），这回用的是翻译法，直接把“1”等翻译为“一”等，最大适用值是999（九百九十九），与 Word 版本无关了，不再删除域，应该可以了，你试试（将光标放在 VBE 中原来的《Title2345AutoNum》宏中双击，按删除键Delete删除，粘贴上新宏）：

Sub Title2345AutoNum()
Dim doc As Document, r As Range, i As Paragraph, b&, c&, d&, e&
Set doc = ActiveDocument
With Selection
.Expand 4
.EndKey 6, 1
Set r = .Range
End With
For Each i In r.Paragraphs
With i.Range
If Not .Information(12) Then
If .Style = "标题 1" Or .Text Like "[!^13]附件*" Or .Text Like "附件*" Then
b = 0: c = 0: d = 0: e = 0
ElseIf .Style = "标题 2" Then
c = 0: d = 0: e = 0
b = b + 1
With doc.Range(Start:=.Characters(1).Start, End:=.Characters(InStr(i.Range, "、")).End - 1)
.Text = b
.Select
Num2Chn
End With
ElseIf .Style = "标题 3" Then
d = 0: e = 0
c = c + 1
With doc.Range(Start:=.Characters(1).Start, End:=.Characters(InStr(i.Range, "）")).End - 1)
.Text = c
.Select
Num2Chn
.InsertBefore Text:="（"
End With
ElseIf .Style = "标题 4" Then
e = 0
d = d + 1
doc.Range(Start:=.Characters(1).Start, End:=.Characters(InStr(i.Range, "．")).End - 1).Text = d
ElseIf .Style = "标题 5" Then
e = e + 1
With doc.Range(Start:=.Characters(1).Start, End:=.Characters(InStr(i.Range, "）")).End - 1)
.Text = e
.InsertBefore Text:="（"
End With
End If
End If
End With
Next
End Sub
Sub Num2Chn()
Dim a, r As Range, v&, i&
a = Array("零", "一", "二", "三", "四", "五", "六", "七", "八", "九")
With Selection
Set r = .Range
v = Len(.Text)
If v > 3 Then Exit Sub
With r
For i = 1 To v
.Characters(i).Text = a(.Characters(i))
Next i
If .Next.Text = "零" Then .Next.Delete
If v = 2 Then
.InsertAfter Text:="十"
If .Characters(1).Text = "一" Then .Characters(1).Delete
ElseIf v = 3 Then
.Characters(1).InsertAfter Text:="百"
.InsertAfter Text:="十"
.Select
If .Text Like "*百零十" Then
If .Next Like "[一二三四五六七八九]" Then
.Characters.Last.Delete
Else
.Text = Replace(.Text, "零十", "")
End If
End If
End If
End With
End With
End Sub

复制代码

翼★虎 · 发表于 2019-1-22 17:52

413191246se 老师好，我按你的最新思路，解决了中文标题及后被删除问题。当原始段落为word编号文件时候，利用《Title2345AutoNum》宏排序时候，原序号不会删除，同时生成新的序号。会出现（1.1.XX;2.2.XX;）（一、一、XX;二、二、.XX;），希望老师在闲暇之余测试下。谢谢。

413191246se · 发表于 2019-1-22 23:28

翼★虎：请你暂时先用 76 楼代码测试文档；但 75 楼代码不要用了！因为，杜先生/老师（duquancai）他的正则表达式代码是有问题的！不能用！！！——要不我为什么不用他的代码呢？确实是有问题，影响排版效果。我不会对任何人有偏见而不用他的代码，我只针对代码是否能正确排版。——你不用上传附件了，上传我可能也下载出错，你只需将一些文字复制上来，我下载试试吧！因为我只针对公文四个层次进行排版，关于多级编号这个问题，我因为从来也用不到，所以，也从来没有进行过排版测试。

413191246se · 发表于 2019-1-23 01:00

最新 76 楼代码（未用到域），有问题吗？

翼★虎 · 发表于 2019-1-23 09:10

413191246se 老师好，76楼代码进行文本排版没有问题，谢谢。如果复制源文件中有多级编号时候就会出现标题重复问题。

zyqn518 · 发表于 2019-1-23 10:51

标记，学习
多谢

413191246se · 发表于 2019-1-23 12:00

翼★虎：如果你有多级编号的文本示例，可以复制上来，我不太懂多级编号。——另外，其实，公文排版，似乎是用不到多级编号的。当然广义上来说，是什么文档都能排版。——有问题咱们继续探讨。

翼★虎 · 发表于 2019-1-23 14:12

413191246se 老师好，我拿你的《如何判断公文标题层次序号是连续》范文，生成多级编号。做下测试。你试试看能否正常打开。谢谢。

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

[分享] Word2003VBA 通用模板宏（2019元旦版）更新：2018-12-29