Einzelne Seiten aus Word einzeln Abspeichern

'Pfad zu den Dokumenten  
Const strPathDocs = "C:\temp\docs"  
'ZielOrdner für die gesplitteten Dateien  
Const strAusgabeOrdner = "c:\temp\docs\ausgabe"  
'Logfile für eventuell auftretende Fehler  
Const strPathLogfile = "c:\temp\docs\logfile.txt"  
'Erweiterungen der Dateien die bearbeitet werden sollen  
arrFileExtensions = Array("doc","docx")  

Set fso = Wscript.CreateObject("Scripting.Filesystemobject")  
Set objWord = WScript.CreateObject("Word.Application")  
Set objShell = CreateObject("Wscript.Shell")  
Set regex = CreateObject("vbscript.regexp")  
regex.Pattern = "Seite (\d+) / (\d+)"  
Dim intDocCount, intErrCount
'Applikation anzeigen und eventuelle Dialoge für Batchbetrieb unterdrücken  
objWord.Visible = True
objWord.DisplayAlerts = -1
objWord.ScreenUpdating = False
'Im Ordner alle Word-Dokumente verarbeiten  
parseFolders fso.GetFolder(strPathDocs), False
'Das Anzeigen von Benachrichtigungen wieder aktivieren und Word schließen  
objWord.DisplayAlerts = -1
objWord.ScreenUpdating = True
objWord.Quit True
Set fso = Nothing
Set objWord = Nothing
Set regex = Nothing
If intErrCount = 0 Then
	MsgBox "Es wurden insgesamt " & intDocCount & " Dokumente verarbeitet.", vbInformation, "Verarbeitung abgeschlossen"  
Else
	MsgBox "Es wurden insgesamt " & intDocCount & " Dokumente verarbeitet." & vbCrLf & "Davon ist bei " & intErrCount & " Dokumenten ein Fehler aufgetreten!", vbInformation, "Verarbeitung abgeschlossen"  
	objShell.Run "Notepad.exe " & strPathLogfile  
End If

'Ende  

Function parseFolders(fldr, boolRecursion)
    For Each file In fldr.Files
    	For i = 0 To UBound(arrFileExtensions)
			If LCase(arrFileExtensions(i)) = LCase(fso.GetExtensionName(file.Path)) Then
				intDocCount = intDocCount + 1 
	            'Fehlerbehandlung für den Fall das ein Fehler beim Öffnen eines Dokumentes auftritt  
	            On Error Resume Next
	            Set objDoc = objWord.Documents.Open(file.Path)
	            If Err.Number <> 0 Then
	            	intErrCount = intErrCount + 1
	            	WriteLog "!!ERROR!! Fehler beim öffnen der Datei: -> '" & file.Path & "'"  
	            Else
	            	sBasename = fso.GetBaseName(file.Path)
				    sExtension = fso.GetExtensionName(file.Path)
				    sPath = fso.GetParentFolderName(file.Path)
				    If Not fso.FolderExists(strAusgabeOrdner) Then
				    	fso.CreateFolder(strAusgabeOrdner)
				    End If
	            	Set rngPage = objDoc.Range
	            	iCurrentPage = 1
	            	iSubDocCount = 1
	            	iPageCount = objDoc.Content.ComputeStatistics(2)
	            	
	            	Do Until iCurrentPage > iPageCount
				        For Each frame In rngPage.Frames
				            Set myMatches = regex.Execute(frame.Range.Text)
				            If myMatches.Count >= 1 Then
				                Set myMatch = myMatches(0)
				                If myMatch.SubMatches.Count >= 1 Then
				                    sectionpage = myMatch.SubMatches(0)
				                    sectioncount = myMatch.SubMatches(1)
				                    If sectionpage = sectioncount Then
				                        If iCurrentPage = iPageCount Then
				                            rngPage.End = objDoc.Range.End 
				                        Else
				                            objWord.Selection.GoTo wdGoToPage, wdGoToAbsolute, iCurrentPage + 1
				                            rngPage.End = objWord.Selection.Start
				                        End If
				                        rngPage.Copy
				                        Set docSingle = objWord.Documents.Add
				                        docSingle.Range.Paste
				                        If sectioncount = 1 Then
				                            docSingle.Range.Find.Execute "^m",,,,,,,,,""  
				                            docSingle.Range.Find.Execute "^b",,,,,,,,,""  
				                        End If
				                        strNewFileName = strAusgabeOrdner & "\" & sBasename & "_" & iSubDocCount & "." & sExtension  
				                        docSingle.SaveAs strNewFileName
				                        iCurrentPage = iCurrentPage + 1
				                        iSubDocCount = iSubDocCount + 1
				                        docSingle.Close
				                        rngPage.Collapse 0
				                    Else
				                        objWord.Selection.GoTo 1, 1, iCurrentPage + 1
				                        iCurrentPage = iCurrentPage + 1
				                        rngPage.Collapse 0
				                    End If
				                End If
				            End If
				        Next
				    Loop
	            	objDoc.Close False
	            	WriteLog "Dokument wurde verarbeitet: ->'" & file.Path & "'"  
	            End if
	            Exit For
	         End If
		Next
    Next
    
    'Funktion wird rekursiv aufrufen wenn das durchsuchen aller Unterordner gewünscht ist  
    If boolRecursion Then
		For Each subFolder in fldr.SubFolders
			parseFolders subFolder, True
		Next
	End If
End Function

Function WriteLog(strText)
	Set objLog = fso.OpenTextFile(strPathLogfile,8,True)
	logline = Now & " - " & strText  
	objLog.WriteLine(logline)
	objLog.Close
End Function