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

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