发文字号（宏）

413191246se · 发表于 2020-9-29 00:08

* 功能：如果存在发文字号则设置格式；否则插入发文字号并设置格式。
* 修改：代码中有 4 处“可修改”的地方，可改为自己单位发文所用数据。

Sub 发文()
Const s As String = "委发" '可修改
Dim r As Range, i&, j As Paragraph
With ActiveDocument
With .Content.Find
.Execute "[^13^l]", , , 1, , , , , , "^p", 2
.ClearFormatting
.Text = "^13[!^13]@[：。:]"
.Forward = True
.MatchWildcards = True
.Execute
If .Found = True Then
With .Parent
.Select
With Selection
.HomeKey 6, 1
.MoveEnd
.ClearFormatting
CommandBars.FindControl(ID:=122).Execute
With .Font
.NameFarEast = "宋体"
.NameAscii = "Times New Roman"
.Bold = True
.Kerning = 0
.DisableCharacterSpaceGrid = True
End With
With .ParagraphFormat
.LineSpacing = LinesToPoints(1.15)
.AutoAdjustRightIndent = False
.DisableLineHeightGrid = True
End With
Set r = .Range
With r
For Each j In .Paragraphs
If Len(j.Range) = 1 Then j.Range.Delete
Next
With .Paragraphs(1).Range
If Not .Text Like "*〔[0-9][0-9][0-9][0-9]〕*号*" Then .InsertBefore Text:=s & "〔" & Format(Date, "yyyy") & "〕" & "X号" & vbCr
End With
With .Paragraphs(1).Range
.InsertParagraphAfter
.InsertParagraphBefore
End With
.Characters.Last.InsertParagraphBefore
i = .Paragraphs.Count
End With
End With
End With
End If
End With
.Paragraphs(1).Range.Font.Size = 108 '可修改
With .Paragraphs(2).Range.Font
.Name = "仿宋"
.Size = 16
End With
.Paragraphs(3).Range.Font.Size = 36 '可修改
.Range(Start:=.Paragraphs(4).Range.Start, End:=.Paragraphs(i - 1).Range.End).Font.Size = 22
.Paragraphs(i).Range.Font.Size = 26 '可修改
End With
End Sub

复制代码

dengcaimao · 发表于 2020-10-11 14:47

谢谢提供这么好的工具

hebeijianke · 发表于 2020-12-29 23:10

Mark一下，好东西，很实用((o(^_ ^)o))

hebeijianke · 发表于 2020-12-30 11:03

运行出现4608错误，什么情况，知道吗

czghx2006 · 发表于 2021-1-7 20:14

好东西，感谢分享，我试试

413191246se · 发表于 2021-1-7 21:53

4 楼朋友：使用此宏前，必须先用我的《公文排版》宏排版。请再试试。

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

[分享] 发文字号（宏）