word 2010下，如何批量删除Work的页眉和页脚，然后存为PDF文档

待我称王封你为后i 2022-08-24 11:42 102阅读 0赞

今天有这个需要，就尝试写了一段宏。

目的是把一个目录下的所有的word文件的页眉页脚删除，然后存成PDF。

这样的好处是，在电纸书上看时，能清爽一些。

再加上，办公室里，闷得我喘不上气来，也只能放弃干活，把这个事解决一下吧。

找了几个文章，写出了如下的代码，因为我装的office 2010，所以只在2010上验证过。

另外，我没有把处理work和导出PDF写在一起，目前是两个函数。

Sub 删除页眉内容()
        Dim j As Section
        Dim y As HeaderFooter
        For Each j In ActiveDocument.Sections
            For Each y In j.Headers
                y.Range.Delete
                y.Range.ParagraphFormat.Borders(wdBorderBottom).LineStyle = wdLineStyleNone
            Next
        Next
    End Sub
    
    
    Sub 删除页脚内容()
        Dim j As Section
        Dim y As HeaderFooter
        For Each j In ActiveDocument.Sections
            For Each y In j.Footers
                y.Range.Delete
            Next
        Next
    End Sub

Sub 批量删除页眉页脚()
    
    
      Dim MyPath As String, i As Integer, myDoc As Document
      With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "选择要处理目标文件夹" & "——(删除里面所有Word文档的页眉页脚)"
        If .Show = -1 Then
          MyPath = .SelectedItems(1)
        Else
          Exit Sub
        End If
      End With
    
     ChangeFileOpenDirectory MyPath
     
        myfilename = Dir(MyPath & "\*.doc")
        Do While myfilename <> ""
            'MsgBox myfilename
            
    
            
            ''''''''''''''''''
    
    Dim curFileName
    curFileName = MyPath & "\" & myfilename
    
             Set 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.Save
            
            ActiveDocument.Close '退出
            '''''''''''''''''''
            
                  myfilename = Dir
            
        Loop
    End Sub

Public Function GetFileExtName(ByVal FileNameData As String) As String
        Dim strFileName As String
        
        strFileName = FileNameData
        
        If InStr(1, strFileName, ".") = 0 Then
            GetFileExtName = ""
        Else
            Dim iLenk
            iLenk = InStr(1, strFileName, ".")
            GetFileExtName = Left(strFileName, iLenk)
        End If
    End Function
    
    Sub 批量导出PDF()
    
    
      Dim MyPath As String, i As Integer, myDoc As Document
      With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "选择要处理目标文件夹" & "——(删除里面所有Word文档的页眉页脚)"
        If .Show = -1 Then
          MyPath = .SelectedItems(1)
        Else
          Exit Sub
        End If
      End With
    
     ChangeFileOpenDirectory MyPath
     
        myfilename = Dir(MyPath & "\*.doc")
        Do While myfilename <> ""
            'MsgBox myfilename
            
    
            
            ''''''''''''''''''
    
    Dim curFileName
    curFileName = MyPath & "\" & myfilename
    
             Set myDoc = Documents.Open(FileName:=curFileName, Visible:=True)
            
          
          Dim curPdfName
          curPdfName = 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:=False
       
    
            Application.DisplayAlerts = False '强制执行“是”
    
            
            ActiveDocument.Close '退出
           ' ActiveWindow.Close
            '''''''''''''''''''
            
                  myfilename = Dir
            
        Loop
    End Sub