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
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)
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 <> 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() '变编号页眉编号变化
豫公网安备41160202000603
站长QQ:729038198
关于我们
投诉建议