word 2010下，如何批量删除Work的頁眉和頁腳，然後存為PDF文檔

今天有這個需要，就嘗試寫了一段宏。

目的是把一個目錄下的所有的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