VBA中关于WORD的基本应用 比如批量改页眉页脚，从文件名取数字作为页眉等等。

VBA中关于WORD的基本应用
比如批量改页眉页脚，从文件名取数字作为页眉等等。

以下是代码，直接在Word的VBA编辑器里粘贴上去就OK了。

Sub 批量转PDF()
Dim i As Variant
Dim t As Variant
Dim str As String, n As Long, fd, Nam As String
On Error GoTo err '如果程序执行错误 跳转执行Err
Set fd = Application.FileDialog(msoFileDialogFolderPicker) '允许用户选择一个文件夹
With fd
.Title = “选择目标文件夹”
If .Show = -1 Then t = .SelectedItems(1) Else Exit Sub
End With
str = Dir(t & “*.doc*”)
While Len(str) > 0
n = n + 1
Documents.Open FileName:=t & IIf(Right(t, 1) = “”, “”, “”) & str
Nam = CreateObject(“Scripting.FileSystemObject”).getextensionname(str)
ActiveDocument.ExportAsFixedFormat OutputFileName:=(t & IIf(Right(t, 1) = “”, “”, “”) & Replace(str, Nam, “pdf”)), _
ExportFormat:=wdExportFormatPDF, OpenAfterExport:=False, OptimizeFor:= _
wdExportOptimizeForPrint, Range:=wdExportAllDocument, From:=1, To:=1, _
Item:=wdExportDocumentContent, IncludeDocProps:=True, KeepIRM:=True, _
CreateBookmarks:=wdExportCreateNoBookmarks, DocStructureTags:=True, _
BitmapMissingFonts:=True
ActiveDocument.Close False
str = Dir()
Wend
Set fd = Nothing
MsgBox (“已完成全部转换”)
err:
End Sub
Sub 文档保护()
Dim myDialog As FileDialog
Dim oFile As Variant
Dim oDoc As Document
Dim myResult As VbMsgBoxResult
Dim myPassWord As String
On Error Resume Next
myPassWord = “xyz” '此处双引号内设置自己的文档保护密码
'定义一个文件夹选取对话框
Set myDialog = Application.FileDialog(msoFileDialogFilePicker)
With myDialog
.Filters.Clear '清除所有文件筛选器中的项目
.Filters.Add “所有 WORD 文件”, “.doc", 1 '增加筛选器的项目为所有WORD文件
.AllowMultiSelect = True '允许多项选择
If .Show <> -1 Then Exit Sub
myResult = MsgBox(“选择是将进行对所选文件的设置文档保护,选择否将解除文档保护!”, vbYesNo)
For Each oFile In .SelectedItems '在所有选取项目中循环
Set oDoc = Documents.Open(FileName:=oFile, Visible:=False)
With oDoc
If myResult = vbYes Then '如果选择了进行文档保护
'如果该文档未经过保护则使用保护窗体(文档)功能
If .ProtectionType = wdNoProtection Then .Protect Type:=wdAllowOnlyComments, Password:=myPassWord
Else '如果选择了取消文档保护
'如果文档已使用了保护文档的功能,则解除文档保护
If .ProtectionType <> wdNoProtection Then .Unprotect myPassWord
End If
.Close True
End With
Next
End With
End Sub
Sub 批量操作WORD()
Dim path As String
Dim FileName As String
Dim worddoc As Document
Dim MyDir As String
MyDir = “C:\Users\Administrator\Desktop\第二版 (2) (1)” '文件夹路径根据需要自己修改，需要处理的文件都放该文件夹内
FileName = Dir(MyDir & "*.doc”, vbNormal)
Do Until FileName = “”
If FileName <> ThisDocument.name Then
Set worddoc = Documents.Open(MyDir & “” & FileName)
worddoc.Activate
Call 宏4 '调用宏,换成你自己宏的名字
’ 宏1() 改页边距和页眉页脚距离，不涉及页面方向
’ 宏2() 去页脚,运行两次
’ 宏3() 替换年月日，具体替换成什么，自己去设置
’ 宏4() 加页码
’ 宏5() 插入表格，在运行前，先把要插入的复制到剪切板
’ 宏6() 刷新域，未完成
’ 宏7() 变编号
’ 宏8() 文档加密，密码为xyz
’ 宏9() 文档保护,密码为xyz

     worddoc.Close True
     FileName = Dir()
End If

Loop
Set worddoc = Nothing
MsgBox “修改完毕!请查看！！”, vbInformation
End Sub
Sub 宏1() '页边距，我这个是窄页边距，页眉0.7，页脚0.8
’
’ 宏1 宏 改页边距和页眉页脚距离，不涉及页面方向
’
’
Selection.WholeStory
With ActiveDocument.Styles(wdStyleNormal).Font
If .NameFarEast = .NameAscii Then
.NameAscii = “”
End If
.NameFarEast = “”
End With
With ActiveDocument.PageSetup
.LineNumbering.Active = False
.TopMargin = CentimetersToPoints(1.27)
.BottomMargin = CentimetersToPoints(1.27)
.LeftMargin = CentimetersToPoints(1.27)
.RightMargin = CentimetersToPoints(1.27)
.Gutter = CentimetersToPoints(0)
.HeaderDistance = CentimetersToPoints(0.7)
.FooterDistance = CentimetersToPoints(0.8)
.FirstPageTray = wdPrinterDefaultBin
.OtherPagesTray = wdPrinterDefaultBin
.SectionStart = wdSectionNewPage
.OddAndEvenPagesHeaderFooter = False
.DifferentFirstPageHeaderFooter = False
.VerticalAlignment = wdAlignVerticalTop
.SuppressEndnotes = False
.MirrorMargins = False
.TwoPagesOnOne = False
.BookFoldPrinting = False
.BookFoldRevPrinting = False
.BookFoldPrintingSheets = 1
.GutterPos = wdGutterPosLeft
.LayoutMode = wdLayoutModeLineGrid
End With
ActiveDocument.Save
End Sub

Sub 宏2() '去页脚
’
’ 宏3 宏 只能去除一行页脚，可以重复运行一下
’
’
If ActiveWindow.View.SplitSpecial <> wdPaneNone Then
ActiveWindow.Panes(2).Close
End If
If ActiveWindow.ActivePane.View.Type = wdNormalView Or ActiveWindow. _
ActivePane.View.Type = wdOutlineView Then
ActiveWindow.ActivePane.View.Type = wdPrintView
End If
ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageFooter
Selection.EndKey Unit:=wdLine, Extend:=wdExtend
Selection.TypeBackspace
ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
ActiveDocument.Save
End Sub
Sub 宏3() '替换年月日
’
’ 替换年月日 宏
’
’
Selection.find.ClearFormatting
Selection.find.Replacement.ClearFormatting
With Selection.find
.Text = “???年月日”
.Replacement.Text = “2019年4月18日”
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchByte = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = True
End With
Selection.find.Execute Replace:=wdReplaceAll
ActiveDocument.Save
End Sub
Sub 宏4() '加页码
’
’ 加页码 宏

If ActiveWindow.View.SplitSpecial <> wdPaneNone Then
ActiveWindow.Panes(2).Close
End If
If ActiveWindow.ActivePane.View.Type = wdNormalView Or ActiveWindow. _
ActivePane.View.Type = wdOutlineView Then
ActiveWindow.ActivePane.View.Type = wdPrintView
End If
ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageFooter
Application.Templates( _
“C:\Users\Administrator\AppData\Roaming\Microsoft\Document Building Blocks\2052\15\Built-In Building Blocks.dotx” _
).BuildingBlockEntries(“加粗显示的数字 2”).Insert Where:=Selection.Range, _
RichText:=True
ActiveDocument.Save
ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
ActiveDocument.Save
End Sub
Sub 宏5() '插入表格，插入的东西运行前要复制一下
’
’ 插入表格 宏
’
’
Selection.EndKey Unit:=wdLine
Selection.PasteAndFormat (wdFormatOriginalFormatting)
Selection.WholeStory
Selection.Fields.Update
ActiveDocument.Save
End Sub

Sub 宏7() '变编号页眉编号变化

Dim mysec As Section
For Each mysec In ActiveDocument.Sections
mysec.Headers(1).Range.Text = Replace(Replace(mysec.Headers(1).Range.Text, “-04/00-”, “-04/01-”), Chr(13), “”)
mysec.Headers(1).Range.Text = Replace(Replace(mysec.Headers(1).Range.Text, “-03/03-”, “-04/00-”), Chr(13), “”)
mysec.Headers(1).Range.Text = Replace(Replace(mysec.Headers(1).Range.Text, “-03/02-”, “-03/03-”), Chr(13), “”)
mysec.Headers(1).Range.Text = Replace(Replace(mysec.Headers(1).Range.Text, “-03/01-”, “-03/02-”), Chr(13), “”)
mysec.Headers(1).Range.Text = Replace(Replace(mysec.Headers(1).Range.Text, “-03/00-”, “-03/01-”), Chr(13), “”)
mysec.Headers(1).Range.Text = Replace(Replace(mysec.Headers(1).Range.Text, “-02/03-”, “-03/00-”), Chr(13), “”)
mysec.Headers(1).Range.Text = Replace(Replace(mysec.Headers(1).Range.Text, “-02/02-”, “-02/03-”), Chr(13), “”)
mysec.Headers(1).Range.Text = Replace(Replace(mysec.Headers(1).Range.Text, “-02/01-”, “-02/02-”), Chr(13), “”)
mysec.Headers(1).Range.Text = Replace(Replace(mysec.Headers(1).Range.Text, “-02/00-”, “-02/01-”), Chr(13), “”)
mysec.Headers(1).Range.Text = Replace(Replace(mysec.Headers(1).Range.Text, “-01/03-”, “-02/00-”), Chr(13), “”)
mysec.Headers(1).Range.Text = Replace(Replace(mysec.Headers(1).Range.Text, “-01/02-”, “-01/03-”), Chr(13), “”)
mysec.Headers(1).Range.Text = Replace(Replace(mysec.Headers(1).Range.Text, “-01/01-”, “-01/02-”), Chr(13), “”)
mysec.Headers(1).Range.Text = Replace(Replace(mysec.Headers(1).Range.Text, “-01/00-”, “-01/01-”), Chr(13), “”)
Next
ActiveDocument.Save
End Sub
Sub 宏8() '文档加密
With OptionsAllowFastSave = True
BackgroundSave = True
creatbackup = False
SavePropertiesPrompt = False
SaveInterval = 10
SaveNormalPrompt = False
End With
With ActiveDocument
.ReadOnlyRecommended = False
.SaveFormsData = False
.SaveSubsetFonts = False
'.Password = “123456”
.WritePassword = “xyz”
End With
Application.DefaultSaveFormat = “”

End Sub
Sub 宏9() '文档保护
’
’ 宏11 宏
’
’
ActiveDocument.Protect Password:=“xyz”, NoReset:=False, Type:= _
wdAllowOnlyReading, UseIRM:=False, EnforceStyleLock:=False
ActiveDocument.Save
End Sub

Sub 宏12() '与文件编号合上,这个是用了正则表达式的，建议先看一下这个链接https://blog.csdn.net/huzhizhewudi/article/details/84556475
’
’ 宏12 宏
’
Dim reg As New RegExp
With reg

.Global = True

.IgnoreCase = True

.MultiLine = False

.Pattern = “-JS-[0-9]” '匹配一个-JS-数字的字符串
End With
Dim mysec As Section
Dim n As String
Dim n1 As String
Dim n2 As String
Dim x As String
n = ActiveDocument.name’提取文件名字符串到n
n1 = str(Val(n))'提取字符串n的数字部分
i = Len(n1)'计算n1的长度
x = String(4 - i, “0”) & n1’n1在左边用0补足3位
n2 = “-JS-” & x
n2 = Replace(n2, " ", “”)'去掉字符串n2的空格
For Each mysec In ActiveDocument.Sections
mysec.Headers(1).Range.Text = Replace(reg.Replace(mysec.Headers(1).Range.Text, n2), Chr(13), “”)
Next
ActiveDocument.Save
End Sub

Sub 宏11() ’ 重置页眉为01/00,这个是用了正则表达式的，建议先看一下这个链接https://blog.csdn.net/huzhizhewudi/article/details/84556475
If ActiveWindow.View.SplitSpecial <> wdPaneNone Then ActiveWindow.Panes(2).Close
With ActiveWindow.ActivePane.View
.Type = wdPrintView
.SeekView = wdSeekCurrentPageHeader
Selection.WholeStory
Selection.Delete Unit:=wdCharacter, Count:=1
Selection.TypeText Text:="************************ 技术部 编号：NFSK/QT-JS-120-01/00-****"
.SeekView = wdSeekMainDocument
End With

WordBasic.ViewFooterOnly
Selection.WholeStory
Selection.Delete Unit:=wdCharacter, Count:=1
Selection.TypeText Text:="************************ 技术部 编号：NFSK/QT-JS-120-01/00-****"
ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument

Dim reg As New RegExp
With reg

.Global = True

.IgnoreCase = True

.MultiLine = False

.Pattern = “-JS-[0-9]” '匹配所有非汉字、非数字0-9、非字母
End With
Content = reg.Replace(Content, “,”) '将匹配的内容用英文状态逗号替换
Dim mysec As Section
Dim n As String
Dim n1 As String
Dim n2 As String
Dim x As String
n = ActiveDocument.name
n1 = str(Val(n))
i = Len(n1)
x = String(4 - i, “0”) & n1
n2 = “-JS-” & x
n2 = Replace(n2, " ", “”)
For Each mysec In ActiveDocument.Sections
mysec.Headers(1).Range.Text = Replace(reg.Replace(mysec.Headers(1).Range.Text, n2), Chr(13), “”)
Next

ActiveDocument.Save
End Sub