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

最新推荐文章于 2023-06-18 12:14:00 发布

sandorn

最新推荐文章于 2023-06-18 12:14:00 发布

阅读量1.4k

点赞数

文章标签： vba word

'http://club.excelhome.net/thread-1452376-1-1.html

Attribute VB_Name = "NewMacros"
Option Explicit
Sub AutoOpen()
On Error Resume Next
Dim y$, x$, s As Section, i&, j&
With ActiveDocument
y = .FullName
If y Like "*.docx" Then
If MsgBox("是否转换为 Word2003 格式？", vbYesNo + vbCritical) = vbYes Then
x = Left(y, Len(y) - 5)
.SaveAs FileName:=x, FileFormat:=wdFormatDocument
If MsgBox("是否删除源文件？", 4 + 16) = vbYes Then
.Close
Kill y
Documents.Open FileName:=x
End If
End If
End If
For Each s In .Sections
With s.PageSetup
If .Orientation = wdOrientLandscape Then j = 1
If .PaperSize <> wdPaperA4 Then
If i = 0 Then i = 1: If MsgBox("是否改为A4纸张？", 4 + 16) = vbNo Then Exit Sub
.PaperSize = wdPaperA4
If j = 1 Then .Orientation = wdOrientLandscape
End If
End With
j = 0
Next
If .Tables.Count > 0 Then CommandBars("Tables and Borders").Visible = True Else CommandBars("Tables and Borders").Visible = False
End With
End Sub
Sub AutoClose()
ActiveWindow.DocumentMap = False
End Sub
Sub 公文()
Dim t!, x&, y&, s!
x = ActiveDocument.BuiltInDocumentProperties(wdPropertyWords)
t = Timer
核心
s = Round(Timer - t, 2)
y = ActiveDocument.BuiltInDocumentProperties(wdPropertyWords)
显示页数
ActiveWindow.DocumentMapPercentWidth = 20
MsgBox "排版完毕！用时 " & s & " 秒！共 " & Selection.Information(wdNumberOfPagesInDocument) & " 页！ " & vbCr & vbCr & "排版前字数 = " & x & vbCr & "排版后字数 = " & y, 0 + 48
ActiveWindow.ActivePane.View.Zoom.PageFit = wdPageFitBestFit
End Sub
Sub 核心()
Dim doc As Document, t As Table, j As Long, k As Long, i As Long
Set doc = ActiveDocument
ActiveWindow.View.Type = wdPrintView
PaperSetup

With doc
With .Content.Find
.Execute "^13", , , , , , , , , "^p", 2
.Execute "^11", , , , , , , , , "^p", 2
.Parent.ListFormat.ConvertNumbersToText
End With

With .Paragraphs.Last.Range
If .Text Like "*" & vbTab & vbCr Then .Delete
End With

If .Tables.Count = 0 Then
.Select
正文样式
Else
'取消环绕
For Each t In .Tables
With t.Range.Rows
.WrapAroundText = False
.Alignment = wdAlignRowCenter
End With
Next

'首表上方
If .Paragraphs(1).Range.Information(wdWithInTable) = False Then
.Range(Start:=0, End:=.Tables(1).Range.Start).Select
正文样式
End If

'表间循环
k = .Tables.Count
rc:
For j = 1 To k
If j = k Then Exit For
.Range(Start:=.Tables(j).Range.End, End:=.Tables(j + 1).Range.Start).Select
正文样式
i = k
k = .Tables.Count
If k = i - 1 Then GoTo rc
Next j

'末表下方
.Range(Start:=.Tables(k).Range.End, End:=.Content.End).Select
正文样式

'表下加空
For Each t In .Tables
With t.Range.Next
If Asc(.Text) <> 13 Then .InsertParagraphBefore: .MoveEnd 1, -1
.Font.Size = 4
End With
Next
End If

With .Content.Find
.Execute "(", , , , , , , , , "（", 2
.Execute ")", , , , , , , , , "）", 2
.Execute "）、", , , , , , , , , "）", 2

.Execute "([、.．])([ 　^s^t]{1,})", , , 1, , , , , , "\1", 2
.Execute "([ 　^s^t]@)([、.．])", , , 1, , , , , , "\2", 2
.Execute "(^12)^13", , , 1, , , , , , "\1", 2
.Execute "(^13) ", , , , , , , , , "\1", 2

.Execute "([0-9０-９])、", , , 1, , , , , , "\1．", 2
.Execute "([0-9０-９]).([一-﨩])", , , 1, , , , , , "\1．\2", 2
.Execute "(^13[0-9０-９]{1,}).", , , 1, , , , , , "\1．", 2

.Execute "([0-9０-９])：([0-9０-９])", , , 1, , , , , , "\1:\2", 2
.Execute "([0-9０-９])，([0-9０-９])", , , 1, , , , , , "\1,\2", 2
.Execute "([0-9０-９])。([0-9０-９])", , , 1, , , , , , "\1.\2", 2

.Execute "附表", , , , , , , , , "附件", 2
.Execute "(^13)附([：:.．、，,^13])", , , 1, , , , , , "\1附件\2", 2
.Execute "(^13)附([ 　^s^t0-9０-９]{1,})", , , 1, , , , , , "\1附件\2", 2
.Execute "(^13)附([：:.．、，,]^13)", , , 1, , , , , , "\1附件\2", 2

.Execute "([二一])([零〇○0Oo])(??年)", , , 1, , , , , , "\1〇\3", 2
.Execute "([二一]?)([零〇○0Oo])(?年)", , , 1, , , , , , "\1〇\3", 2
.Execute "([二一]??)([零〇○0Oo])(年)", , , 1, , , , , , "\1〇\3", 2
.Execute "?([0-9０-９]{4})(?)([0-9０-９]@号)", , , 1, , , , , , "〔\1〕\3", 2
.Execute "(^13联)(系)(人：*^13?[一-﨩][一-﨩][一-﨩]：)", , , 1, , , , , , "\1 \2 \3", 2

.Execute "[：:] ", , , , , , , , , "：", 2
.Execute "）^9", , , , , , , , , "）", 2
.Execute " (“)", , , 1, , , , , , "\1", 2
.Execute "(”) ", , , 1, , , , , , "\1", 2
.Execute "(》)(《)", , , 1, , , , , , "\1、\2", 2
.Execute "(。)(（*）)(^13)", , , 1, , , , , , "\2\1\3", 2
End With
End With

Full2Half
Half2Full

Title1

Title2345
Selection.HomeKey Unit:=wdStory
Title2345AutoNum

称呼
落款
附件
印发
第一

插入页码_公文一字线
Selection.Sections(1).Footers(1).PageNumbers.Add PageNumberAlignment:=wdAlignPageNumberCenter, FirstPage:=False
删除页眉横线
插入页码

TitleCancel
CutLine
TableTitle
With doc
If .Paragraphs(2).Range Like "*）?" Then .Paragraphs(2).Range.InsertBefore Text:=" "
End With
TitleExtend

最后一磅
显示页数
FJTitle
CutPage

Selection.HomeKey Unit:=wdStory
End Sub
Sub PaperSetup()
Dim s As Section
For Each s In ActiveDocument.Sections
With s.PageSetup
If .Orientation = wdOrientPortrait Then
.TopMargin = CentimetersToPoints(2.54)
.BottomMargin = CentimetersToPoints(2.54)
.LeftMargin = CentimetersToPoints(3.17)
.RightMargin = CentimetersToPoints(3.17)
.PageWidth = CentimetersToPoints(21)
.PageHeight = CentimetersToPoints(29.7)
Else
.TopMargin = CentimetersToPoints(2.5)
.BottomMargin = CentimetersToPoints(2.5)
.LeftMargin = CentimetersToPoints(2.54)
.RightMargin = CentimetersToPoints(2.54)
.PageWidth = CentimetersToPoints(29.7)
.PageHeight = CentimetersToPoints(21)
End If
.HeaderDistance = CentimetersToPoints(1.5)
.FooterDistance = CentimetersToPoints(1.75)
End With
Next
End Sub
Sub 正文样式()
Dim i As Paragraph, r As Range
With Selection
.ClearFormatting
CommandBars.FindControl(ID:=122).Execute
CommandBars.FindControl(ID:=123).Execute
With .Font
.Name = "仿宋"
.Size = 16
.Color = wdColorBlue
.Kerning = 0
.DisableCharacterSpaceGrid = True
End With
With .ParagraphFormat
.LineSpacing = LinesToPoints(1.5)
.CharacterUnitFirstLineIndent = 2
.AutoAdjustRightIndent = False
.DisableLineHeightGrid = True
End With
Set r = .Range
For Each i In r.Paragraphs
If Asc(i.Range) = 13 Then i.Range.Delete
Next
End With
End Sub
Sub Full2Half()
Dim i As Paragraph, mt, r As Range, n%, m%
With CreateObject("vbscript.regexp")
.Pattern = "[Ａ-Ｚａ-ｚ０-９“”]"
.Global = True
.IgnoreCase = False
.MultiLine = True
For Each i In ActiveDocument.Paragraphs
For Each mt In .Execute(i.Range.Text)
m = mt.FirstIndex: n = mt.Length
With ActiveDocument.Range(i.Range.Start + m, i.Range.Start + m + n)
If .Text Like "[“”]" Then .CharacterWidth = wdWidthFullWidth Else .CharacterWidth = wdWidthHalfWidth
End With
Next
Next
End With
End Sub
Sub Half2Full()
Dim d, x, y, k, t, i%, j%
x = Array(".", ",", ";", ":", "!", "?")
y = Array("。", "，", "；", "：", "！", "？")
Set d = CreateObject("Scripting.Dictionary")
For i = 0 To UBound(x)
d(x(i)) = y(i)
Next
k = d.keys: t = d.items
With ActiveDocument.Content.Find
For j = 0 To d.Count - 1
.Execute "([一-﨩^13^11])\" & k(j) & "([0-9一-﨩^13^11])", , , 1, , , , , , "\1" & t(j) & "\2", 2
Next
End With
End Sub
Sub Title1()
Dim doc As Document, r As Range
Set doc = ActiveDocument
With doc
If Not .Paragraphs(1).Range.Information(12) Then Set r = .Paragraphs(1).Range Else Set r = .Tables(1).Range.Next(4, 1)
End With
With r
If .Text Like "*[。：；，、！？…—.:;,!?]?" Or .Text Like "[一1][、.．]*" Then Exit Sub
If .End <> doc.Content.End Then
If Not (.Next.Information(12) Or .Next(4, 1) Like "*[。：；，、！？…—.:;,!?]?" Or .Next(4, 1) Like "[一1][、.．]*" Or .Next(4, 1) Like "（[一1]）*") Then .MoveEnd 4, 1
End If
If .End <> doc.Content.End Then
If Not (.Next.Information(12) Or .Next(4, 1) Like "*[。：；，、！？…—.:;,!?]?" Or .Next(4, 1) Like "[一1][、.．]*" Or .Next(4, 1) Like "（[一1]）*") Then .MoveEnd 4, 1
End If
If .End <> doc.Content.End Then
.Characters.Last.InsertParagraphBefore
End If
.InsertParagraphBefore
.Style = wdStyleHeading1
.Borders(wdBorderBottom).LineStyle = wdLineStyleNone
With .Font
.NameAscii = "Times New Roman"
.Size = 22
.Color = wdColorAutomatic
End With
With .ParagraphFormat
.SpaceBeforeAuto = False
.SpaceAfterAuto = False
.SpaceBefore = 0
.SpaceAfter = 0
.LineSpacing = LinesToPoints(1.15)
.Alignment = wdAlignParagraphCenter
.AutoAdjustRightIndent = False
.DisableLineHeightGrid = True
End With
With .Paragraphs
.First.Range.Font.Size = 21
.Last.Range.Font.Size = 26
End With
End With
End Sub
Sub Title2345()
Dim doc As Document, i&, s$
Set doc = ActiveDocument
For i = 1 To 4
If i = 1 Then
s = "^13[一二三四五六七八九十百零〇○Oo千]@、*^13"
ElseIf i = 2 Then
s = "^13（[一二三四五六七八九十百零〇○Oo千]@）*^13"
ElseIf i = 3 Then
s = "^13[0-9]@．*^13"
ElseIf i = 4 Then
s = "^13（[0-9]@）*^13"
End If
With Selection
.HomeKey Unit:=wdStory
With .Find
.ClearFormatting
.Text = s
.Forward = True
.MatchWildcards = True
.Replacement.Text = ""
Do While .Execute
With .Parent
.MoveStart
If Not .Information(12) Then
If .Paragraphs.Count = 1 Then
If i = 1 Then
.Style = wdStyleHeading2
.Font.Color = wdColorRed
ElseIf i = 2 Then
.Style = wdStyleHeading3
.Font.NameFarEast = "楷体"
.Font.Color = wdColorPink
ElseIf i = 3 Then
.Style = wdStyleHeading4
With .Font
.Name = "仿宋"
.Size = 16
.Color = wdColorGreen
End With
ElseIf i = 4 Then
.Style = wdStyleHeading5
With .Font
.Name = "仿宋"
.Size = 16
.Color = wdColorOrange
End With
End If
If .Sentences(1) Like "*：??*" Then
.MoveStart 1, InStr(.Text, "：")
With .Font
.Name = "仿宋"
.Bold = False
.Color = wdColorBlue
End With
If .Paragraphs(1).Range.Style Like "标题*" & "[23]" Then
If .Text Like "*[。：；，、！？…—.:;,!?]?" Then
.Characters.Last.Previous.Delete
End If
ElseIf .Paragraphs(1).Range.Style Like "标题*" & "[45]" Then
If .Text Like "*[!。：；，、！？…—.:;,!?]?" Then
If .Text Like "*[!0-9a-zA-Z]?" Then
.Characters.Last.InsertBefore Text:="。"
End If
End If
End If
Else
If .Sentences.Count = 1 Then
If .Text Like "*[。：；，、！？…—.:;,!?]?" Then .Characters.Last.Previous.Delete
Else
With doc.Range(Start:=.Sentences(1).End, End:=.Paragraphs(1).Range.End).Font
.Name = "仿宋"
.Bold = False
.Color = wdColorBlue
End With
End If
End If
With .ParagraphFormat
.SpaceBeforeAuto = False
.SpaceAfterAuto = False
.SpaceBefore = 0
.SpaceAfter = 0
.LineSpacing = LinesToPoints(1.5)
.CharacterUnitFirstLineIndent = 2
.AutoAdjustRightIndent = False
.DisableLineHeightGrid = True
.KeepWithNext = False
.KeepTogether = False
End With
If .Style = "标题 2" Then
With .ParagraphFormat
.SpaceBefore = 3
.SpaceAfter = 3
End With
End If
End If
Else
.Tables(1).Range.Next.Select
End If
.EndKey Unit:=wdLine
End With
Loop
End With
End With
Next i
End Sub
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
.Delete
.Fields.Add Range:=i.Range, Text:="= " & b & " \* CHINESENUM3"
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
.Delete
.Fields.Add Range:=i.Range, Text:="= " & c & " \* CHINESENUM3"
.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
doc.Fields.Unlink
End Sub
Sub TitleCancel()
On Error Resume Next
Dim i As Paragraph, j&, k&, x&
For x = 2 To 5
For Each i In ActiveDocument.Paragraphs
With i.Range
If .Style = "标题 " & x Then
If j = 0 Then
If .Next(4, 1).Style = "标题 " & x And .Sentences.Count = 1 And Not .Text Like "*：*" Then k = 1
j = 1
End If
If k = 1 Then .Select: 正文样式: If .Text Like "*[!。：；，、！？…—.:;,!?]?" And .Text Like "*[!0-9]?" Then .Characters.Last.InsertBefore Text:="。"
ElseIf Right(.Style, 1) < x Then
j = 0
k = 0
End If
End With
Next
j = 0
k = 0
Next x
End Sub
Sub TitleExtend()
With Selection
.HomeKey 6
With .Find
.ClearFormatting
.Execute "^p^p", , , 0, , , 1
If .Found = True Then
With .Parent
.MoveEnd 1, -1
If .Paragraphs(1).Range.ComputeStatistics(statistic:=wdStatisticLines) = 1 Then
.MoveStart 5, -1
With .Find
.Execute "^w", , , , , , , , , "", 2
.Execute "　", , , , , , , , , "", 2
End With
If .Text Like "（*）?" Then
With .Font
.Size = 18
.NameFarEast = "楷体"
End With
.ParagraphFormat.SpaceBefore = 6
If Len(.Text) = 6 Then
.Characters(2).InsertAfter Text:=" "
.Characters(4).InsertAfter Text:=" "
End If
Else
TitleSpacing
End If
End If
End With
End If
End With
End With
End Sub
Sub TitleSpacing()
Dim i&
i = Len(Selection)
With Selection
If i = 3 Then
.Characters(1).InsertAfter Text:=" "
ElseIf i = 4 Then
.Characters(1).InsertAfter Text:=" "
.Characters(5).InsertAfter Text:=" "
ElseIf i = 5 Or i = 6 Then
.Characters(1).InsertAfter Text:=" "
.Characters(4).InsertAfter Text:=" "
.Characters(7).InsertAfter Text:=" "
If i = 6 Then .Characters(10).InsertAfter Text:=" "
ElseIf i = 7 Or i = 8 Then
.Characters(1).InsertAfter Text:=" "
.Characters(3).InsertAfter Text:=" "
.Characters(5).InsertAfter Text:=" "
.Characters(7).InsertAfter Text:=" "
.Characters(9).InsertAfter Text:=" "
If i = 8 Then .Characters(11).InsertAfter Text:=" "
End If
End With
End Sub
Sub CutLine()
Dim r As Range, i&, j&
With Selection
.HomeKey 6
With .Find
.ClearFormatting
.Text = "^p"
.Forward = True
.MatchWildcards = False
Do While .Execute
With .Parent
If .Style <> "标题 1" Then
If Not .Information(12) Then
If .Paragraphs(1).Range.ComputeStatistics(statistic:=1) > 1 Then
.MoveStart 5, -1
If .Text Like "?[。：；，、！？…—.:;,!?]?" Or .Text Like "??" Then
.Expand 4
Set r = .Range
i = r.ComputeStatistics(statistic:=1)
Do While .Text Like "[!一-﨩]*"
.MoveStart
Loop
With .Font
Do
j = j + 1
If j = 3 Then Exit Do
.Spacing = -0.4
Loop Until r.ComputeStatistics(statistic:=1) = i - 1
End With
End If
.Collapse 0
If .End = ActiveDocument.Content.End - 1 Then Exit Sub
End If
End If
End If
End With
Loop
End With
End With
End Sub
Sub TableTitle()
With ActiveDocument
If Not .Paragraphs(1).Range.Information(12) And Len(.Paragraphs(1).Range) = 1 Then
If Not .Paragraphs(3).Range.Information(12) And Len(.Paragraphs(3).Range) = 1 Then
If .Paragraphs(4).Range.Information(12) Then
Else
If .Paragraphs(5).Range.Information(12) Then
With .Paragraphs(4).Range
With .Font
.NameFarEast = "宋体"
.NameAscii = "Times New Roman"
.Size = 12
End With
With .ParagraphFormat
.CharacterUnitFirstLineIndent = 0
.FirstLineIndent = 0
.Space1
End With
End With
Else
Exit Sub
End If
End If
.Paragraphs(1).Range.Delete
With .Paragraphs(1).Range
If .ComputeStatistics(1) = 1 Then
.Parent.Paragraphs(2).Range.Font.Size = 12
Else
.Parent.Paragraphs(2).Range.Font.Size = 16
End If
End With
End If
End If
End With
End Sub
Sub 称呼()
With Selection.Find
.ClearFormatting
.Execute "^13^13*：^13", , , 1, , , 1
If .Found = True Then
With .Parent
.MoveStart 1, 2
If .Range.ComputeStatistics(1) < 3 Then
With .ParagraphFormat
.CharacterUnitFirstLineIndent = 0
.FirstLineIndent = CentimetersToPoints(0)
End With
End If
End With
End If
End With
End Sub
Sub 落款()
Dim r As Range
With Selection
.HomeKey 6
With .Find
.ClearFormatting
.Text = "^13[0-9]{4}年[0-9]{1,2}月[0-9]{1,2}日^13"
.Forward = True
.MatchWildcards = True
Do While .Execute
With .Parent
.MoveStart
If .Style = "标题 1" Then
.EndKey 5
Else
.Font.Color = wdColorPink
With .ParagraphFormat
.Alignment = wdAlignParagraphRight
.CharacterUnitRightIndent = 5.9
End With
Set r = .Previous(4, 1)
With r
If r Like "*[!。：；，、！？…—.:;,!?]?" Then
.Font.Color = wdColorRed
.InsertBefore Text:=vbCr & vbCr & vbCr
.SetRange Start:=.Paragraphs.Last.Range.Start, End:=.Paragraphs.Last.Range.End
With .ParagraphFormat
If Len(r) = 10 Then
.CharacterUnitFirstLineIndent = 13.55
Else
.CharacterUnitFirstLineIndent = 11
End If
End With
Else
.InsertAfter Text:=vbCr
Selection.MoveStart
End If
End With
Exit Sub
End If
End With
Loop
End With
End With
End Sub
Sub 附件()
Dim s As Range, r As Range, i As Paragraph, k&, n&, t$
With Selection
If .Type = wdSelectionIP Then Exit Sub Else Set s = .Range
.EndKey 5
With .Find
.ClearFormatting
.Text = "[^13^12]附件*^13"
.Forward = True
.MatchWildcards = True
Do While .Execute
With .Parent
If Asc(.Text) = 13 Then
.Characters(1).InsertAfter Text:=Chr(12)
.MoveStart 1, 2
Else
.MoveStart
End If
.MoveEnd 1, -1
If .Previous.Previous.Previous.Information(12) Then .Previous.Previous.Delete
n = n + 1
.Text = "附件" & n
With .Font
.NameFarEast = "黑体"
.NameAscii = "Times New Roman"
.Bold = True
.Color = wdColorRed
End With
With .ParagraphFormat
.CharacterUnitFirstLineIndent = 0
.FirstLineIndent = CentimetersToPoints(0)
.Space1
End With
.Next(4, 1).Select
If Not (.Next.Information(12) Or .Next(4, 1) Like "*[。：；，、！？…—.:;,!?_ 　^s^t（）]*" Or .Next(4, 1) Like "[一1][、.．]*" Or .Next(4, 1) Like "（[一1]）*") Then
.MoveEnd 4, 1
.Paragraphs(1).Range.Characters.Last.Delete
End If
t = t & n & "．" & .Text
.Style = wdStyleSubtitle
With .Font
.NameAscii = "Times New Roman"
.Size = 20
.Color = wdColorAutomatic
End With
With .ParagraphFormat
.SpaceBefore = 0
.SpaceAfter = 0
.LineSpacing = LinesToPoints(1.15)
.AutoAdjustRightIndent = False
.DisableLineHeightGrid = True
End With
If .Text Like "*）?" And .Range.ComputeStatistics(statistic:=1) Then .InsertBefore Text:=" "
.InsertParagraphBefore
.Characters.Last.InsertBefore Text:=vbCr
.EndKey 5
k = 1
End With
Loop
End With
If k = 0 Then Exit Sub
If n = 1 Then .Previous(4, 1).Previous(4, 1).Previous(4, 1).Characters.Last.Previous.Delete: t = Right(t, Len(t) - 2)
'''
s.Select
.HomeKey 6, 1
With .Find
.ClearFormatting
.Execute "^13附件", , , 1, , , 1
If .Found = True Then
With .Parent
.MoveStart
Do
.MoveDown 4, 1, 1
Loop Until .Text Like "*" & vbCr & vbCr
.MoveEnd 1, -1
.Text = vbCr & "附件：" & t
.MoveStart
End With
Else
s.Previous(4, 1).Previous.Previous.Previous.Select
With .Parent
.Text = vbCr & "附件：" & t & vbCr
.MoveStart
.MoveEnd 1, -1
End With
End If
End With
Set r = .Range
r.Font.Color = wdColorViolet
If n = 1 Then
With .ParagraphFormat
.CharacterUnitLeftIndent = 3.05
If .Parent.Text Like "附件：20##*" Then
.CharacterUnitFirstLineIndent = -2.99
Else
.CharacterUnitFirstLineIndent = -3.03
End If
End With
If .Range.ComputeStatistics(statistic:=1) > 1 Then
.Characters.Last.Select
.MoveStart 5, -1
If Len(.Text) = 2 Then
.MoveStart 5, -1
If .Text Like "附件：*" Then .MoveStart 1, 4 Else .MoveStart
.Font.Spacing = -0.4
End If
End If
Else
With .Paragraphs(1).Range.ParagraphFormat
.CharacterUnitLeftIndent = 3.05
If .Parent Like "*20##*" Then .CharacterUnitFirstLineIndent = -4.53 Else .CharacterUnitFirstLineIndent = -4.65
End With
r.MoveStart 4, 1
For Each i In r.Paragraphs
With i.Range
With .ParagraphFormat
If .Parent Like "*20##*" Then
.CharacterUnitLeftIndent = 7.6
.CharacterUnitFirstLineIndent = -1.5
Else
.CharacterUnitLeftIndent = 7.65
.CharacterUnitFirstLineIndent = -1.56
End If
End With
If .ComputeStatistics(statistic:=1) > 1 Then
.Characters.Last.Select
With Selection
.MoveStart 5, -1
If Len(.Text) = 2 Then
.MoveStart 5, -1
If .Text Like "#．*" Then .MoveStart 1, 3 Else .MoveStart
.Font.Spacing = -0.4
End If
End With
End If
End With
Next
End If
End With
End Sub
Sub 缩成一行()
With Selection
.Expand 4
If .Information(12) Then .MoveEnd 1, -1
With .Font
If .Spacing = "9999999" Then .Spacing = 0
If .Scaling = "9999999" Then .Scaling = 100
.Spacing = -0.5
Do Until .Parent.Range.ComputeStatistics(statistic:=wdStatisticLines) = 1
.Scaling = .Scaling - 2
Loop
End With
End With
End Sub
Sub 印发()
Dim i&, r As Range
With Selection
.HomeKey 6
With .Find
.ClearFormatting
.Text = "[0-9]{4}年[0-9]{1,2}月[0-9]{1,2}日印发"
.Forward = True
.MatchWildcards = True
Do While .Execute
With .Parent
If .Information(12) Then .Tables(1).Rows.ConvertToText Separator:=wdSeparateByParagraphs, NestedTables:=True
.Expand 4
.Text = Replace(.Text, " ", "")
.Text = Replace(.Text, "　", "")
.Text = Replace(.Text, vbTab, "")
.Text = Replace(.Text, ChrW(160), "")
If .Text Like "*日印发" & vbCr Then Exit Do Else .Collapse 0
End With
Loop
If .Found = False Then Exit Sub
End With
.Characters(InStr(.Text, "2")).InsertBefore Text:=" "
If .Previous(4, 1) Like "*[!。]?" Then .Previous(4, 1).Characters.Last.InsertBefore Text:="。"
If .Previous(4, 1).Text Like "抄送：*" Then .MoveStart 4, -1
.InsertBefore Text:=vbCr & vbCr & vbCr
.MoveStart 1, 3
.ConvertToTable Separator:=wdSeparateByParagraphs, NumColumns:=1, AutoFitBehavior:=wdAutoFitFixed
With .Font
.Size = 14
.Kerning = 0
.DisableCharacterSpaceGrid = True
End With
With .ParagraphFormat
.Space1
.CharacterUnitLeftIndent = 1
.CharacterUnitRightIndent = 1
.CharacterUnitFirstLineIndent = -3.05
.LineUnitBefore = 0.2
.LineUnitAfter = 0.2
.AutoAdjustRightIndent = False
.DisableLineHeightGrid = True
End With
With .Tables(1)
.PreferredWidthType = wdPreferredWidthPoints
.PreferredWidth = CentimetersToPoints(14.7)
.Rows.Alignment = wdAlignRowCenter
.Range.Font.Color = wdColorBlue
End With
If .Cells.Count = 2 Then
Options.DefaultBorderLineWidth = wdLineWidth100pt
.Borders(wdBorderTop).LineStyle = Options.DefaultBorderLineStyle
.Borders(wdBorderBottom).LineStyle = Options.DefaultBorderLineStyle
.Tables(1).Range.Cells(2).Select
Options.DefaultBorderLineWidth = wdLineWidth025pt
.Borders(wdBorderTop).LineStyle = Options.DefaultBorderLineStyle
ElseIf .Cells.Count = 1 Then
Options.DefaultBorderLineWidth = wdLineWidth100pt
.Borders(wdBorderTop).LineStyle = Options.DefaultBorderLineStyle
.Borders(wdBorderBottom).LineStyle = Options.DefaultBorderLineStyle
End If
ActiveWindow.View.TableGridlines = False
.Paragraphs(1).Range.Select
.MoveEnd 1, -1
i = InStr(.Text, " ")
Do
.Characters(i).InsertAfter Text:=" "
Loop Until .Range.ComputeStatistics(statistic:=wdStatisticLines) = 2
Do
.Characters(i).Delete
Loop Until .Range.ComputeStatistics(statistic:=wdStatisticLines) = 1
End With
End Sub
Sub 第一()
With Selection
.HomeKey 6
With .Find
.ClearFormatting
.Text = "^13第[一二三四五六七八九十][!一-﨩][一-﨩]*。"
.Forward = True
.MatchWildcards = True
Do While .Execute
With .Parent
If Not .Information(12) Then
.MoveStart
.Font.Bold = True
.Font.Color = wdColorBrown
.Characters(3).Text = "，"
.Collapse 0
End If
End With
Loop
End With
End With
End Sub
Sub 插入页码_公文一字线()
Dim s As Section
For Each s In ActiveDocument.Sections
s.Footers(1).Range.Delete
With s.Footers(1).Range.Sections(1).Headers(1).PageNumbers
.NumberStyle = wdPageNumberStyleArabic
.HeadingLevelForChapter = 0
.IncludeChapterNumber = False
.ChapterPageSeparator = wdSeparatorHyphen
.RestartNumberingAtSection = False
.StartingNumber = 0
End With
s.Footers(1).PageNumbers.Add 2, True
With s.Footers(1).Range.Frames(1).Range
.Select
With Selection
.TypeText Text:=Chr(-24159)
.InsertSymbol Font:="宋体", CharacterNumber:=8212, Unicode:=True
.TypeText Text:=" "
.EndKey 5
.TypeText Text:=" "
.InsertSymbol Font:="宋体", CharacterNumber:=8212, Unicode:=True
.TypeText Text:=Chr(-24159)
.Expand 4
With .Font
.Name = "宋体"
.Size = 14
End With
.ParagraphFormat.CharacterUnitRightIndent = 1.5
End With
End With
Next
ActiveWindow.ActivePane.Close
ActiveWindow.View.Type = wdPrintView
End Sub
Sub 删除页眉横线()
ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
Selection.ParagraphFormat.Borders(wdBorderBottom).LineStyle = wdLineStyleNone
ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
End Sub
Sub 插入页码()
With ActiveDocument
If .Sections.Count = 1 Then
If .Content.Information(wdNumberOfPagesInDocument) > 2 And .Sections(1).Footers(wdHeaderFooterPrimary).Range.Text = vbCr Then
.Sections(1).Footers(1).PageNumbers.Add PageNumberAlignment:=wdAlignPageNumberRight, FirstPage:=True
ElseIf .Content.Information(wdNumberOfPagesInDocument) <= 2 And .Sections(1).Footers(wdHeaderFooterPrimary).Range.Text <> vbCr Then
.StoryRanges(wdPrimaryFooterStory).Frames(1).Cut
End If
End If
End With
End Sub
Sub 最后一磅()
With ActiveDocument.Paragraphs.Last.Range
If Len(.Text) > 1 Then Exit Sub
.Font.Size = 1
.ParagraphFormat.LineSpacing = LinesToPoints(0.06)
.Select
End With
取消网格
End Sub
Sub 显示页数()
Dim i&
i = ActiveDocument.Content.Information(wdNumberOfPagesInDocument)
With ActiveWindow.ActivePane.View.Zoom
If i <= 6 Then
.PageColumns = i: .PageRows = 1
ElseIf i = 7 Or i = 9 Or i = 11 Or i = 13 Or i = 15 Then
.PageColumns = (i + 1) / 2: .PageRows = 2
ElseIf i = 8 Or i = 10 Or i = 12 Or i = 14 Or i = 16 Then
.PageColumns = i / 2: .PageRows = 2
ElseIf i >= 17 Then
.PageColumns = 15
End If
End With
End Sub
Sub FJTitle()
With Selection
.HomeKey 6
With .Find
.ClearFormatting
.Text = "^12附件*^12附件"
.Forward = True
.MatchWildcards = True
Do While .Execute
With .Parent
.MoveStart
.MoveEnd 1, -2
FJRange
.HomeKey 5
End With
Loop
.ClearFormatting
.Execute "^12附件", , , 1, , , 1
If .Found = True Then
With .Parent
.MoveStart
.EndKey 6, 1
FJRange
End With
End If
End With
End With
End Sub
Sub FJRange()
Dim doc As Document, r As Range, x&, y&
Set doc = ActiveDocument
Set r = Selection.Range
With r
If .Tables.Count > 0 Then
If .Paragraphs(6).Range.Information(12) And Not .Paragraphs(5).Range.Information(12) Then
.Paragraphs(5).Range.Select: FJText
ElseIf .Paragraphs(7).Range.Information(12) And Not .Paragraphs(6).Range.Information(12) Then
.Paragraphs(5).Range.Select: Selection.MoveEnd 4, 1: FJText
End If
.Tables(1).Range.Next(4, 1).Select
With Selection
If Asc(.Text) = 12 Or .End = doc.Content.End Then GoTo sf
.ParagraphFormat.Space1
If Not .End = doc.Content.End Then
If Not Asc(.Next) = 12 Then .MoveEnd 4, 1
End If
If Not .End = doc.Content.End Then
If Not Asc(.Next) = 12 Then .MoveEnd 4, 1
End If
If Not .End = doc.Content.End Then
If Not Asc(.Next) = 12 Then .MoveEnd 4, 1
End If
If Not .End = doc.Content.End Then
If Not (Asc(.Next) = 12) Then GoTo sf
End If
.MoveStart
FJText
End With
sf:
x = .Characters.First.Information(3)
y = .Characters.Last.Information(3)
If x < y Then
Do
.Paragraphs(3).Range.Select
缩减一行
With Selection
If .Previous.Font.Size = 1 Then Exit Do
.Previous.Font.Size = .Previous.Font.Size - 1
.Next.Font.Size = .Next.Font.Size - 1
End With
Loop Until .Characters.Last.Information(3) = x
End If
End If
End With
End Sub
Sub FJText()
With Selection
With .Font
.NameFarEast = "宋体"
.NameAscii = "Times New Roman"
.Size = 12
End With
With .ParagraphFormat
.CharacterUnitFirstLineIndent = 0
.FirstLineIndent = 0
.Space1
End With
End With
End Sub
Sub CutPage()
Dim s As Range, p&
With Selection
.HomeKey 6
With .Find
.ClearFormatting
.Execute "^12附件", , , 1, , , 1
If .Found = True Then .Parent.Characters(1).Select Else ActiveDocument.Characters.Last.Select
End With
Set s = .Range
p = s.Information(3)
If p >= 3 And p Mod 2 = 1 Then
.GoTo What:=wdGoToPage, Which:=wdGoToNext, Name:=p
ActiveDocument.Range(Start:=.Start, End:=s.End).Select
If .Range.ComputeStatistics(statistic:=1) < 12 Then
.HomeKey 6
减少一页
End If
End If
End With
End Sub
Sub 普通()
Dim t!, x&, y&, s!
x = ActiveDocument.BuiltInDocumentProperties(wdPropertyWords)
t = Timer
外核
s = Round(Timer - t, 2)
y = ActiveDocument.BuiltInDocumentProperties(wdPropertyWords)
显示页数
ActiveWindow.DocumentMapPercentWidth = 20
MsgBox "排版完毕！用时 " & s & " 秒！共 " & Selection.Information(wdNumberOfPagesInDocument) & " 页！ " & vbCr & vbCr & "排版前字数 = " & x & vbCr & "排版后字数 = " & y, 0 + 48
ActiveWindow.ActivePane.View.Zoom.PageFit = wdPageFitBestFit
End Sub
Sub 外核()
核心
Dim i As Paragraph, t As Table
For Each i In ActiveDocument.Paragraphs
With i.Range
If Not .Information(12) Then
If .Style = "标题 2" Then
.ParagraphFormat.CharacterUnitFirstLineIndent = 1.75
ElseIf .Style = "标题 3" Then
If .Sentences.Count = 1 Then
.ParagraphFormat.CharacterUnitFirstLineIndent = 1.74
Else
.ParagraphFormat.CharacterUnitFirstLineIndent = 1.75
End If
ElseIf .Style Like "标题 " & "[45]" Or .Style = "正文" Then
With .Font
.NameFarEast = "宋体"
.NameAscii = "Times New Roman"
.Size = 14
End With
End If
If .Style = "标题 4" Then .ParagraphFormat.CharacterUnitFirstLineIndent = 1.99
If .Style Like "标题 [23]" Then
If .Sentences.Count > 1 Then
With ActiveDocument.Range(Start:=.Sentences(1).End, End:=.Paragraphs(1).Range.End).Font
.NameFarEast = "宋体"
.NameAscii = "Times New Roman"
End With
End If
End If
If .Style <> "标题 1" Then .ParagraphFormat.LineSpacing = LinesToPoints(1.25)
End If
End With
Next
For Each t In ActiveDocument.Tables
t.Range.Next.Font.Size = 4
Next
切换页码
With Selection.Sections(1).Headers(1).PageNumbers
.NumberStyle = wdPageNumberStyleNumberInDash
.HeadingLevelForChapter = 0
.IncludeChapterNumber = False
.ChapterPageSeparator = wdSeparatorHyphen
.RestartNumberingAtSection = False
.StartingNumber = 0
End With
Selection.Sections(1).Footers(1).PageNumbers.Add PageNumberAlignment:=wdAlignPageNumberCenter, FirstPage:=False
插入页码
With Selection
.HomeKey 6
With .Find
.ClearFormatting
.Execute "^13^13^13^13*^13", , , 1, , , 1
If .Found = True Then
With .Parent
.MoveStart 1, 4
With .ParagraphFormat
If Len(.Parent) = 10 Then
.CharacterUnitFirstLineIndent = 16.65
Else
.CharacterUnitFirstLineIndent = 14
End If
End With
End With
End If
End With
最后一磅
显示页数
.HomeKey 6
End With
End Sub
Sub 切换页码()
If ActiveDocument.Sections(1).Footers(wdHeaderFooterPrimary).Range.Text = vbCr Then
Selection.Sections(1).Footers(1).PageNumbers.Add PageNumberAlignment:=wdAlignPageNumberRight, FirstPage:=True
ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
Selection.ParagraphFormat.Borders(wdBorderBottom).LineStyle = wdLineStyleNone
ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
Else
ActiveDocument.StoryRanges(wdPrimaryFooterStory).Frames(1).Cut
End If
End Sub
Sub 另存为()
Dim i$
ActiveWindow.ActivePane.View.Zoom.PageFit = wdPageFitBestFit
With ActiveDocument
i = .FullName
If i Like "*:*" Then
If .Saved = False Then .SaveAs FileName:=i, FileFormat:=wdFormatDocument
Else
.Save
End If
End With
End Sub
Sub 关闭不保存()
ActiveDocument.Close savechanges:=wdDoNotSaveChanges
End Sub
Sub 重新打开()
Dim i$
With ActiveDocument
i = .FullName
If i Like "*:*" Then
If .Saved = False Then
.Close savechanges:=wdDoNotSaveChanges
Documents.Open FileName:=i
End If
End If
End With
End Sub
Sub 打印关闭不保存()
With ActiveDocument
.PrintOut
.Close savechanges:=wdDoNotSaveChanges
End With
End Sub
Sub 打印N份关闭不保存()
Dim i$
i = InputBox("", "请输入打印份数！", "3")
If i = "" Then End
With ActiveDocument
.PrintOut Copies:=i
.Close savechanges:=wdDoNotSaveChanges
End With
End Sub
Sub 打印当前页()
Application.PrintOut FileName:="", Range:=wdPrintCurrentPage
End Sub
Sub 表格处理()
Dim t As Table, c As Cell, a&, e&, i As Paragraph, j&, k&, x&, y&, z&
If Selection.Information(12) Then a = 1
For Each t In ActiveDocument.Tables
If a = 1 Then Set t = Selection.Tables(1)
With t
'取消环绕
With .Rows
.WrapAroundText = False
.Alignment = wdAlignRowLeft
.LeftIndent = CentimetersToPoints(0)
End With

'判断表格是否规则(e=1=规则/e=0=不规则)
With .Range
With .Find
.Execute "^13", , , , , , , , , "^p", 2
.Execute "^11", , , , , , , , , "^p", 2
End With
x = .Information(wdEndOfRangeRowNumber)
y = .Information(wdEndOfRangeColumnNumber)
z = .Cells.Count
End With
If x <> 1 Then
If z = x * y Then
For k = 1 To y
For j = 1 To x - 1
If .Cell(j + 1, k).Width = .Cell(j, k).Width Then e = 1 Else e = 0
If e = 0 Then Exit For
Next j
If e = 0 Then Exit For
Next k
Else
e = 0
End If
Else
e = 1
End If

'清除空格
If Asc(.Range.Next) <> 13 Then .Range.Next.InsertBefore Text:=vbCr
.Select
Selection.MoveEnd
CommandBars.FindControl(ID:=122).Execute
Selection.Characters.Last.ParagraphFormat.Alignment = wdAlignParagraphJustify
.Select

'清除格式
Selection.ClearFormatting
With .Range
With .Font
.NameAscii = "Times New Roman"
.Size = 12
.Color = wdColorBlue
.Kerning = 0
.DisableCharacterSpaceGrid = True
End With
With .ParagraphFormat
.Alignment = wdAlignParagraphCenter
.AutoAdjustRightIndent = False
.DisableLineHeightGrid = True
End With
.Cells.VerticalAlignment = wdCellAlignVerticalCenter
End With

.LeftPadding = CentimetersToPoints(0.19)
.RightPadding = CentimetersToPoints(0.19)

.AutoFitBehavior (wdAutoFitContent)
.Select
.AutoFitBehavior (wdAutoFitWindow)

If e = 1 Then
'行高最小值
With .Rows
.HeightRule = wdRowHeightAtLeast
.Height = CentimetersToPoints(0.9)
End With
'表头加粗
If Len(.Cell(2, 2).Range) > 2 Then
With .Rows(1).Range.Font
.NameFarEast = "黑体"
.Bold = True
.Color = wdColorRed
End With
End If
End If

'删除单元格空段
For Each c In .Range.Cells
For Each i In c.Range.Paragraphs
If Asc(i.Range) = 13 And Len(i.Range) = 1 Then i.Range.Delete
Next
With c.Range.Paragraphs
If .Count > 1 And Len(.Last.Range) = 2 Then .Last.Previous.Range.Characters.Last.Delete
End With
Next
End With
If a = 1 Then Exit For
Next
行高热键
End Sub
Sub 取消标题()
ActiveDocument.Content.InsertParagraphAfter
Dim i$, j$, k&, r As Range, s&, t As Range
With Selection
If .Type = wdSelectionIP Then
i = .Style
If Not i Like "标题*" Then MsgBox "无标题！", 0 + 16: End
j = MsgBox("<是>：全文 <否>：光标后 <取消>：光标前", 3 + 48, "取消标题")
If j = 6 Then
.WholeStory
ElseIf j = 7 Then
.Expand 4
.EndKey 6, 1
Else
.HomeKey 6, 1
If Asc(.Characters.Last) <> 13 Then .Expand 4
End If
Else
.Expand 4
k = 1
End If
Set r = .Range
Set t = .Range
.HomeKey 6
With .Find
.ClearFormatting
.Style = "正文"
.Text = ""
.Format = True
.Forward = True
.MatchWildcards = False
Do While .Execute
With .Parent
If .Information(12) Then
.Tables(1).Range.Next.Select
If Len(.Text) = 1 Then .Next.Select
.HomeKey 5
Else
s = .Font.Size
Exit Do
End If
End With
Loop
End With
If Not (s = 16 Or s = 14) Then s = 16
End With
If k = 1 Then GoTo ks
With r.Find
.ClearFormatting
.Style = i
.Text = ""
.Format = True
.Forward = True
.MatchWildcards = False
Do While .Execute
ks:
r.Select
正文样式
If s = 14 Then
With r.Font
.NameFarEast = "宋体"
.NameAscii = "Times New Roman"
.Size = 14
End With
r.ParagraphFormat.LineSpacing = LinesToPoints(1.25)
End If
If k = 1 Then
r.Find.Execute "([!。：；，、！？…—.:;,\!\?])(^13)", , , 1, , , , , , "\1。\2", 2
If r Like "*" & vbCr & vbCr Then r.Characters.Last.Previous.Delete
GoTo de
End If
If r Like "*[!。：；，、！？…—.:;,!?]?" Then r.Characters.Last.InsertBefore Text:="。"
r.SetRange Start:=r.End, End:=t.End
If Len(r) < 2 Then GoTo de
If r.End <> ActiveDocument.Content.End Then
If r.Next(4, 1).Text = vbCr Then r.MoveEnd
End If
Loop
End With
de:
ActiveDocument.Characters.Last.Delete
End Sub
Sub 增加段前间距()
Selection.ParagraphFormat.SpaceBefore = 6
End Sub
Sub 减少首行缩进()
Selection.ParagraphFormat.CharacterUnitFirstLineIndent = Selection.ParagraphFormat.CharacterUnitFirstLineIndent - 0.05
End Sub
Sub 减少行距()
With Selection
If .Type = wdSelectionIP Then 选择正文
取消网格
With .Paragraphs
If .LineSpacing <= 0.96 Then End
If .LineSpacing = "9999999" Then .LineSpacing = LinesToPoints(1.25)
.LineSpacing = LinesToPoints(.LineSpacing / 12 - 0.02)
End With
End With
End Sub
Sub 增加行距()
With Selection
If .Type = wdSelectionIP Then 选择正文
取消网格
With .Paragraphs
If .LineSpacing = "9999999" Then .LineSpacing = LinesToPoints(1.25)
.LineSpacing = LinesToPoints(.LineSpacing / 12 + 0.02)
End With
End With
End Sub
Sub 选择正文()
With Selection
.HomeKey 6
With .Find
.ClearFormatting
.Execute "^12附件", , , 0, , , 1
If .Found = True Then .Parent.HomeKey 6, 1 Else .Parent.EndKey 6, 1
End With
Do Until Not (.Paragraphs(1).Range.Style = "标题 1" Or .Paragraphs(1).Range.Style = "副标题")
.MoveStart 4, 1
Loop
End With
End Sub
Sub 取消网格()
With Selection
If .Type = wdSelectionIP Then 选择正文
With .Font
.Kerning = 0
.DisableCharacterSpaceGrid = True
End With
With .ParagraphFormat
.AutoAdjustRightIndent = False
.DisableLineHeightGrid = True
End With
End With
End Sub
Sub 减少字符缩放()
With Selection
If .Type = wdSelectionIP Then .Expand 4
With .Font
If .Scaling <= 6 Then End
If .Scaling = "9999999" Then .Scaling = 100
.Scaling = .Scaling - 5
End With
End With
End Sub
Sub 增加字符缩放()
With Selection
If .Type = wdSelectionIP Then .Expand 4
With .Font
If .Scaling >= 600 Then End
If .Scaling = "9999999" Then .Scaling = 100
.Scaling = .Scaling + 5
End With
End With
End Sub
Sub 标准字符缩放()
Selection.Font.Scaling = 100
End Sub
Sub 减少字符间距()
With Selection
If .Type = wdSelectionIP Then .Expand 4
With .Font
If .Spacing = "9999999" Then .Spacing = 0
.Spacing = .Spacing - 0.1
End With
End With
End Sub
Sub 增加字符间距()
With Selection
If .Type = wdSelectionIP Then .Expand 4
With .Font
If .Spacing = "9999999" Then .Spacing = 0
.Spacing = .Spacing + 0.2
End With
End With
End Sub
Sub 粘贴无格式文本()
If Documents.Count = 0 Then Documents.Add
Selection.PasteAndFormat Type:=wdFormatPlainText
End Sub
Sub 删除所有空格()
With Selection
If .Type = wdSelectionIP Then .WholeStory
With .Find
.ClearFormatting
.Execute "^w", , , 0, , , , , , "", 2
.Execute "　", , , 0, , , , , , "", 2
End With
End With
End Sub
Sub 切换标题副标题()
With Selection
.Expand 4
If .Style <> ActiveDocument.Styles(wdStyleSubtitle) Then
.Style = ActiveDocument.Styles(wdStyleSubtitle)
Else
.Style = ActiveDocument.Styles(wdStyleTitle)
End If
.Font.NameAscii = "Times New Roman"
With .ParagraphFormat
.SpaceBeforeAuto = False
.SpaceAfterAuto = False
.SpaceBefore = 0
.SpaceAfter = 0
.LineSpacing = LinesToPoints(1.25)
.AutoAdjustRightIndent = False
.DisableLineHeightGrid = True
End With
End With
End Sub
Sub 切换页眉()
ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
With Selection.ParagraphFormat.Borders(wdBorderBottom)
If .LineStyle = wdLineStyleNone Then .LineStyle = wdLineStyleSingle Else .LineStyle = wdLineStyleNone
End With
ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
End Sub
Sub 减少一页()
Dim x&, y&, i!, j&
With Selection
If .Type = wdSelectionIP Then 选择正文
If .End <> ActiveDocument.Content.End Then
If Asc(.Next) = 12 Then .MoveEnd: j = 1
End If
With .Find
.ClearFormatting
If .Parent.Information(4) = 2 Then
.Execute "^p^p^p^p", , , 0, , , , , , "^p^p", 2
Else
.Execute "^p^p^p^p", , , 0, , , , , , "^p^p^p", 2
End If
End With
x = .Characters.First.Information(3)
y = .Characters.Last.Information(3)
If x = y Then GoTo js
With .ParagraphFormat
If .LineSpacing = "9999999" Then .LineSpacing = LinesToPoints(1.5)
i = 1.5
Do
i = i - 0.01
.LineSpacing = LinesToPoints(i)
If Round(.LineSpacing / 12, 2) <= 1 Then .Space1: Exit Sub
Loop Until .Parent.Characters.Last.Information(3) = y - 1
End With
js:
If j = 1 Then
If .Characters.Last.Next.Text = "附" Then
.Characters.Last.ParagraphFormat.Space1
End If
End If
.HomeKey 6
End With
插入页码
End Sub
Sub 缩减一行()
Dim r As Range, s As Range, i&, j&
With Selection
If .ParagraphFormat.Alignment = wdAlignParagraphCenter Then j = 0 Else j = 1
If .Information(12) Then
.MoveEndUntil cset:=vbCr, Count:=wdForward
.MoveStart 5, -1
Else
.Expand 4
End If
With .Font
If .Spacing = "9999999" Then .Spacing = 0
If .Scaling = "9999999" Then .Scaling = 100
End With
Set s = .Range
i = s.ComputeStatistics(statistic:=wdStatisticLines)
If i = 1 Or i = 0 Then Exit Sub
If j = 1 Then .MoveStart 1, 1
Set r = .Range
With r.Font
If j = 0 Then
.Spacing = -0.5
Do Until r.ComputeStatistics(statistic:=wdStatisticLines) = i - 1
.Scaling = .Scaling - 2
Loop
Else
Do
.Spacing = .Spacing - 0.1
Loop Until s.ComputeStatistics(statistic:=wdStatisticLines) = i - 1
End If
End With
End With
End Sub
Sub 纵横转换()
With Selection
If .Type <> wdSelectionIP Then
ActiveDocument.Range(Start:=.Start, End:=.Start).InsertBreak Type:=wdSectionBreakNextPage
.Start = .Start + 1
If .End <> ActiveDocument.Content.End Then
ActiveDocument.Range(Start:=.End, End:=.End).InsertBreak Type:=wdSectionBreakNextPage
End If
End If
With .PageSetup
If .Orientation = wdOrientPortrait Then .Orientation = wdOrientLandscape Else .Orientation = wdOrientPortrait
End With
End With
End Sub
Sub m2m3上标()
With Selection
If .Type = wdSelectionIP Then .HomeKey 6
With .Find
.ClearFormatting
.Execute "m2", , , 1, , , , , , "m" & ChrW(178), 2
.Execute "m3", , , 1, , , , , , "m" & ChrW(179), 2
End With
End With
End Sub
Sub 发文字号()
核心
With ActiveDocument
.Content.InsertBefore Text:=vbCr & "XXX发〔" & Format(Date, "yyyy") & "〕" & "X号" & vbCr
.Paragraphs(1).Range.Font.Size = 102
.Paragraphs(3).Range.Font.Size = 40
With .Paragraphs(2).Range.Font
.Size = 16
.NameFarEast = "仿宋"
End With
.Range(Start:=0, End:=.Paragraphs(3).Range.End).Font.NameAscii = "Times New Roman"
End With
End Sub
Sub 行高循环()
CursorIn
With Selection
If .Type = wdSelectionIP Then .Tables(1).Select
If .Rows.HeightRule = 1 Or .Rows.HeightRule = 2 Then
If .Rows.Height >= CentimetersToPoints(1.2) Then
.Rows.Height = CentimetersToPoints(0.5)
Else
.Rows.Height = CentimetersToPoints(.Rows.Height / 28.35 + 0.1)
End If
ElseIf .Rows.HeightRule = 9999999 Or .Rows.HeightRule = 0 Then
.Rows.HeightRule = wdRowHeightAtLeast
.Rows.Height = CentimetersToPoints(0.5)
End If
End With
End Sub
Sub 表格满页()
CursorIn
Dim j!, k!, x&, y&
With Selection
With .Tables(1).Range
x = .Characters.First.Information(wdActiveEndPageNumber)
y = .Characters.Last.Information(wdActiveEndPageNumber)
If x <> y Then End
.Rows.Height = CentimetersToPoints(0.5)
Do
j = j + 0.02
.Rows.Height = CentimetersToPoints(0.5 + j)
Loop Until .Characters.Last.Information(wdActiveEndPageNumber) = y + 1
j = 0
Do
j = j + 0.01
k = Round(.Rows.Height / 28.35, 2)
.Rows.Height = CentimetersToPoints(k - j)
Loop Until .Characters.Last.Information(wdActiveEndPageNumber) = y
End With
End With
最后一磅
End Sub
Sub 表格全选()
Dim t As Table
With ActiveDocument
.DeleteAllEditableRanges wdEditorEveryone
For Each t In .Tables
t.Range.Editors.Add wdEditorEveryone
Next
.SelectAllEditableRanges wdEditorEveryone
.DeleteAllEditableRanges wdEditorEveryone
End With
End Sub
Sub 表格缩行()
Dim t As Table, c As Cell, a&
With Selection
If .Information(12) Then a = 1
For Each t In ActiveDocument.Tables
If a = 1 Then Set t = .Tables(1)
With t.Range.Find
.Execute "^p", , , , , , , , , "", 2
.Execute "^l", , , , , , , , , "", 2
.Execute "^w", , , , , , , , , "", 2
.Execute "　", , , , , , , , , "", 2
End With
For Each c In t.Range.Cells
c.Range.Select
.MoveEnd Unit:=wdCharacter, Count:=-1
With .Font
If .Spacing = "9999999" Then .Spacing = 0
If .Scaling = "9999999" Then .Scaling = 100
If .Parent.Range.ComputeStatistics(statistic:=wdStatisticLines) > 1 Then .Spacing = -0.5
Do Until .Parent.Range.ComputeStatistics(statistic:=wdStatisticLines) = 1
If .Parent.Range.ComputeStatistics(statistic:=wdStatisticLines) = 0 Then Exit Do
.Scaling = .Scaling - 2
Loop
End With
Next
If a = 1 Then Exit For
Next
.HomeKey 6
End With
End Sub
Sub 外框加粗()
Dim t As Table, i&, j&
If Selection.Information(12) Then i = 1
For Each t In ActiveDocument.Tables
If i = 1 Then Set t = Selection.Tables(1)
For j = 1 To 4
t.Range.Borders(-j).LineWidth = 12
Next
If i = 1 Then Exit For
Next
End Sub
Sub 断行相连()
ActiveDocument.Content.Find.Execute FindText:="([!。：！？…）])^13", MatchWildcards:=True, ReplaceWith:="\1", Replace:=wdReplaceAll
End Sub
Sub CursorIn()
If Not Selection.Information(12) Then MsgBox "请将光标放在表格中！", 0 + 16: End
End Sub
Sub 删行热键()
KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyF3), KeyCategory:=wdKeyCategoryMacro, Command:="合并单元格"
KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyF4), KeyCategory:=wdKeyCategoryMacro, Command:="删除行"
MsgBox "F3：合并单元格 F4：删除行", 0 + 48
End Sub
Sub 合并单元格()
On Error Resume Next
With Selection
.Cells.Merge
.MoveLeft 1, 1
End With
End Sub
Sub 删除行()
CursorIn
Selection.Rows.Delete
End Sub
Sub 减少行高()
On Error Resume Next
CursorIn
With Selection
If .Rows.Height / 28.3 <= 0.04 Then End
If .Type = wdSelectionIP Then .Tables(1).Select
If .Rows.HeightRule = 1 Or .Rows.HeightRule = 2 Then
.Rows.Height = CentimetersToPoints(.Rows.Height / 28.35 - 0.05)
ElseIf .Rows.HeightRule = 9999999 Or .Rows.HeightRule = 0 Then
.Rows.Height = CentimetersToPoints(0.7)
End If
End With
End Sub
Sub 行高热键()
KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyF3), KeyCategory:=wdKeyCategoryMacro, Command:="减少行高"
KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyF4), KeyCategory:=wdKeyCategoryMacro, Command:="增加行高"
MsgBox "F3：减少行高 F4：增加行高", 0 + 48
End Sub
Sub 减少行高微调()
CursorIn
With Selection
If .Type = wdSelectionIP Then .Tables(1).Select
.Rows.HeightRule = wdRowHeightAtLeast
.Rows.Height = CentimetersToPoints(.Rows.Height / 28.35 - 0.01)
.Rows.HeightRule = wdRowHeightExactly
End With
End Sub
Sub 行高微调热键()
KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyF3), KeyCategory:=wdKeyCategoryMacro, Command:="减少行高微调"
KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyF4), KeyCategory:=wdKeyCategoryMacro, Command:="增加行高微调"
MsgBox "F3：减少行高微调 F4：增加行高微调", 0 + 48
End Sub
Sub 行距热键()
KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyF3), KeyCategory:=wdKeyCategoryMacro, Command:="减少行距"
KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyF4), KeyCategory:=wdKeyCategoryMacro, Command:="增加行距"
MsgBox "F3：减少行距 F4：增加行距", 0 + 48
End Sub
Sub 间距热键()
KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyF3), KeyCategory:=wdKeyCategoryMacro, Command:="减少字符间距"
KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyF4), KeyCategory:=wdKeyCategoryMacro, Command:="增加字符间距"
MsgBox "F3：减少字符间距 F4：增加字符间距", 0 + 48
End Sub
Sub 缩放热键()
KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyF3), KeyCategory:=wdKeyCategoryMacro, Command:="减少字符缩放"
KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyF4), KeyCategory:=wdKeyCategoryMacro, Command:="增加字符缩放"
MsgBox "F3：减少字符缩放 F4：增加字符缩放", 0 + 48
End Sub
Sub 悬挂缩进热键()
ActiveWindow.ActivePane.View.Zoom.Percentage = 100
KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyF3), KeyCategory:=wdKeyCategoryMacro, Command:="减少悬挂缩进"
KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyF4), KeyCategory:=wdKeyCategoryMacro, Command:="增加悬挂缩进"
MsgBox "F3：减少悬挂缩进 F4：增加悬挂缩进", 0 + 48
End Sub
Sub 减少悬挂缩进()
Selection.ParagraphFormat.CharacterUnitFirstLineIndent = Selection.ParagraphFormat.CharacterUnitFirstLineIndent + 0.01
End Sub
Sub 增加悬挂缩进()
Selection.ParagraphFormat.CharacterUnitFirstLineIndent = Selection.ParagraphFormat.CharacterUnitFirstLineIndent - 0.01
End Sub
Sub 第一章()
Dim i&, j$, k$, m$, n&
k = MsgBox("<是>：第一章 <否>：第一条 <取消>：自定义", 3 + 48)
If k = 6 Then
j = "章"
ElseIf k = 7 Then
j = "条"
Else
j = InputBox("", "请输入量词（节/课/题/部分/阶段/自然段）", "部分")
If j = "" Then End
End If
m = MsgBox("<是>：第一" & j & " <否>：第1" & j & " <取消>：放弃", 3 + 48)
If m = 6 Then
n = 2
ElseIf m = 7 Then
n = 1
Else
End
End If
With Selection
.HomeKey 6
With .Find
.ClearFormatting
.Replacement.Text = ""
Do While .Execute("^13第[一二三四五六七八九十0-9０-９百零〇○Oo千]{1,}" & j, , , 1, , , 1)
With .Parent
If Not .Information(12) Then
.MoveStart
.Expand 4
With .Find
.Execute " ", , , , , , , , , "", 2
.Execute "　", , , , , , , , , "", 2
.Execute "^s", , , , , , , , , "", 2
.Execute "^t", , , , , , , , , "", 2
End With
.Characters(InStr(.Text, j) + Len(j) - 1).InsertAfter Text:=Chr(-24159)
If j = "条" Then
If .Text Like "*[!。：；，、！？…—.:;,!?]?" Then .Characters.Last.InsertBefore Text:="。"
.MoveEnd 1, -(Len(.Text) - InStr(.Text, j))
With .Font
.NameFarEast = "黑体"
.NameAscii = "Times New Roman"
.Bold = True
.Color = wdColorPink
End With
Else
.Style = wdStyleSubtitle
.Font.NameFarEast = "黑体"
.Font.Color = wdColorRed
If Len(j) > 1 Then .Font.Color = wdColorBrown
If Len(j) > 1 Then .Font.Size = 18
With .ParagraphFormat
.SpaceBefore = 24
.SpaceAfter = 30
End With
If .Text Like "*[。：；，、！？…—.:;,!?]?" Then .Characters.Last.Previous.Delete
If .Text Like "*　???" Then .Characters.Last.Previous.InsertBefore Text:=Chr(-24159)
.MoveEnd 1, -(Len(.Text) - (InStr(.Text, j) + Len(j) - 1))
End If
.MoveStart
.MoveEnd 1, -Len(j)
i = i + 1
.Text = i
If n = 2 Then
.Delete
.Fields.Add Range:=.Range, Text:="= " & i & " \* CHINESENUM3"
.Paragraphs(1).Range.Fields.Unlink
End If
Else
.Tables(1).Range.Next.Select
If Asc(.Text) <> 13 Then .InsertParagraphBefore
.Characters(1).Font.Size = 4
End If
.EndKey 5
End With
Loop
End With
.HomeKey 6
End With
End Sub
Sub 千分位()
Dim i&, j&, k&, h&
With Selection
.HomeKey 6
With .Find
.ClearFormatting
.Text = "[0-9.,，　^s^t]{1,}元"
.Forward = True
.MatchWildcards = True
Do While .Execute
With .Parent
.MoveEnd 1, -1
.Text = Replace(.Text, " ", "")
.Text = Replace(.Text, "　", "")
.Text = Replace(.Text, vbTab, "")
.Text = Replace(.Text, ChrW(160), "")
.Text = Replace(.Text, ",", "")
.Text = Replace(.Text, "，", "")
.Text = Format(.Text)
If .Text Like "*.*.*" Then .Font.Color = wdColorRed: GoTo skip
If .Text Like ".*" Then .Text = "0" & .Text
If .Text Like "*?.??" Then
ElseIf .Text Like "*?.?" Then
.Text = .Text & "0"
ElseIf .Text Like "*?.???*" Then
.Text = Format(.Text, "0.00")
Else
.Text = .Text & ".00"
End If
.Font.Color = wdColorGreen
'千分位
If .Text Like "*.*" Then i = InStr(.Text, ".") - 1 Else i = Len(.Text)
k = Int(i / 3)
If k = i / 3 Then k = k - 1
If i >= 4 Then
For j = 1 To k
.Characters(i - 3 * k + h).InsertAfter Text:=","
h = h + 4
Next j
h = 0
End If
skip:
.Collapse 0
End With
Loop
End With
End With
End Sub
Sub 清除格式()
'样式(边框/底纹/突出显示/背景)
With Selection
.WholeStory
.ClearFormatting
.Font.Borders(1).LineStyle = wdLineStyleNone
.Font.Shading.Texture = wdTextureNone
.Range.HighlightColorIndex = wdNoHighlight
ActiveDocument.Background.Fill.Visible = msoFalse
'底纹边框
With .ParagraphFormat
.Shading.Texture = wdTextureNone
.Shading.BackgroundPatternColor = wdColorAutomatic
.Borders(wdBorderLeft).LineStyle = wdLineStyleNone
.Borders(wdBorderRight).LineStyle = wdLineStyleNone
.Borders(wdBorderTop).LineStyle = wdLineStyleNone
.Borders(wdBorderBottom).LineStyle = wdLineStyleNone
End With
'页面边框
With .Sections(1)
.Borders(wdBorderLeft).LineStyle = wdLineStyleNone
.Borders(wdBorderRight).LineStyle = wdLineStyleNone
.Borders(wdBorderTop).LineStyle = wdLineStyleNone
.Borders(wdBorderBottom).LineStyle = wdLineStyleNone
End With
End With
End Sub
Sub 删除图文框文本框()
Dim j As Frame
For Each j In ActiveDocument.Frames
j.Delete
Next
Dim i As Shape
For Each i In ActiveDocument.Shapes
If i.Type = msoTextBox And i.Type = 17 Then
i.TextFrame.TextRange.Select
Selection.Copy
i.Delete
Selection.Paste
End If
Next
With Selection
.WholeStory
With .ParagraphFormat
.Borders(wdBorderLeft).LineStyle = wdLineStyleNone
.Borders(wdBorderRight).LineStyle = wdLineStyleNone
.Borders(wdBorderTop).LineStyle = wdLineStyleNone
.Borders(wdBorderBottom).LineStyle = wdLineStyleNone
End With
End With
End Sub
Sub 删除空行()
Dim i As Paragraph
For Each i In ActiveDocument.Paragraphs
If Asc(i.Range) = 13 Then i.Range.Delete
Next
End Sub
Sub 姓名加空()
CursorIn
Dim r As Range
With Selection
If .Type = wdSelectionIP Then .SelectColumn
Set r = .Range
With r.Find
.Execute "<(?)(?)>", , , 1, , , , , , "\1 \2", 2
.Execute "<(?) (?)>", , , 1, , , , , , "\1 \2", 2
End With
.Find.Replacement.Text = ""
End With
End Sub
Sub 增加行高()
CursorIn
With Selection
If .Type = wdSelectionIP Then .Tables(1).Select
If .Rows.HeightRule = 1 Or .Rows.HeightRule = 2 Then
.Rows.Height = CentimetersToPoints(.Rows.Height / 28.35 + 0.05)
ElseIf .Rows.HeightRule = 9999999 Or .Rows.HeightRule = 0 Then
.Rows.Height = CentimetersToPoints(0.7)
End If
End With
End Sub
Sub 增加行高微调()
CursorIn
With Selection
If .Type = wdSelectionIP Then .Tables(1).Select
.Rows.HeightRule = wdRowHeightAtLeast
.Rows.Height = CentimetersToPoints(.Rows.Height / 28.35 + 0.01)
.Rows.HeightRule = wdRowHeightExactly
End With
End Sub
Sub 本机排版()
Dim doc As Document, docNew As Document, docTable As Document, t As Table, y$, s&, i&, j&, g&, x$
If MsgBox("是否公文排版（否则普通排版）？", 4 + 16) = vbYes Then g = 1 Else g = 0
Set doc = ActiveDocument
y = doc.FullName
If doc.Tables.Count = 0 Then
ct:
doc.Content.Copy
doc.Close savechanges:=wdDoNotSaveChanges
Set docNew = Documents.Add
docNew.Content.PasteAndFormat Type:=wdFormatPlainText
If g = 1 Then 核心 Else 外核
x = Left(y, Len(y) - 4) & "-Old" & ".doc"
Name y As x
docNew.SaveAs FileName:=y
docNew.Characters(1).Copy
If s = 1 Then GoTo ch
Else
i = doc.Tables.Count
Set docTable = Documents.Add
Documents(doc).Activate
For Each t In doc.Tables
t.Rows.WrapAroundText = False
t.Range.Copy
Documents(docTable).Activate
Selection.Paste
Selection.TypeText Text:="***" & vbCr
Documents(doc).Activate
t.Range.Next(4, 1).InsertBefore Text:="markmytable" & vbCr
doc.Characters(1).Copy
Next
For Each t In doc.Tables
t.Delete
Next
s = 1
GoTo ct
ch:
For j = 1 To i
With Selection
.HomeKey 6
With .Find
.ClearFormatting
.Execute "markmytable", , , 0, , , 1
End With
.Delete
docTable.Tables(j).Range.Copy
.Paste
.Paragraphs(1).Range.Font.Size = 4
docNew.Characters(1).Copy
End With
Next j
Selection.HomeKey 6
docNew.Save
docTable.Close savechanges:=wdDoNotSaveChanges
End If
End Sub
Sub 格式()
If Documents.Count = 0 Then MsgBox "一词一行/一列表格", 0 + 16, "格式": End
Dim r As Row
With ActiveDocument
With .Content.Find
.Execute "^13", , , , , , , , , "^p", 2
.Execute "^11", , , , , , , , , "^p", 2
End With
With .Tables
If .Count = 0 Then
.Parent.Content.ConvertToTable Separator:=wdSeparateByParagraphs, NumColumns:=1, AutoFitBehavior:=wdAutoFitFixed
ElseIf .Count = 1 Then
ElseIf .Count > 1 Then
MsgBox "一词一行/一列表格", 0 + 16, "格式": End
End If
End With
With .Tables(1)
.Select
With Selection
.ClearFormatting
.MoveEnd
End With
CommandBars.FindControl(ID:=122).Execute
For Each r In .Rows
If Len(Replace(Replace(r.Range, vbCr, ""), Chr(7), "")) = 0 Then r.Delete
Next
.Select
End With
End With
End Sub
Sub 标牌()
格式
Dim i&, j&, c As Cell, r As Row
With ActiveDocument
.PageSetup.Orientation = wdOrientLandscape
ActiveWindow.ActivePane.View.Zoom.PageFit = wdPageFitFullPage
Selection.InsertColumnsRight
.Tables(1).AutoFitBehavior (wdAutoFitWindow)
j = .Tables(1).Rows.Count
With .Tables(1)
For i = 1 To j
.Cell(i, 2).Range.Text = .Cell(i, 1).Range.Text
Next i
End With
.Content.Find.Execute "^p", , , , , , , , , "", 2
With .Tables(1).Range
.Style = "普通表格"
.Rows.HeightRule = wdRowHeightExactly
.Rows.Height = CentimetersToPoints(14.6)
.Cells.VerticalAlignment = wdCellAlignVerticalCenter
With .Font
.NameFarEast = "黑体"
.Size = 72
.Bold = True
End With
.Columns(1).Select
.Orientation = wdTextOrientationDownward
For Each c In .Columns(2).Cells
c.Range.Orientation = wdTextOrientationUpward
Next
End With
End With
最后一磅
ActiveWindow.View.TableGridlines = True
Selection.HomeKey 6
End Sub
Sub 标签()
格式
With ActiveDocument.PageSetup
.TopMargin = CentimetersToPoints(2)
.BottomMargin = CentimetersToPoints(2)
.LeftMargin = CentimetersToPoints(1)
.RightMargin = CentimetersToPoints(1)
End With
With Selection
.Tables(1).Style = "网格型"
.Font.Bold = True
.Cells.VerticalAlignment = wdCellAlignVerticalCenter
If MsgBox("<是>：纵向(书脊) <否>：横向(封面)", 4 + 48) = vbYes Then
.PageSetup.Orientation = wdOrientLandscape
.Tables(1).Rows.Alignment = wdAlignRowCenter
.Rows.Height = CentimetersToPoints(3)
.Orientation = wdTextOrientationHorizontalRotatedFarEast
.ParagraphFormat.Alignment = wdAlignParagraphDistribute
.Borders(wdBorderLeft).LineStyle = wdLineStyleNone
.Borders(wdBorderRight).LineStyle = wdLineStyleNone
.Font.Size = 48
Else
.Tables(1).AutoFitBehavior (wdAutoFitWindow)
.PageSetup.TextColumns.SetCount NumColumns:=2
.Rows.Height = CentimetersToPoints(5)
.Font.Size = 60
End If
ActiveWindow.ActivePane.View.Zoom.PageFit = wdPageFitFullPage
ActiveWindow.View.TableGridlines = False
End With
End Sub
Sub 封面()
Documents.Add
With ActiveDocument
With .Content
.InsertBefore Text:=vbCr & "方案" & vbCr & "作者" & vbCr & vbCr & "大学" & vbCr & ChrW(160) & Format(Date, "yyyy年m月d日")
.Font.Bold = True
With .ParagraphFormat
.Alignment = wdAlignParagraphCenter
.AutoAdjustRightIndent = False
.DisableLineHeightGrid = True
End With
End With
.Paragraphs(1).Range.Font.Size = 110
.Paragraphs(2).Range.Font.Size = 40
With .Paragraphs(3).Range
With .Font
.Name = "楷体"
.Size = 22
End With
.ParagraphFormat.LineUnitBefore = 1.75
End With
.Paragraphs(4).Range.Font.Size = 280
.Paragraphs(5).Range.Font.Size = 20
With .Paragraphs(6).Range
.Font.Size = 18
.ParagraphFormat.LineUnitBefore = 0.6
End With
End With
End Sub
Sub 名单()
Dim doc As Document, i As Paragraph, j As Range, r As Range, s As Range, b&, c!, n&, m&, x&, y&
Set doc = ActiveDocument
With Selection
If .Type = wdSelectionIP Then MsgBox "请选定<组长/副组长/成员>区域！", 0 + 16, "名单": End
If Asc(.Previous) = 12 Then .InsertParagraphBefore: .MoveStart 1, 1: x = 1
If .Paragraphs.Last.Range.End = doc.Content.End Then .InsertParagraphAfter: .MoveEnd 1, -1: y = 1
.Expand 4
n = .Characters(1).Font.Size
Set s = .Range
.InsertAfter Text:=.Text
.MoveStart 4, s.Paragraphs.Count
Set r = .Range
s.Underline = wdUnderlineWavyHeavy
With .Find
.ClearFormatting
.Execute ":", , , 0, , , , , , "：", 2
.Execute "(：)[ 　^s^t]{1,}", , , 1, , , , , , "\1", 2
.Execute "。", , , 0, , , , , , "", 2
.Execute "、", , , 0, , , , , , " ", 2
End With
For Each i In r.Paragraphs
With i.Range
If .Text Like "*：*" Then
.InsertBefore Text:="<"
Set j = doc.Range(Start:=.Start, End:=i.Range.Characters(InStr(.Text, "：")).End - 1)
With j.Find
.Execute " ", , , 0, , , , , , "", 2
.Execute "　", , , 0, , , , , , "", 2
.Execute "^t", , , 0, , , , , , "", 2
End With
End If
End With
Next
With .Find
.ClearFormatting
.Execute "^p", , , 0, , , , , , " ", 2
.Execute "^s", , , 0, , , , , , " ", 2
.Execute "^t", , , 0, , , , , , " ", 2
.Execute "　", , , 0, , , , , , " ", 2
.Execute "：", , , 0, , , , , , "：^p", 2
.Execute " ", , , 0, , , , , , "^p", 2
End With
For Each i In r.Paragraphs
If Len(i.Range) = 1 Then i.Range.Delete
Next
For Each i In r.Paragraphs
If Len(i.Range) = 2 Then i.Range.Characters.Last.Delete
Next
For Each i In r.Paragraphs
If Len(i.Range) = 3 Then i.Range.Characters(1).InsertAfter Text:=" "
Next
With .Find
.ClearFormatting
.Execute "：^p", , , 0, , , , , , "：", 2
.Execute "^p", , , 0, , , , , , ",", 2
.Execute ",<", , , 0, , , , , , "^p", 2
End With
.ConvertToTable Separator:=wdSeparateByCommas, NumColumns:=5, AutoFitBehavior:=wdAutoFitFixed
.Rows.ConvertToText Separator:=wdSeparateByTabs, NestedTables:=True
.Find.Execute "^t", , , 0, , , , , , "　", 2
正文样式
.Characters.First.Delete
r.Select
For Each i In r.Paragraphs
If i.Range Like "*：*" Then
If i.Range Like "????：*" Then
b = 7
ElseIf i.Range Like "???：*" Then
b = 6
Else
b = 5
End If
If m < b Then m = b
End If
Next
b = m
If b = 6 Then
c = 6.1
For Each i In r.Paragraphs
If i.Range Like "??：*" Then i.Range.Characters(1).InsertAfter Text:="　"
Next
ElseIf b = 7 Then
c = 7.1
For Each i In r.Paragraphs
If i.Range Like "???：*" Then i.Range.Characters(2).InsertAfter Text:=" ": i.Range.Characters(1).InsertAfter Text:=" "
If i.Range Like "??：*" Then i.Range.Characters(1).InsertAfter Text:="　　"
Next
ElseIf b = 5 Then
c = 5.05
End If
For Each i In r.Paragraphs
If Not i.Range Like "*：*" Then i.Range.ParagraphFormat.CharacterUnitFirstLineIndent = c
i.Range.ParagraphFormat.CharacterUnitRightIndent = -0.5
If i.Range Like "*：*" Then i.Range.Characters(1).Select: .MoveEndUntil cset:="：": .MoveEnd Unit:=wdCharacter, Count:=1: .Font.Bold = True
Next
End With
With r.Font
If n = 14 Then .Name = "宋体": .Parent.ParagraphFormat.LineSpacing = LinesToPoints(1.25)
.Size = n
End With
If x = 1 Then s.Previous.Delete
If y = 1 Then r.Next.Delete
s.Select
MsgBox "请对照检查无误后删除原名单（选定区域）！", 0 + 48, "名单"
End Sub
Sub 人民币中文大写()
Dim i$, j$, k&, n&, m&
With Selection
If .Type = wdSelectionIP Then MsgBox "请选定数字！", 0 + 16: End
If .Text Like "*" & vbCr Then .MoveEnd 1, -1
.Text = Replace(.Text, " ", "")
.Text = Replace(.Text, "　", "")
.Text = Replace(.Text, vbTab, "")
.Text = Replace(.Text, ChrW(160), "")
.Text = Replace(.Text, ",", "")
.Text = Replace(.Text, "，", "")
Do While .Text Like "[!0-9]*"
.MoveStart
Loop
Do While .Text Like "*[!0-9]"
.MoveEnd 1, -1
Loop
n = Len(Selection)
.Characters(1).Select
Do While .Next Like "[0-9.]"
.MoveEnd
m = m + 1
If m = n - 1 Then Exit Do
Loop
If .Text Like "*.*" Then
i = Format(.Text, "0.00")
j = Right(i, 2)
i = Left(i, Len(i) - 3)
k = 1
Else
i = .Text
End If
If j = "00" Then k = 0
.TypeText Text:="（人民币"
.Fields.Add Range:=.Range, Text:="= " & i & " \* CHINESENUM2"
.TypeText Text:="元"
If k = 0 Then
.TypeText Text:="整）"
Else
.Fields.Add Range:=.Range, Text:="= " & Left(j, 1) & " \* CHINESENUM2"
.TypeText Text:="角"
.Fields.Add Range:=.Range, Text:="= " & Right(j, 1) & " \* CHINESENUM2"
.TypeText Text:="分）"
End If
.Paragraphs(1).Range.Fields.Unlink
With .Previous.Previous
If .Previous.Text = "零" Then .Previous.Delete: .Delete
End With
End With
End Sub
Sub 自动复制()
CursorIn
Dim m&, n&, h&, i$, c As Cell
With Selection
m = .Information(wdEndOfRangeRowNumber)
n = .Information(wdEndOfRangeColumnNumber)
h = .Information(wdMaximumNumberOfRows)
.SelectCell
CommandBars.FindControl(ID:=123).Execute
CommandBars.FindControl(ID:=122).Execute
.Range.ListFormat.RemoveNumbers NumberType:=wdNumberParagraph
If Len(.Text) = 2 Then End
.MoveEnd 1, -1
i = .Text
ActiveDocument.Range(Start:=.Tables(1).Cell(m + 1, n).Range.Start, End:=.Tables(1).Cell(h, n).Range.End).Select
.Range.ListFormat.RemoveNumbers NumberType:=wdNumberParagraph
For Each c In .Cells
c.Range.Text = i
Next
.Tables(1).Cell(m, n).Select
End With
End Sub
Sub 自动编号()
CursorIn
Dim s$, i$, j$, m&, n&, h&, c As Cell, u&, v&, z&, x$, y&
With Selection
If .Cells.Count > 1 Then .Cells(1).Select
m = .Information(wdEndOfRangeRowNumber)
n = .Information(wdEndOfRangeColumnNumber)
h = .Information(wdMaximumNumberOfRows)
.SelectCell
CommandBars.FindControl(ID:=123).Execute
CommandBars.FindControl(ID:=122).Execute
.Range.ListFormat.RemoveNumbers NumberType:=wdNumberParagraph
If Len(.Text) = 2 Then
i = 1
ActiveDocument.Range(Start:=.Tables(1).Cell(m, n).Range.Start, End:=.Tables(1).Cell(h, n).Range.End).Select
.Range.ListFormat.RemoveNumbers NumberType:=wdNumberParagraph
For Each c In .Cells
c.Range.Text = i
i = i + 1
Next
.Tables(1).Cell(m, n).Select
End
End If
.MoveEnd 1, -1
.Range.CharacterWidth = wdWidthHalfWidth
If .Text Like "*[!0-9]" Then MsgBox "非数字！", 0 + 16: End
j = .Text
Do While .Text Like "*[0-9]"
.MoveEnd 1, -1
If .Type = wdSelectionIP Then Exit Do
Loop
If .Type = wdSelectionIP Then
i = j
u = 1
Else
s = .Text
i = Right(j, Len(j) - Len(s))
End If
v = Len(i)
If i Like "0*" Then z = 1: i = Format(i)
If Len(i) > 15 Then MsgBox "编号仅限15位！", 0 + 16: End
ActiveDocument.Range(Start:=.Tables(1).Cell(m + 1, n).Range.Start, End:=.Tables(1).Cell(h, n).Range.End).Select
.Range.ListFormat.RemoveNumbers NumberType:=wdNumberParagraph
For Each c In .Cells
i = i + 1
If Len(i) > v Then Exit For
If z = 1 Then
x = ""
For y = 1 To v - Len(i)
x = x & "0"
Next y
i = x & i
End If
If u = 1 Then
c.Range.Text = i
Else
c.Range.Text = s & i
End If
Next
.Tables(1).Cell(m, n).Select
End With
End Sub
Sub 证书编号热键()
KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyF3), KeyCategory:=wdKeyCategoryMacro, Command:="证书行数调整"
KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyF4), KeyCategory:=wdKeyCategoryMacro, Command:="证书编号检查"
MsgBox "F3：证书行数调整" & vbCr & "F4：证书编号检查", 0 + 48
End Sub
Sub 证书行数调整()
Dim s As Section, r As Range, a As Range, i&, j&
For Each s In ActiveDocument.Sections
If s.Range.Paragraphs.Count = 1 Then Exit For
Set a = s.Range.Paragraphs(1).Range
With a.Font
If .Parent.ComputeStatistics(statistic:=wdStatisticLines) > 1 Then
.Spacing = -0.5
Do Until a.ComputeStatistics(statistic:=wdStatisticLines) = 1
.Scaling = .Scaling - 2
Loop
i = i + 1
End If
End With
Set r = s.Range.Paragraphs(2).Range
With r.Font
If .Parent.ComputeStatistics(statistic:=wdStatisticLines) > 2 Then
.Spacing = -0.5
Do Until r.ComputeStatistics(statistic:=wdStatisticLines) = 2
.Scaling = .Scaling - 2
Loop
j = j + 1
End If
End With
Next
MsgBox "调整 " & i + j & " 处！", 0 + 48, "证书行数调整"
End Sub
Sub 证书编号检查()
CursorIn
Dim s$, i$, j$, m&, n&, h&, c As Cell, u&, v&, z&, x$, y&, k$
With Selection
.SelectCell
.MoveEnd 1, -1
j = .Text
m = .Information(wdEndOfRangeRowNumber)
n = .Information(wdEndOfRangeColumnNumber)
h = .Information(wdMaximumNumberOfRows)
Do While .Text Like "*[0-9]"
.MoveEnd 1, -1
If .Type = wdSelectionIP Then Exit Do
Loop
If .Type = wdSelectionIP Then
i = j
u = 1
Else
s = .Text
i = Right(j, Len(j) - Len(s))
End If
v = Len(i)
If i Like "0*" Then z = 1: i = Format(i)
ActiveDocument.Range(Start:=.Tables(1).Cell(m + 1, n).Range.Start, End:=.Tables(1).Cell(h, n).Range.End).Select
For Each c In .Cells
i = i + 1
If Len(i) > v Then Exit For
If z = 1 Then
x = ""
For y = 1 To v - Len(i)
x = x & "0"
Next y
i = x & i
End If
k = Left(c.Range.Text, Len(c.Range.Text) - 2)
If u = 1 Then
If k <> i Then
c.Select
.SplitTable
.TypeText Text:="***"
c.Select
MsgBox "编号不连续！", 0 + 16
Exit Sub
End If
Else
If k <> s & i Then
c.Select
.SplitTable
.TypeText Text:="***"
c.Select
MsgBox "编号不连续！", 0 + 16
Exit Sub
End If
End If
Next
.Tables(1).Cell(m, n).Select
End With
End Sub
Sub 证书表格合并()
If ActiveDocument.Saved = False Then MsgBox "未保存！", 0 + 16: End
Dim doc As Document, d$, a, b, n&, m&, q$, t As Table, c As Cell, r As Row, i&, s$, u$
Set doc = ActiveDocument

d = MsgBox("<是>：默认字段 <否>：表格一字段 <取消>：自定义", 3 + 48)
If d = vbYes Then
n = 1
m = 5
a = Array("证书编号", "课题", "姓名", "单位", "等级")
ElseIf d = vbNo Then
n = 2
Else
n = 3
q = InputBox("", "请输入自定义字段（空格分隔）！", "姓名单位课题等级证书编号")
If q = "" Then End
b = Split(q, " ")
m = UBound(b) + 1
End If

证书表格预置

If n = 2 Then m = doc.Tables(1).Columns.Count

With doc
For Each t In .Tables
With t
'调整字段
For i = 1 To m
If n = 1 Then
s = a(i - 1)
ElseIf n = 2 Then
s = doc.Tables(1).Rows(1).Cells(i).Range.Text
s = Left(s, Len(s) - 2)
ElseIf n = 3 Then
s = b(i - 1)
End If
If .Rows(1).Range Like "*" & s & "*" Then
.Rows(1).Select
With Selection
With .Find
.ClearFormatting
.Execute s
End With
If .Information(17) <> i Then
.Columns(1).Select
.Cut
t.Columns(i).Select
.Paste
End If
End With
Else
If i = 1 Then .Cell(1, 1).Select
With Selection
If i = 1 Then .InsertColumns Else .InsertColumnsRight
.Cells(1).Range.Text = s
End With
End If
Next i

'删除末列
If n = 1 Then
u = "等级"
ElseIf n = 2 Then
u = doc.Tables(1).Rows(1).Cells(doc.Tables(1).Columns.Count).Range.Text
u = Left(u, Len(u) - 2)
ElseIf n = 3 Then
u = b(UBound(b))
End If
Do While Not .Rows(1).Cells(.Columns.Count).Range Like u & "*"
.Columns(.Columns.Count).Delete
Loop
End With
Next

'合并数据
Do While .Tables.Count > 1
With .Tables(2)
.Rows(1).Delete
.Select
End With
With Selection
.MoveEnd 1, -1
.Cut
End With
.Tables(1).Range.Characters.Last.Select
With Selection
.MoveRight 12, 1
.Paste
End With
.Characters(1).Copy
Loop
End With

证书表格后期

End Sub
Sub 证书表格预置()
Dim t As Table, c As Cell, r As Row, x&, y&, z&, j&, k&, e&
With ActiveDocument
With .Content.Find
.Execute "^13", , , , , , , , , "", 2
.Execute "^11", , , , , , , , , "", 2
End With

For Each t In .Tables
With t
'取消环绕
With .Rows
.WrapAroundText = False
.Alignment = wdAlignRowLeft
.LeftIndent = CentimetersToPoints(0)
End With

'是否规则(e=1=规则/e=0=不规则)
With .Range
x = .Information(wdEndOfRangeRowNumber)
y = .Information(wdEndOfRangeColumnNumber)
z = .Cells.Count
End With
If x <> 1 Then
If z = x * y Then
For k = 1 To y
For j = 1 To x - 1
If .Cell(j + 1, k).Width = .Cell(j, k).Width Then e = 1 Else e = 0
If e = 0 Then Exit For
Next j
If e = 0 Then Exit For
Next k
Else
e = 0
End If
Else
e = 1
End If
If e = 0 Then .Select: MsgBox "表格不规则！", 0 + 16: End
End With
Next

For Each t In .Tables
With t
'删除空格
.Select
Selection.MoveEnd
CommandBars.FindControl(ID:=122).Execute

'删除表头空格
With .Rows(1).Range.Find
.Execute "^w", , , , , , , , , "", 2
.Execute "　", , , , , , , , , "", 2
End With

'规范字段
For Each c In .Rows(1).Cells
With c.Range
If .Text Like "*序号*" Then
.Text = "序号"
ElseIf .Text Like "*姓名*" Then
.Text = "姓名"
ElseIf .Text Like "*课题*" Then
.Text = "课题"
ElseIf .Text Like "*[单学][位校]*" Then
.Text = "单位"
ElseIf .Text Like "*[等奖][级项]*" Then
.Text = "等级"
ElseIf .Text Like "*编号*" Then
.Text = "证书编号"
End If
If Len(.Text) = 2 Then .Text = "空列"
End With
Next

'删除空列
Do While .Rows(1).Range Like "*空列*"
.Rows(1).Select
With Selection
With .Find
.ClearFormatting
.Execute "空列"
End With
.Columns.Delete
End With
Loop

'删除序号
.Rows(1).Select
With Selection.Find
.ClearFormatting
.Execute "序号"
If .Found = True Then .Parent.Columns.Delete
End With

'删除空行
For Each r In .Rows
If Len(Replace(Replace(r.Range, vbCr, ""), Chr(7), "")) = 0 Then r.Delete
Next

'蓝色粉红
.Range.Font.Color = wdColorBlue
.Rows(2).Range.Font.Color = wdColorPink
End With
Next
End With
End Sub
Sub 证书表格后期()
With ActiveDocument
If Not .Paragraphs(1).Range.Information(12) Then .Paragraphs(1).Range.Delete
.Range(Start:=.Tables(1).Range.End, End:=.Content.End).Delete
With .Tables(1).Rows(1).Range.Font
.Color = wdColorRed
.Bold = True
End With
With .Tables(1)
With .Range
.Font.Size = 10.5
.ParagraphFormat.Space1
End With
With .Rows
.HeightRule = wdRowHeightAtLeast
.Height = CentimetersToPoints(0)
End With
.Select
.AutoFitBehavior (wdAutoFitContent)
.Select
.AutoFitBehavior (wdAutoFitWindow)
End With
ActiveWindow.ActivePane.View.Zoom.PageFit = wdPageFitBestFit
Selection.HomeKey 6
End With
End Sub
Sub 证书自动编号()
If ActiveDocument.Tables.Count <> 1 Then MsgBox "证书数据源仅限一个表格！", 0 + 16: End
Dim doc As Document, t As Table, c As Cell, m&, n&, x&, k&, d&, b&
Set doc = ActiveDocument
Set t = doc.Tables(1)

证书表格预置

'字段
With t
For Each c In .Rows(1).Cells
With c.Range
If .Text Like "姓名*" Then
x = .Information(17)
ElseIf .Text Like "课题*" Then
k = .Information(17)
ElseIf .Text Like "等级*" Then
d = .Information(17)
ElseIf .Text Like "证书编号*" Then
b = .Information(17)
End If
End With
Next
If x = 0 Or k = 0 Then MsgBox "<姓名/课题>丢失！", 0 + 16: End
If d = 0 Then If MsgBox("<等级>丢失！是否继续？", 4 + 16) = vbNo Then End
If b = 0 Then If MsgBox("<证书编号>丢失！是否继续？", 4 + 16) = vbNo Then End

'编号
If b > 0 Then .Cell(2, b).Range.Select: 自动编号
m = .Rows.Count

'等级
If d > 0 Then
doc.Range(Start:=.Cell(2, d).Range.Start, End:=.Cell(m, d).Range.End).Select
For Each c In Selection.Cells
With c.Range
If Len(.Text) = 2 Then
.Shading.BackgroundPatternColor = wdColorRed
ElseIf .Text Like "[1１一壹]*" Then
.Text = "一等"
ElseIf .Text Like "[2２二贰]*" Then
.Text = "二等"
ElseIf .Text Like "[3３三叁]*" Then
.Text = "三等"
End If
End With
Next
End If

'姓名
.Columns(x).Select
Selection.Find.Execute "[ 　^s]@", , , 1, , , , , , "", 2
doc.Range(Start:=.Cell(2, x).Range.Start, End:=.Cell(m, x).Range.End).Select
For Each c In Selection.Cells
With c.Range
.MoveEnd 1, -1
If Len(.Text) = 0 Then
.Shading.BackgroundPatternColor = wdColorRed
ElseIf Len(.Text) = 1 Then
.Shading.BackgroundPatternColor = wdColorBrightGreen
ElseIf Len(.Text) = 2 Then
.Characters(1).InsertAfter Text:=" "
ElseIf Len(.Text) >= 4 Then
.Shading.BackgroundPatternColor = wdColorBrightGreen
End If
End With
Next

'课题
.Columns(k).Select
With Selection.Find
.ClearFormatting
.Execute "《", , , , , , , , , "〈", 2
.Parent.SelectColumn
.Execute "》", , , , , , , , , "〉", 2
End With
doc.Range(Start:=.Cell(2, k).Range.Start, End:=.Cell(m, k).Range.End).Select
For Each c In Selection.Cells
With c.Range
.MoveEnd 1, -1
If Len(.Text) = 0 Then
.Shading.BackgroundPatternColor = wdColorRed
ElseIf .Text Like "〈*〉" Then
.Characters.First.Delete
.Characters.Last.Delete
ElseIf .Text Like "〈*" Then
If Not (.Text Like "〈*〉?*") Then .Characters.First.Delete
ElseIf .Text Like "*〉" Then
If Not (.Text Like "*?〈*〉") Then .Characters.Last.Delete
ElseIf .Text Like "*?〈?*" Then
If Not (.Text Like "*〈*〉*") Then .Text = .Text & "〉"
ElseIf .Text Like "*?〉?*" Then
.Text = "〈" & .Text
End If
End With
Next

'序号
.Columns(1).Select
With Selection
.InsertColumns
.Shading.BackgroundPatternColor = wdColorAutomatic
.Range.Cells.VerticalAlignment = wdCellAlignVerticalCenter
For Each c In .Cells
c.Range.Text = n
n = n + 1
Next
.Cells(1).Range.Text = "序号"
End With

证书表格后期

'校验
If b > 0 Then .Cell(2, b + 1).Select: 证书编号检查: 证书编号热键
End With
End Sub
Sub doc2txt()
Dim i$, j$
With ActiveDocument
i = .FullName
If Not i Like "*:*" Then MsgBox "未保存！不能转换！", 0 + 16: End
If i Like "*.doc" Or i Like "*.txt" Then
j = Left(i, Len(i) - 4)
ElseIf i Like "*.docx" Then
j = Left(i, Len(i) - 5)
End If
If i Like "*.doc" Or i Like "*.docx" Then
.SaveAs FileName:=j, FileFormat:=wdFormatText
ElseIf i Like "*.txt" Then
.SaveAs FileName:=j, FileFormat:=wdFormatDocument
Else
End
End If
.Close
End With
If MsgBox("转换完毕！是否删除源文件？", 4 + 64, "doc2txt & txt2doc") = vbYes Then Kill i
End Sub
Sub 批量排版()
On Error Resume Next
Dim fd As FileDialog, i&, doc As Document, p$, e&, g&
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
If fd.Show = -1 Then p = fd.SelectedItems(1) Else Exit Sub
Set fd = Nothing
If MsgBox("是否排版文件夹 " & p & " ?", 4 + 48) = vbNo Then Exit Sub
If MsgBox("<是>：Word文档(*.doc) <否>：提取文件名", 4 + 48) = vbYes Then e = 1 Else e = 0
If e = 1 Then
If MsgBox("<是>：公文排版 <否>：普通排版", 4 + 16) = vbYes Then g = 1 Else g = 0
Else
Documents.Add
End If
With Application.FileSearch
.NewSearch
.LookIn = p
.SearchSubFolders = True
.FileName = "*.doc"
If .Execute > 0 Then
For i = 1 To .FoundFiles.Count
If e = 1 Then
Set doc = Documents.Open(FileName:=.FoundFiles(i))
If g = 1 Then 核心 Else 外核
删除页眉横线
ActiveWindow.ActivePane.View.Zoom.PageFit = wdPageFitBestFit
doc.Close savechanges:=wdSaveChanges
Else
ActiveDocument.Content.InsertAfter Text:=.FoundFiles(i) & vbCr
End If
Next i
MsgBox "排版完毕！共排版 " & .FoundFiles.Count & " 个文件！", 0 + 48
Else
MsgBox "未发现文件！", 0 + 16
End If
End With
End Sub
Sub 批量打印()
On Error Resume Next
Dim fd As FileDialog, i&, doc As Document, p$, s As Section, j&, k$, x&, t&
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
If fd.Show = -1 Then p = fd.SelectedItems(1) Else Exit Sub
Set fd = Nothing
If MsgBox("是否打印文件夹 " & p & " ?", 4 + 48) = vbNo Then Exit Sub
k = InputBox("请输入打印份数！", "批量打印", "1")
If k = "" Then Exit Sub
For t = 1 To k
With Application.FileSearch
.NewSearch
.LookIn = p
.SearchSubFolders = True
.FileName = "*.doc"
If .Execute > 0 Then
For i = 1 To .FoundFiles.Count
Set doc = Documents.Open(FileName:=.FoundFiles(i), Visible:=False)
For Each s In doc.Sections
With s.PageSetup
If .Orientation = wdOrientLandscape Then j = 1 Else j = 0
If .PaperSize <> wdPaperA4 Then .PaperSize = wdPaperA4: If j = 1 Then .Orientation = wdOrientLandscape
End With
Next
doc.PrintOut
doc.Close savechanges:=wdDoNotSaveChanges
Next i
x = .FoundFiles.Count
Else
MsgBox "未发现文件！", 0 + 16: End
End If
End With
Dialogs(wdDialogNewToolbar).Display timeout:=1 '延时
Next t
MsgBox "打印完毕！共打印 " & x & " 个文件！" & k & " 份！", 0 + 48
End Sub
Sub 批量合并()
On Error Resume Next
Dim fd As FileDialog, i&, doc As Document, p$, t&, j&, s As Section, k&, n&, m&, c&
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
If fd.Show = -1 Then p = fd.SelectedItems(1) Else Exit Sub
Set fd = Nothing
If MsgBox("是否合并文件夹 " & p & " ?", 4 + 48) = vbNo Then End
If MsgBox("<是>：Word 文档(*.doc) <否>：文本文档(*.txt)", 4 + 48) = vbYes Then t = 0 Else t = 1
If MsgBox("请选择分隔符！——<是>：分节符 <否>：分页符", 4 + 48) = vbYes Then j = 1 Else j = 0
If j = 1 Then
If MsgBox("每节页码！——<是>：重排 <否>：顺延", 4 + 48) = vbYes Then k = 1 Else k = 2
Else
k = 2
End If
Documents.Add
With Application.FileSearch
.NewSearch
.LookIn = p
.SearchSubFolders = True
If t = 0 Then .FileName = "*.doc" Else .FileName = "*.txt"
If .Execute > 0 Then
For i = 1 To .FoundFiles.Count
If t = 0 Then
Set doc = Documents.Open(FileName:=.FoundFiles(i), Visible:=False)
Else
Set doc = Documents.Open(FileName:=.FoundFiles(i), Encoding:=936, Visible:=False)
End If
doc.Content.Copy
doc.Close
Selection.EndKey 6
Selection.Paste
ActiveDocument.Characters(1).Copy
If j = 1 Then
Selection.InsertBreak Type:=wdSectionBreakNextPage
Else
Selection.InsertBreak Type:=wdPageBreak
End If
Next i
MsgBox "合并完毕！共合并 " & .FoundFiles.Count & " 个文件！", 0 + 64
Else
MsgBox "未发现文件！", 0 + 16
End If
End With
With ActiveDocument
.Characters.Last.Previous.Delete
.Characters.Last.Previous.Delete
'重排页码
For Each s In .Sections
s.Range.Select
删除页眉横线
s.Footers(wdHeaderFooterPrimary).Range.Delete
With Selection.Sections(1).Headers(1).PageNumbers
.NumberStyle = wdPageNumberStyleNumberInDash
If k = 1 Then .RestartNumberingAtSection = True Else .RestartNumberingAtSection = False
.StartingNumber = 1
End With
Selection.Sections(1).Footers(1).PageNumbers.Add PageNumberAlignment:=wdAlignPageNumberCenter, FirstPage:=True
ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageFooter
Selection.HeaderFooter.LinkToPrevious = Not Selection.HeaderFooter.LinkToPrevious
ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
Next
Selection.HomeKey 6
'奇数加页
Do
For Each s In .Sections
n = s.Range.Information(3)
n = n - m
m = m + n
If n Mod 2 = 1 Then
s.Range.Characters.Last.InsertBreak Type:=wdPageBreak
n = 0
m = 0
c = 1
Exit For
Else
c = 0
End If
Next
Loop Until c = 0
End With
End Sub
Sub 批量转换doc2txt()
If MsgBox("请将<AutoOpen>宏改名避免麻烦！是否继续？", 4 + 16) = vbNo Then End
On Error Resume Next
Dim fd As FileDialog, i&, j$, doc As Document, p$, t&
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
If fd.Show = -1 Then p = fd.SelectedItems(1) Else Exit Sub
Set fd = Nothing
If MsgBox("是否转换文件夹 " & p & " ?", 4 + 48) = vbNo Then End
j = MsgBox("<是>：doc2txt <否>：txt2doc <取消>：docx2doc", 3 + 48)
If j = vbYes Then
t = 1
ElseIf j = vbNo Then
t = 2
Else
t = 3
End If
With Application.FileSearch
.NewSearch
.LookIn = p
.SearchSubFolders = True
If t = 1 Then
.FileName = "*.doc"
ElseIf t = 2 Then
.FileName = "*.txt"
Else
.FileName = "*.docx"
End If
If .Execute > 0 Then
For i = 1 To .FoundFiles.Count
If t = 1 Then
Set doc = Documents.Open(FileName:=.FoundFiles(i), Visible:=False)
doc.SaveAs FileName:=Left(doc.FullName, Len(doc.FullName) - 4) & ".txt", FileFormat:=wdFormatText
ElseIf t = 2 Then
Set doc = Documents.Open(FileName:=.FoundFiles(i), ConfirmConversions:=False, Visible:=False)
doc.SaveAs FileName:=Left(doc.FullName, Len(doc.FullName) - 4), FileFormat:=wdFormatDocument
Else
Set doc = Documents.Open(FileName:=.FoundFiles(i), Visible:=False)
doc.SaveAs FileName:=Left(doc.FullName, Len(doc.FullName) - 5), FileFormat:=wdFormatDocument
End If
ActiveDocument.Close
Next i
MsgBox "转换完毕！共转换 " & .FoundFiles.Count & " 个文件！", 0 + 64
Else
MsgBox "未发现文件！", 0 + 16
End If
End With
End Sub
Sub 删除当前文档()
Dim i$, j$
With ActiveDocument
i = .FullName
If Not i Like "*:*" Then MsgBox "无法删除新建文档！", 0 + 16: End
j = InputBox("请输入 killfile（按确定/回车）删除！", "删除当前文档（不可恢复）", "")
If j = "killfile" Then
.Close savechanges:=wdDoNotSaveChanges
Kill i
End If
End With
End Sub
Sub aaaa自定义()
'热键
If Documents.Count = 0 Then Documents.Add
CustomizationContext = NormalTemplate
KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyF12, wdKeyAlt), KeyCategory:=wdKeyCategoryMacro, Command:="ToolsRecordMacroToggle"
KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyF5), KeyCategory:=wdKeyCategoryMacro, Command:="FileSave"
KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyF6), KeyCategory:=wdKeyCategoryMacro, Command:="FileClose"
KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyF7), KeyCategory:=wdKeyCategoryMacro, Command:="普通"
KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyF8), KeyCategory:=wdKeyCategoryMacro, Command:="公文"
KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyF9), KeyCategory:=wdKeyCategoryMacro, Command:="打印关闭不保存"
KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyF10), KeyCategory:=wdKeyCategoryMacro, Command:="打印N份关闭不保存"
KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyF11), KeyCategory:=wdKeyCategoryMacro, Command:="打印当前页"
KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyF2), KeyCategory:=wdKeyCategoryMacro, Command:="减少首行缩进"

'常用
Dim i&, arr
CommandBars("Standard").Reset

With CommandBars("Standard").Controls
.Add Type:=msoControlButton, ID:=26
.Add(Type:=msoControlButton, ID:=2201).FaceId = 476 '大/小写
.Add(Type:=msoControlButton, ID:=2793).FaceId = 252 '全/半角
arr = Array("宋体", "宋", "仿宋", "仿", "楷体", "楷", "黑体", "黑", "Times New Roman", "英")
For i = 0 To UBound(arr) Step 2
.Add(Type:=msoControlButton, ID:=2823, Parameter:=arr(i)).Caption = arr(i + 1)
Next i

arr = Array(4, 141, 7391, 247, 3462, 809)
For i = 0 To UBound(arr)
.Add Type:=msoControlButton, ID:=arr(i)
Next i

With .Add(Type:=msoControlPopup)
.BeginGroup = True
.Caption = "辅助"
End With
End With
'
With CommandBars("Standard").Controls("辅助").Controls
arr = Array("证书自动编号", "证书编号热键", "证书表格合并", "悬挂缩进热键", "行距热键", "间距热键", "缩放热键", "删行热键")
For i = 0 To UBound(arr)
With .Add(Type:=msoControlButton)
.Caption = arr(i)
.OnAction = arr(i)
End With
Next i

With .Add(Type:=msoControlButton)
.BeginGroup = True
.Caption = "默认纸张A4(2.54/3.17)"
.FaceId = 18
.OnAction = "PaperSetup"
End With

With .Add(Type:=msoControlButton)
.Caption = "删除当前文档"
.FaceId = 478
.OnAction = "删除当前文档"
End With

With .Add(Type:=msoControlButton)
.Caption = "标题自动编号"
.FaceId = 71
.OnAction = "Title2345AutoNum"
End With

arr = Array("本机排版", "发文字号", "清除格式", "标牌", "标签", "封面", "名单", "第一章", "千分位", "人民币中文大写", "m2m3上标", "断行相连", "姓名加空", "最后一磅", "删除空行", "删除图文框文本框", "doc2txt", "批量转换doc2txt", "批量排版", "批量打印", "批量合并")
For i = 0 To UBound(arr)
With .Add(Type:=msoControlButton)
.Caption = arr(i)
.OnAction = arr(i)
End With
Next i
End With

With CommandBars("Standard").Controls
With .Add(Type:=msoControlButton)
.BeginGroup = True
.Caption = "粘贴无格式文本"
.FaceId = 1100
.OnAction = "粘贴无格式文本"
End With

arr = Array("删除所有空格", 456, "切换页码", 127, "切换页眉", 762, "表格处理", 203, "切换标题副标题", 251, "取消网格", 217, "纵横转换", 1545, "另存为", 270, "关闭不保存", 1716, "重新打开", 688)
For i = 0 To UBound(arr) Step 2
With .Add(Type:=msoControlButton)
.Caption = arr(i)
.FaceId = arr(i + 1)
.OnAction = arr(i)
End With
Next i
End With

CommandBars("Formatting").Reset

With CommandBars("Formatting").Controls
arr = Array(62, 63, 57, 58)
For i = 0 To UBound(arr)
.Add Type:=msoControlButton, ID:=arr(i)
Next i

'"增加段前间距", 597
arr = Array("普通", 329, "公文", 417, "取消标题", 487, "缩减一行", 1060, "减少字符缩放", 163, "标准字符缩放", 158, "减少字符间距", 1355, "增加字符间距", 1353)
For i = 0 To UBound(arr) Step 2
With .Add(Type:=msoControlButton)
.Caption = arr(i)
.FaceId = arr(i + 1)
.OnAction = arr(i)
End With
Next i

.Add(Type:=msoControlButton, ID:=2226).FaceId = 219 '标准

arr = Array("减少一页", 173, "减少行距", 227, "增加行距", 692)
For i = 0 To UBound(arr) Step 2
With CommandBars("Formatting").Controls.Add(Type:=msoControlButton)
.Caption = arr(i)
.FaceId = arr(i + 1)
.OnAction = arr(i)
End With
Next i

.Add Type:=msoControlButton, ID:=699
.Add Type:=msoControlButton, ID:=698

With .Add(Type:=msoControlButton, ID:=756) '全选
.BeginGroup = True
.Caption = "全选"
.Style = msoButtonCaption
End With

arr = Array(54, 55, 56)
For i = 0 To UBound(arr)
.Add Type:=msoControlButton, ID:=arr(i)
Next i

.Add(Type:=msoControlButton, ID:=178).Style = msoButtonIcon '全屏
.Add Type:=msoControlButton, ID:=6 '页宽
.Add Type:=msoControlButton, ID:=5 '单页
CommandBars("Print Preview").Controls(4).Copy Bar:=CommandBars("Formatting") '多页
End With

'表格
CommandBars("Tables and Borders").Reset

With CommandBars("Tables and Borders").Controls
arr = Array(3918, 3681, 3683, 293, 3685, 3687, 294, 3907, 3908)
For i = 0 To UBound(arr)
.Add Type:=msoControlButton, ID:=arr(i)
Next i

arr = Array(803, "选定表格", 59, 3704, "表格属性", 276, 805, "标题行重复", 502, 808, "拆分表格", 531)
For i = 0 To UBound(arr) Step 3
With .Add(Type:=msoControlButton, ID:=arr(i))
.Caption = arr(i + 1)
.FaceId = arr(i + 2)
.Style = msoButtonIconAndCaption
End With
Next i

.Add(Type:=msoControlButton, ID:=332).FaceId = 1977

arr = Array("行高热键", 541, "行高微调热键", 3100, "自动复制", 703, "自动编号", 1095, "表格满页", 372, "表格缩行", 371, "行高循环", 3526, "外框加粗", 1705, "表格全选", 165)
For i = 0 To UBound(arr) Step 2
With .Add(Type:=msoControlButton)
.Caption = arr(i)
.FaceId = arr(i + 1)
.OnAction = arr(i)
End With
Next i
End With

'全屏
CommandBars("Full Screen").Reset
CommandBars("Full Screen").Controls.Add Type:=msoControlButton, ID:=6 '页宽
CommandBars("Full Screen").Controls.Add Type:=msoControlButton, ID:=5 '单页
CommandBars("Print Preview").Controls(4).Copy Bar:=CommandBars("Full Screen") '多页
End Sub

sandorn

关注

0
点赞
踩
3

收藏

觉得还不错? 一键收藏
0
评论
Word2003VBA 通用模板宏（2019元旦版）更新：2018-12-29

'http://club.excelhome.net/thread-1452376-1-1.htmlAttribute VB_Name = "NewMacros"Option ExplicitSub AutoOpen() On Error Resume Next Dim y$, x$, s As Section, i&amp;, j&amp; With Active...
复制链接

扫一扫