第一章（宏）2019-8-17 修正！

413191246se · 发表于 2019-8-17 13:49

本帖最后由 413191246se 于 2019-8-17 19:56 编辑

* 不好意思！ "楷体"在代码中是用 FontKT 表示的，但发布时没有带上函数，已经更正！请重新下载！
* 通过 Selection 对象查找“第X章”等特征字符，设置标题 1/2/3 三种级别（也适用于“第一条”/“第一部分”）。
* 本宏并非速度最快，拟用 Range 区域查找、ForEachNext 循环遍历段落法重新 VS，限于时间，稍后再做。
* 反复测试，确信没有问题，功能齐备，请各位朋友们试用（对有需要多级标题编号的朋友们是个福音！）。

Sub 第一章()
'更新/2019-8-17/定稿/Selection
Dim a$, b$, c$, d$, e$, f$, g$, h$, m&, i$, j$, k&, n&, s$, x&
a = MsgBox("<是>：第一章 <否>：第一条 <取消>：自定义 ", 3 + 48, "分类选择")
If a = vbYes Then
j = "章"
ElseIf a = vbNo Then
j = "条"
Else
j = InputBox("", "请输入量词（节/课/题/部分/阶段/自然段）", "部分")
If j = "" Then Exit Sub
End If
If MsgBox("<是>：第一" & j & " <否>：第 1 " & j & " ", 4 + 48, "数词选择") = vbYes Then
n = 2
e = "一"
Else
n = 1
e = "1"
f = " "
End If
If j = "条" Then
g = MsgBox("<是>：正文加粗 <否>：标题级别 ", 4 + 48, "样式选择")
If g = vbYes Then
h = MsgBox("<是>：黑体加粗 <否>：楷体加粗 <取消>：正文加粗 ", 3 + 48, "格式选择")
If h = vbYes Then
m = 1
c = "黑体加粗"
ElseIf h = vbNo Then
m = 2
c = "楷体加粗"
Else
m = 3
c = "正文加粗"
End If
GoTo sk
End If
End If
If m = 0 Then
b = MsgBox("<是>：标题 1 <否>：标题 2 <取消>：标题 3 ", 3 + 48, "级别选择")
If b = vbYes Then
s = 1
c = "标题 1"
ElseIf b = vbNo Then
s = 2
c = "标题 2"
Else
s = 3
c = "标题 3"
End If
If MsgBox("<是>：左对齐 <否>：居中 ", 4 + 48, "对齐选择") = vbYes Then
k = 0
d = "左对齐"
Else
k = 1
d = "居中"
End If
End If
sk:
If MsgBox("请确认最终选择结果！是否继续？ ", 4 + 16, "第" & f & e & f & j & " / " & c & " / " & d) = vbNo Then Exit Sub
i = "^13第[一二三四五六七八九十百零〇○OoＯｏ0-9０-９]@" & j
'''
With Selection
.HomeKey Unit:=wdStory
With .Find
.ClearFormatting
.Text = i
.Replacement.Text = ""
.Forward = True
.MatchWildcards = True
Do While .Execute
With .Parent
.MoveStart
With .Paragraphs(1).Range
With .Find
.Execute "^w", , , , , , , , , "", 2
.Execute "　", , , , , , , , , "", 2
End With
If .Text Like "*[。：；，、！？…—.:;,!?]?" Then .Characters.Last.Previous.Delete
If m = 0 Then
If s = 1 Then
.Style = wdStyleHeading1
ElseIf s = 2 Then
.Style = wdStyleHeading2
.ParagraphFormat.SpaceBefore = 18
Else
.Style = wdStyleHeading3
.ParagraphFormat.SpaceBefore = 18
End If
.Font.Color = wdColorRed
With .ParagraphFormat
.SpaceAfter = 24
.KeepWithNext = False
.KeepTogether = False
End With
If k = 1 Then .ParagraphFormat.Alignment = wdAlignParagraphCenter
End If
End With
.InsertAfter Text:="　"
If .Next.Next.Next.Text = vbCr Then .Next.InsertAfter Text:="　"
.MoveEnd 1, -1
If m <> 0 Then
If m = 1 Then
.Font.NameFarEast = "黑体"
ElseIf m = 2 Then
.Font.NameFarEast = FontKT
End If
With .Font
.Bold = True
.Color = wdColorPink
End With
End If
.MoveEnd 1, -Len(j)
'AutoNum
x = x + 1
If n = 2 Then
.Delete
.Fields.Add Range:=.Range, Text:="= " & x & " \* CHINESENUM3"
.HomeKey 5
.Fields.Unlink
.InsertBefore Text:="第"
ElseIf n = 1 Then
.MoveStart
.Text = x
End If
.Start = .End
End With
Loop
End With
.HomeKey Unit:=wdStory
End With
End Sub
Function FontKT() As String
If System.Version = 5.1 Then FontKT = "楷体_GB2312" Else FontKT = "楷体"
End Function

复制代码

413191246se · 发表于 2019-8-17 19:49

本帖最后由 413191246se 于 2019-8-17 19:57 编辑

略。。。。

13032383987 · 发表于 2019-10-8 18:14

这个宏好是好，但比较突出的问题是不合适公文排版，公文排版往往做为附件形式有几个不同附件，用这个第一章第一条就全部把序号给改了，造成公文内容错误

GONG2816 · 发表于 2019-12-21 08:50

您的代码很好，但有一个问题需要在代码中考虑。假如是对“第一章”这样的情况的格式进行调整，当它的位置是在文件的第一段，或者是在表格后的第一段时，这个代码无法变化格式

cuanju · 发表于 2019-12-21 10:48

可以在正式代码前用代码增加一个空段，并在所有表格后增加一段，在代码末尾再用代码删除。

=============================
Sub 后续处理()
'文章首段前增加一个空段
ActiveDocument.Content.InsertBefore Chr(13)
'在所有表格后增加一段
On Error Resume Next
Dim Tbl As Table
For Each Tbl In ActiveDocument.Tables
      Set tempRange = ActiveDocument.Range(Tbl.Range.End, Tbl.Range.End)
      tempRange.InsertAfter Chr(13)
Next

'*********此处放置正式代码**********

'删除原本表格后增加的一段
For Each Tbl In ActiveDocument.Tables
      Set tempRange = Tbl.Range
      tempRange.Collapse 0
      tempRange.Delete
Next
'删除文章首段前增加的空段
If Len(ActiveDocument.Paragraphs(1).Range) < 2 Then ActiveDocument.Paragraphs(1).Range = Empty
End Sub

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

[分享] 第一章（宏）2019-8-17 修正！

评分