Remove first six pages and last page from folder of Word files.

[H1SOKA]

Hey guys,

I have a quick question for someone who is experienced with Word macros.

I have a folder of Word files that need the first six pages of the documents deleted. I also need the last page of each document removed as well.

Does anyone have a macro like this laying around?

It just needs to remove the first 6 pages and the last page, and be able to run on a large folder of files.

Thanks in advance.

 

[Fredrik1987]

Re: Remove first six pages and last page from folder of .word files.

I'm far from any expert, if the MVP's (or anyone else) have a different solution, I'd recommend the one they use
Did a quick read on pages in Word, it seems like pages isn't really a recognized as a range... so if a table spans more than one page this method can be rather unpredictable.

Rember to do a backup of the files
Should work fine, perhaps a bit slow though

Option Explicit




'/  Activate these References;
'   1.  Microsoft scripting runtime
'   2.  Microsoft shell conrols and automation




Dim rng_Page As Word.Range
Dim rng_Delete As Word.Range
Dim rng_LastPage As Word.Range






Sub RemovePages()




Dim MyDir As String
Dim Key As Variant
Dim MyDoc As Word.Document




MyDir =  'Parent folder path




For Each Key In FilesFromFolder(MyDir)
    Set MyDoc = Documents.Open(FileName:=Key, Visible:=False)




    FirstSix(MyDoc).Delete
    LastPage(MyDoc).Delete
    
    
    MyDoc.Close wdSaveChanges, wdOriginalDocumentFormat
    
    
Next




End Sub






'/  Returs first six pages in the document
'/  This could be errorprone, bookmark "\page" can return incorrectly if tables etc. spans several pages
Private Function FirstSix( _
WordDoc As Word.Document _
) As Word.Range




On Error Resume Next
Dim int_Page As Long: int_Page = 1




Do While int_Page <= 6
    If Err.Number <> 0 Then Exit Do
    
    
    With WordDoc
        
        Set rng_Page = .GoTo(What:=wdGoToPage, Name:=int_Page)
        Set rng_Page = rng_Page.GoTo(What:=wdGoToBookmark, Name:="\page")
        
        
        If int_Page = 1 Then
        
        
            Set rng_Delete = rng_Page
        
    
        Else
            
            
            rng_Delete.SetRange rng_Delete.Start, rng_Page.End
        
            
        
        End If
    End With
    int_Page = int_Page + 1
Loop




Set FirstSix = rng_Delete




End Function






Private Function LastPage( _
WordDoc As Word.Document _
) As Word.Range




With WordDoc




    Set rng_LastPage = .GoTo(What:=wdGoToPage, Name:=WordDoc.Range.Information(wdNumberOfPagesInDocument))
    Set rng_LastPage = rng_LastPage.GoTo(What:=wdGoToBookmark, Name:="\page")
    rng_LastPage.SetRange rng_LastPage.Start - 1, rng_LastPage.End


    
End With




Set LastPage = rng_LastPage




End Function






'/  Add File if file type contains the phrase "Word"
Private Function FilesFromFolder( _
ParentDir As String _
) As Scripting.Dictionary




Dim obj_Shell As New Shell32.Shell
Dim Folder As Shell32.Folder
Dim Item As Shell32.FolderItem
Dim dict_Temp As New Scripting.Dictionary




If ParentDir = "" Then Exit Function






For Each Item In obj_Shell.Namespace(ParentDir).Items
    If Item.IsFolder = True Then
    
    
        Call FilesFromFolder(Item.Path)     '/  Include files in subfolders
        
        
    Else
    


        If dict_Temp.Exists(Item.Name) = False Then
            If InStr(1, Item.Type, "Word", vbTextCompare) >= 1 Then
            
            
                dict_Temp.Add Item.Path, Item
            
            
            End If
        End If
    End If
Next




Set FilesFromFolder = dict_Temp




End Function

 

[Macropod]

Re: Remove first six pages and last page from folder of .word files.

Does anyone have a macro like this laying around?

It just needs to remove the first 6 pages and the last page, and be able to run on a large folder of files.

Yeah, we all keep esoteric macros lying around ...

What happens if a given document contains less than 8 pages? Are there any Section breaks, headers or footers involved? Are you aware that what constitutes a 'page' is determined by the active printer driver - which means that the same macro could return different results depending on which printer driver is in use?

 

[Fredrik1987]

Re: Remove first six pages and last page from folder of .word files.

Well, I wasn't aware of any of that, guess thats why you're the MVP and I'm the newbie

 

[Macropod]

Re: Remove first six pages and last page from folder of .word files.

Your reply doesn't address any of the issues I raised. The following macro will delete the last and first 6 pages of any document in the chosen folder - subject to the caveat about what constitutes a 'page' being determined by the active printer driver.

Sub TrimDocuments()
Application.ScreenUpdating = False
Dim strFolder As String, strFile As String, strDocNm As String, wdDoc As Document, Rng As Range
strDocNm = ActiveDocument.FullName
strFolder = GetFolder
If strFolder = "" Then Exit Sub
strFile = Dir(strFolder & "\*.doc", vbNormal)
While strFile <> ""
  If strFolder & "\" & strFile <> strDocNm Then
    Set wdDoc = Documents.Open(FileName:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
    With wdDoc
      If .ComputeStatistics(wdStatisticPages) < 8 Then
        .Range.Delete
      Else
        Set Rng = .Range.GoTo(What:=wdGoToPage, Name:=.ComputeStatistics(wdStatisticPages))
        Set Rng = Rng.GoTo(What:=wdGoToBookmark, Name:="\page")
        Rng.Delete
        Set Rng = .Range.GoTo(What:=wdGoToPage, Name:=6)
        Set Rng = Rng.GoTo(What:=wdGoToBookmark, Name:="\page")
        Rng.Start = .Range.Start
        Rng.Delete
      End If
      .Close SaveChanges:=True
    End With
  End If
  strFile = Dir()
Wend
Set wdDoc = Nothing
Application.ScreenUpdating = True
End Sub

Function GetFolder() As String
Dim oFolder As Object
GetFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function