locked
Unwanted blank pages when splitting a word document into separate pages RRS feed

  • Question

  • Hi experts,

    below you'll find a routine to divide a merged document into separate pages, copied from the internet. Every 2 pages are to be combined into a new document.

    The problem, i cannot solve, is that each newly created document get 2 extra blank pages, except for the last document. That one only contains the first page and has one extra blank page.

    Any help would be highly appreciated,

    Piet

    routine:

    Sub mySplitIntoPages()
    Dim docMultiple As Document
    Dim docSingle As Document
    Dim rngPage As Range
    Dim iCurrentPage As Integer
    Dim iPageCount As Integer
    Dim strNewFileName As String
    Dim DocNum As Integer
        
      Application.ScreenUpdating = False 'Makes the code run faster and reduces screen flicker a bit.
        Set docMultiple = ActiveDocument 'Work on the active document _
        (the one currently containing the Selection)
        Set rngPage = docMultiple.Range 'instantiate the range object
        iCurrentPage = 1
         'get the document's page count
        iPageCount = docMultiple.Content.ComputeStatistics(wdStatisticPages)
    On Error GoTo CopyFailed
        Do Until iCurrentPage > iPageCount
            If iCurrentPage >= iPageCount Then
                rngPage.End = docMultiple.Range.End 'last page (there won't be a next page)
            Else
                 'Find the beginning of the next page
                 'Must use the Selection object. The Range.Goto method will not work on a page
                Selection.GoTo wdGoToPage, wdGoToAbsolute, iCurrentPage + 2
                 'Set the end of the range to the point between the pages
                rngPage.End = Selection.Start
            End If
            rngPage.Copy 'copy the page into the Windows clipboard
            Set docSingle = Documents.Add 'create a new document
            'paste the clipboard contents to the new document
            docSingle.Range.PasteAndFormat (wdFormatOriginalFormatting)
             'remove any manual page break to prevent a second blank
            docSingle.Range.Find.Execute Findtext:="^m", ReplaceWith:=""
            DocNum = DocNum + 1
          
          strNewFileName = GetTextFromWordDoc(docSingle, "onder vermelding van: contributienota ", ".")
          'build a new sequentially-numbered file name based on the original multi-paged file name and path
          strNewFileName = Replace(docMultiple.FullName, ".doc", "myS_" & strNewFileName & ".doc")
    '        build a new sequentially-numbered file name based on the original multi-paged file name and path
          docSingle.SaveAs2 FileName:=strNewFileName, FileFormat:= _
            wdFormatXMLDocument, LockComments:=False, Password:="", AddToRecentFiles _
            :=True, WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts _
            :=False, SaveNativePictureFormat:=False, SaveFormsData:=False, _
            SaveAsAOCELetter:=False, CompatibilityMode:=15
            
            iCurrentPage = iCurrentPage + 2 'move to the next page
            docSingle.Close 'close the new document
            rngPage.Collapse wdCollapseEnd 'go to the next page
        Loop 'go to the top of the do loop
        Application.ScreenUpdating = True 'restore the screen updating
        GoTo CopyFailed
    CopyFailed:
         'Destroy the objects.
        Set docMultiple = Nothing
        Set docSingle = Nothing
        Set rngPage = Nothing
        Application.Quit savechanges:=wdDoNotSaveChanges
    End
    End Sub

    Tuesday, June 28, 2016 5:36 AM

All replies

  • I haven't looked at your code but one possibility is the margins on the document you are creating are smaller than the document you are extracting from.  Change the margins on the new document and see if the pages go away.
    Tuesday, June 28, 2016 11:27 PM
  • problem solved: now module looks like this:

    Option Explicit
    '***************************************************************************
    '* Module SplitDocIntoPages                                                *
    '*                                                                         *
    '* aan de hand van 'NOP_Doc' wordt een Word document                       *
    '* gesplitst in separate documenten.                                       *
    '*                                                                         *
    '* 'NOP_Doc' = het aantal pagina's dat het separate document zal bevatten  *
    '*                                                                         *
    '* 'sTextToFind' : tekst tussen deze 2 strings vormt de bestandsnaam       *
    '* 'eTextToFind' : voor het gesplitste, nieuwe document                    *
    '*  Opm: beide tekens én de tussenliggende tekst worden onzichtbaar door   *
    '*       ze af te drukken in de kleur van het papier, in dit geval wit!    *
    '*                                                                         *
    '*  'sSubDir' : subdirectory waarin nieuwe documenten worden opgeslagen en *
    '*              moet aanwezig zijn!                                        *
    '*                                                                         *
    '***************************************************************************
    Public Const NOP_Doc As Integer = 2
    Public Const sTextToFind As String = "<:"
    Public Const eTextToFind As String = ":>"
    Public Const sSubDir As String = "Brieven"
    
    Sub SplitIntoPages_V1()
    ' courtesy of: http://www.vbaexpress.com/kb/getarticle.php?kb_id=727
    Dim docMultiple As Document
    Dim docSingle As Document
    Dim rngPage As Range
    Dim iCurrentPage As Integer
    Dim iPageCount As Integer
    Dim strNewFileName As String
    
      Application.ScreenUpdating = False
      
      Set docMultiple = ActiveDocument
      Set rngPage = docMultiple.Range
      iCurrentPage = 1
      
      'get document page count
      iPageCount = Selection.Information(wdNumberOfPagesInDocument)
      
      Do Until iCurrentPage > iPageCount
      
        Selection.GoTo What:=wdGoToPage, Which:=wdGoToAbsolute, Count:=iCurrentPage
        Set rngPage = Selection.Range
        If Not ((iCurrentPage + NOP_Doc) >= iPageCount) Then
          Selection.GoTo What:=wdGoToPage, Which:=wdGoToAbsolute, Count:=iCurrentPage + (NOP_Doc)
        Else
          Selection.EndKey Unit:=wdStory
        End If
        rngPage.End = Selection.Range.End
        rngPage.Select
        
        rngPage.Copy 'copy the page into the Windows clipboard
        Set docSingle = Documents.Add 'create a new document
          'docSingle.Range.Paste 'paste the clipboard contents to the new document
          docSingle.Range.PasteAndFormat (wdFormatOriginalFormatting)
          'create name for new document based on the original multi-paged path
          strNewFileName = docMultiple.Path & Application.PathSeparator & _
                           sSubDir & Application.PathSeparator & _
                           GetTextFromWordDoc(docSingle, sTextToFind, eTextToFind)
          docSingle.SaveAs2 FileName:=strNewFileName, FileFormat:= _
                            wdFormatXMLDocument, LockComments:=False, Password:="", AddToRecentFiles _
                            :=True, WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts _
                            :=False, SaveNativePictureFormat:=False, SaveFormsData:=False, _
                            SaveAsAOCELetter:=False, CompatibilityMode:=15
          
          ClearLastPage
          
          docSingle.Close True 'close the new document
        
        iCurrentPage = iCurrentPage + NOP_Doc 'move to the next page
        rngPage.Collapse wdCollapseEnd 'go to the next page
      Loop 'go to the top of the do loop
    
      'Destroy the objects.
      Set docMultiple = Nothing
      Set docSingle = Nothing
      Set rngPage = Nothing
    
      Application.ScreenUpdating = True 'restore the screen updating
    
    End Sub
    
    Function GetTextFromWordDoc(ByVal theDoc As Document, ByVal StartText As String, ByVal EndText As String) As String
    Dim rng1 As Range
    Dim rng2 As Range
    Dim strTheText As String
      GetTextFromWordDoc = ""
      Set rng1 = theDoc.Range
      If rng1.Find.Execute(FindText:=StartText) Then
          Set rng2 = theDoc.Range(rng1.End, theDoc.Range.End)
          If rng2.Find.Execute(FindText:=EndText) Then
              strTheText = theDoc.Range(rng1.End, rng2.Start).Text
              GetTextFromWordDoc = strTheText
          End If
      End If
    End Function
    
    Sub Clearpages()
        Dim rgePages As Range
        Dim PageCount As Integer
        PageCount = ActiveDocument.ComputeStatistics(wdStatisticPages)
        Selection.GoTo What:=wdGoToPage, Which:=wdGoToAbsolute, Count:=PageCount
        Set rgePages = Selection.Range
        Selection.EndKey Unit:=wdStory
        rgePages.End = Selection.Range.End
        rgePages.Delete
    End Sub
    
    Sub ClearLastPage()
    ' courtesy of: http://www.vbforums.com/showthread.php?665766-RESOLVED-VBA-Deleting-last-page-in-document
    Dim strt
    Dim r As Range
        With ActiveDocument
            strt = .GoTo(wdGoToPage, wdGoToLast).Start
            Set r = .Range(strt - 1, .Range.End)
            r.Delete
        End With
    End Sub
    
    
    

    Monday, November 21, 2016 12:46 PM