Extract specifc pages from word document

[YasserKhalil]

Hello everyone
I have file named `Source.doc` and I need to extract the pages from page 1 to page 6 only and save it as new word document but with the extension docx

[HansV]

Do you want to do this in Word? Or from Excel?

[YasserKhalil]

I am working from excel.

[HansV]

Code: Select all

Sub Test()
    Dim objWrd As Object
    Dim objDoc As Object
    Dim f As Boolean

    On Error Resume Next
    Set objWrd = GetObject(Class:="Word.Application")
    On Error GoTo ErrHandler
    If objWrd Is Nothing Then
        Set objWrd = CreateObject(Class:="Word.Application")
        f = True
    End If

    ' Modify the path
    Set objDoc = objWrd.Documents.Open(Filename:="C:\Word\Source.doc")
    With objDoc
        .Range(Start:=.Goto(What:=1, Which:=1, Count:=7).Start, End:=.Range.End).Delete
        .SaveAs2 Filename:=Replace(.FullName, ".doc", ".docx"), FileFormat:=12
    End With

ExitHandler:
    On Error Resume Next
    objDoc.Close SaveChanges:=False
    If f Then
        objWrd.Quit SaveChanges:=False
    End If
    Exit Sub

ErrHandler:
    MsgBox Err.Description, vbExclamation
    Resume ExitHandler
End Sub

[YasserKhalil]

Thank you very much. How to save the new file with the name `Output_1_To_6`

[HansV]

Change the

Filename:=Replace(.FullName, ".doc", ".docx")

part.

[YasserKhalil]

Thanks a lot
I have changed

Code: Select all

    With objDoc
        .Range(Start:=.Goto(What:=1, Which:=iStart, Count:=iEnd + 1).Start, End:=.Range.End).Delete
        .SaveAs2 Filename:=ThisWorkbook.Path & "\Output_" & iStart & "_To_" & iEnd, FileFormat:=12
    End With

But I am confused what this part refers to `What:=1`
Another point, in the word document output I got 7 pages (the 7th one is empty)

[HansV]

1 = wdGoToPage

Is this better?

Code: Select all

        .Range(Start:=.Goto(What:=1, Which:=iStart, Count:=iEnd + 1).Start - 1, End:=.Range.End).Delete

[HansV]

And you should keep Which:=1 (=wdGoToAbsolute)

[YasserKhalil]

Thank you very much. That is better now.
I tried to change the start and end `Const iStart As Long = 3, iEnd As Long = 6` but got an error `Value out of range`

[HansV]

What are you trying to do now?

[YasserKhalil]

I need to extract specific pages as range from page x to page y and save it to new file

[HansV]

Try this version:

Code: Select all

Sub Test()
    Extract DocName:="C:\Word\Source.doc", FirstPage:=3, LastPage:=6
End Sub

Sub Extract(DocName As String, FirstPage As Long, LastPage As Long)
    Dim objWrd As Object
    Dim objDoc As Object
    Dim f As Boolean
    Dim FirstPos As Long
    Dim LastPos As Long
    Dim fName As String

    On Error Resume Next
    Set objWrd = GetObject(Class:="Word.Application")
    On Error GoTo ErrHandler
    If objWrd Is Nothing Then
        Set objWrd = CreateObject(Class:="Word.Application")
        f = True
    End If

    Set objDoc = objWrd.Documents.Open(Filename:=DocName)
    With objDoc
        FirstPos = .Goto(What:=1, Which:=1, Count:=FirstPage).Start
        LastPos = .Goto(What:=1, Which:=1, Count:=LastPage + 1).Start - 1
        If LastPos < .Range.End Then
            .Range(Start:=LastPos, End:=.Range.End).Delete
        End If
        If FirstPos > 1 Then
            .Range(Start:=1, End:=FirstPos - 1).Delete
        End If
        fName = ThisWorkbook.Path & "\Output_" & FirstPage & "_To_" & LastPage
        .SaveAs2 Filename:=fName, FileFormat:=12
    End With

ExitHandler:
    On Error Resume Next
    objDoc.Close SaveChanges:=False
    If f Then
        objWrd.Quit SaveChanges:=False
    End If
    Exit Sub

ErrHandler:
    MsgBox Err.Description, vbExclamation
    Resume ExitHandler
End Sub

[YasserKhalil]

Amazing. Thank you very much.
In the output, I have the first page as empty one

[HansV]

Is this better?

Code: Select all

Sub Test()
    Extract DocName:="C:\Word\Source.doc", FirstPage:=3, LastPage:=6
End Sub

Sub Extract(DocName As String, FirstPage As Long, LastPage As Long)
    Dim objWrd As Object
    Dim objDoc As Object
    Dim f As Boolean
    Dim FirstPos As Long
    Dim LastPos As Long
    Dim fName As String

    On Error Resume Next
    Set objWrd = GetObject(Class:="Word.Application")
    On Error GoTo ErrHandler
    If objWrd Is Nothing Then
        Set objWrd = CreateObject(Class:="Word.Application")
        f = True
    End If

    Set objDoc = objWrd.Documents.Open(Filename:=DocName)
    With objDoc
        FirstPos = .Goto(What:=1, Which:=1, Count:=FirstPage).Start
        LastPos = .Goto(What:=1, Which:=1, Count:=LastPage + 1).Start - 1
        If LastPos < .Range.End Then
            .Range(Start:=LastPos, End:=.Range.End).Delete
        End If
        If FirstPos > 1 Then
            .Range(Start:=1, End:=FirstPos).Delete
        End If
        fName = ThisWorkbook.Path & "\Output_" & FirstPage & "_To_" & LastPage
        .SaveAs2 Filename:=fName, FileFormat:=12
    End With

ExitHandler:
    On Error Resume Next
    objDoc.Close SaveChanges:=False
    If f Then
        objWrd.Quit SaveChanges:=False
    End If
    Exit Sub

ErrHandler:
    MsgBox Err.Description, vbExclamation
    Resume ExitHandler
End Sub

[YasserKhalil]

The same weird problem. The first page in the output is extra page and empty !!

[HansV]

Could you attach a sample document?

[YasserKhalil]

Here's sample file as the original file is too large
https://www.mediafire.com/file/jjao5xtr ... t.zip/file

[HansV]

Yasser, this is frustrating. First you ask to extract pages 1 to 6, then any range of pages, and now it turns out that each page is a section, so you actually want to extract sections. If you had told us so at the beginning, the code would have been easier and the problem would have been solved by now.

Code: Select all

Sub Test()
    Extract DocName:="C:\Word\Source.doc", FirstSection:=3, LastSection:=6
End Sub

Sub Extract(DocName As String, FirstSection As Long, LastSection As Long)
    Dim objWrd As Object
    Dim objDoc As Object
    Dim objRng As Object
    Dim f As Boolean
    Dim i As Long
    Dim fName As String

    On Error Resume Next
    Set objWrd = GetObject(Class:="Word.Application")
    On Error GoTo ErrHandler
    If objWrd Is Nothing Then
        Set objWrd = CreateObject(Class:="Word.Application")
        f = True
    End If

    Set objDoc = objWrd.Documents.Open(FileName:=DocName)
    With objDoc
        For i = .Sections.Count To 1 Step -1
            If i < FirstSection Or i > LastSection Then
                .Sections(i).Range.Delete
            End If
        Next i    '
        ' Delete last section break
        Set objRng = .Range
        objRng.Collapse Direction:=0
        objRng.MoveStart Count:=-1
        If Asc(objRng) = 12 Then
            objRng.Delete
        End If
        fName = ThisWorkbook.Path & "\Output_" & FirstPage & "_To_" & LastPage
        .SaveAs2 FileName:=fName, FileFormat:=12
    End With

ExitHandler:
    On Error Resume Next
    objDoc.Close SaveChanges:=False
    If f Then
        objWrd.Quit SaveChanges:=False
    End If
    Exit Sub

ErrHandler:
    MsgBox Err.Description, vbExclamation
    Resume ExitHandler
End Sub

[YasserKhalil]

I am so sorry but I didn't know about sections. I am dealing with word documents as pages
Thank you very much for your great help. Now it is solved completely.