今天有这个需要,就尝试写了一段宏。
目的是把一个目录下的所有的word文件的页眉页脚删除,然后存成PDF。
这样的好处是,在电纸书上看时,能清爽一些。
再加上,办公室里,闷得我喘不上气来,也只能放弃干活,把这个事解决一下吧。
找了几个文章,写出了如下的代码,因为我装的office 2010,所以只在2010上验证过。
另外,我没有把处理work和导出PDF写在一起,目前是两个函数。
Sub 删除页眉内容()Dim j As SectionDim y As HeaderFooterFor Each j In ActiveDocument.SectionsFor Each y In j.Headersy.Range.Deletey.Range.ParagraphFormat.Borders(wdBorderBottom).LineStyle = wdLineStyleNoneNextNext
End SubSub 删除页脚内容()Dim j As SectionDim y As HeaderFooterFor Each j In ActiveDocument.SectionsFor Each y In j.Footersy.Range.DeleteNextNext
End Sub
Sub 批量删除页眉页脚()Dim MyPath As String, i As Integer, myDoc As DocumentWith Application.FileDialog(msoFileDialogFolderPicker).Title = "选择要处理目标文件夹" & "——(删除里面所有Word文档的页眉页脚)"If .Show = -1 ThenMyPath = .SelectedItems(1)ElseExit SubEnd IfEnd WithChangeFileOpenDirectory MyPathmyfilename = Dir(MyPath & "\*.doc")Do While myfilename <> ""'MsgBox myfilename''''''''''''''''''Dim curFileName
curFileName = MyPath & "\" & myfilenameSet myDoc = Documents.Open(FileName:=curFileName, Visible:=True)删除页眉内容删除页脚内容' B可以替换的宏' 以下是处理格式所录制的宏,可根据所需录制''''''''''''''''
' 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 = wdSeekCurrentPageHeader
' Selection.WholeStory
' Selection.Delete Unit:=wdCharacter, Count:=1
' Selection.WholeStory
' With Selection.ParagraphFormat
' .Borders(wdBorderLeft).LineStyle = wdLineStyleNone
' .Borders(wdBorderRight).LineStyle = wdLineStyleNone
' .Borders(wdBorderTop).LineStyle = wdLineStyleNone
' .Borders(wdBorderBottom).LineStyle = wdLineStyleNone
' With .Borders
' .DistanceFromTop = 1
' .DistanceFromLeft = 4
' .DistanceFromBottom = 1
' .DistanceFromRight = 4
' .Shadow = False
' End With
' End With
' With Options
' .DefaultBorderLineStyle = wdLineStyleSingle
' .DefaultBorderLineWidth = wdLineWidth075pt
' .DefaultBorderColor = wdColorAutomatic
' End With
' If Selection.HeaderFooter.IsHeader = True Then
' ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageFooter
' Else
' ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
' End If
' Selection.WholeStory
' Selection.Delete Unit:=wdCharascter, Count:=1
' ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
' Selection.Sections(1).Footers(1).PageNumbers.Add PageNumberAlignment:= _
' wdAlignPageNumberRight, FirstPage:=True'''''''''''''''''''''''''''''''''''''''''''''''''''' 以上可以换成是你自己录制的宏' C公共部分的代码Application.DisplayAlerts = False '强制执行“是”'ActiveDocument.Saved = True'强制执行“否”Call ActiveDocument.SaveActiveDocument.Close '退出'''''''''''''''''''myfilename = DirLoop
End Sub
Public Function GetFileExtName(ByVal FileNameData As String) As StringDim strFileName As StringstrFileName = FileNameDataIf InStr(1, strFileName, ".") = 0 ThenGetFileExtName = ""ElseDim iLenkiLenk = InStr(1, strFileName, ".")GetFileExtName = Left(strFileName, iLenk)End If
End FunctionSub 批量导出PDF()Dim MyPath As String, i As Integer, myDoc As DocumentWith Application.FileDialog(msoFileDialogFolderPicker).Title = "选择要处理目标文件夹" & "——(删除里面所有Word文档的页眉页脚)"If .Show = -1 ThenMyPath = .SelectedItems(1)ElseExit SubEnd IfEnd WithChangeFileOpenDirectory MyPathmyfilename = Dir(MyPath & "\*.doc")Do While myfilename <> ""'MsgBox myfilename''''''''''''''''''Dim curFileName
curFileName = MyPath & "\" & myfilenameSet myDoc = Documents.Open(FileName:=curFileName, Visible:=True)Dim curPdfNamecurPdfName = GetFileExtName(curFileName) + "pdf"ActiveDocument.ExportAsFixedFormat OutputFileName:= _curPdfName _, ExportFormat:=wdExportFormatPDF, OpenAfterExport:=False, OptimizeFor:= _wdExportOptimizeForPrint, Range:=wdExportAllDocument, From:=1, To:=1, _Item:=wdExportDocumentContent, IncludeDocProps:=True, KeepIRM:=True, _CreateBookmarks:=wdExportCreateNoBookmarks, DocStructureTags:=True, _BitmapMissingFonts:=True, UseISO19005_1:=FalseApplication.DisplayAlerts = False '强制执行“是”ActiveDocument.Close '退出' ActiveWindow.Close'''''''''''''''''''myfilename = DirLoop
End Sub