Splitsen van word document in afzonderlijke docs met ongewilde lege pagina op einde

[Pieteke]

geachte experts,
Met de onderstaande macro lukt het me prima een groot document te splitsen in een aantal kleinere. Echter doordat bij Documents.Add een carriage return wordt geplaatst in het nieuwe document en met .Range.PasteAndFormat (wdFormatOriginalFormatting) de selectie hiervoor wordt geplaatst, ontstaat een ongewilde lege pagina.
Het probleem is dat ik met geen mogelijkheid die pagina kan verwijderen. Weet u raad?

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()
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
      Clearpages
      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

 

[OctaFish]

Er ontbreekt minstens één functie (GetTextFromWordDoc). Dus het is nogal lastig om te controleren wat er verkeerd gaat.

 

[Pieteke]

Beste OctaFish,

fijn dat u reageert.
Inmiddels heb ik het originele bericht aangepast.
De volledige module staat er nu als code. Ook heb ik als bijlage het test document bijgevoegd.
De ingebedde sub Clearpages() doet niet wat ik zou verwachten, nl de 3de (lege) pagina deleten.
Met andere woorden: als ik met dit bestandje test krijg ik keurig 4 separate documenten in subdir "Brieven".
Alleen hebben ze allemaal één overbodige, lege 3de pagina. Die zou ik graag verwijderd zien.

Voeg volgende opmerkingen toe:
Met de regel Set docSingle = Documents.Add wordt het nieuwe document gemaakt met 1 blanke pagina (logisch toch?)
Door regel docSingle.Range.PasteAndFormat (wdFormatOriginalFormatting) wordt de geselecteerde data geplaatst vóór deze blanke pagina. Zo lijkt het tenminste...

Alvast bedankt voor de te nemen moeite,
Piet

 

[OctaFish]

Je ziet het effect van je macro verkeerd. Word maakt geen aparte pagina aan, maar plakt je tekst vóórin de 1e alinea. Omdat je tekst plakt die precies één pagina beslaat, is het resultaat dus één pagina + extra alinea. En dat past niet meer op één pagina. Dus krijg je een tweede pagina.
Als je jouw macro (enigszins aangepast zodat hij beter werkt) loslaat op een willekeurige tekst die gewoon doorloopt over zeg 8 pagina's dan zul je zien dat een pagina die niet op een alinea-einde eindigt (alinea loopt dus door naar de volgende pagina) perfect gaat. Omdat een alinea per definitie altijd een alinea-einde heeft, en je in dit geval dus de tekst kopieert zonder, wordt de tekst automatisch opgenomen in de alinea van het nieuwe document. Pas als de laatste alinea van de gekopieerde pagina eindigt met een alinea-einde, gaat het fout want dan schuift de alinea van het nieuwe document dus door. Dat is dus in het kort de verklaring.

Je zou dat op kunnen lossen door na het plakken de cursor naar het eind te verplaatsen en een Backspace te geven. Zijn twee standaard commando' dus die kun je in de macro opnemen.

 

[Pieteke]

probleem opgelost!

met onderstaande routine wordt de laatste pagina van een document verwijderd, al dan niet met tekst er op.

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