Makro

Sub SplitDocs()
Dim dirBase As String
Dim fileDir As String
Dim strFileName As String
Dim docNew As Document
Dim pdfjob As PDFCreator.clsPDFCreator
 
    ' Used to set criteria for moving through the document by section.
    Application.Browser.Target = wdBrowseSection
    strName = InputBox(Prompt:="Jm�no souboru:", _
            Title:="Vlo�te jm�no souboru", Default:="")
        If strName = vbNullString Then
            Exit Sub
        End If
                      
    Dim selectCount As Integer
    Application.FileDialog(msoFileDialogFolderPicker).Title = "Vyberte slo�ku do n� se m� ulo�it v�stup"
    selectCount = Application.FileDialog(msoFileDialogFolderPicker).Show
    If (selectCount <> 0) Then
        dirBase = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1) + "\"
        Else: Exit Sub
    End If
    'A mailmerge document ends with a section break next page.
    'Subtracting one from the section count stop error message.
    Set sourceDoc = ActiveDocument
    For i = 1 To ((sourceDoc.Sections.Count) - 1)
        'Select and copy the section text to the clipboard
        Set Section = sourceDoc.Sections.Item(i)
        'Create a new document to paste text from clipboard.
        Set docNew = Documents.Add
        
        
        docNew.Styles(wdStyleNormal).ParagraphFormat.SpaceAfter = 0
        docNew.Styles(wdStyleNormal).ParagraphFormat.LineSpacingRule = wdLineSpaceSingle
        docNew.Range.FormattedText = Section.Range.FormattedText
            
        Dim regEx, Match, Matches
        Dim pagesTo As Integer
        Set regEx = New RegExp
    'regEx.Pattern = "d: (\d{4,6})"
    regEx.Pattern = "nta: ([A-Z]\d{4,6})"
    regEx.IgnoreCase = False
    regEx.Global = True
    
    Set Matches = regEx.Execute(docNew.Range.Text)
    If Matches.Count = 1 Then
    If Matches(0).SubMatches.Count = 1 Then
    fileDir = dirBase & Trim(Matches(0).SubMatches(0))
            On Error Resume Next
            MkDir fileDir
            On Error GoTo 0
            ChangeFileOpenDirectory fileDir
            
            docNew.Repaginate
            pagesTo = ActiveDocument.BuiltInDocumentProperties(wdPropertyPages) - 1
     'PRF - cislo uchazece
    'Set regEx = New RegExp
    'regEx.Pattern = "slo: (\d{5,8})"
    'regEx.IgnoreCase = False
    'regEx.Global = True
    
    'Set Matches = regEx.Execute(docNew.Range.Text)
        'Check if PDFCreator is already running and attempt to kill the process if so
    Do
        bRestart = False
        Set pdfjob = New PDFCreator.clsPDFCreator
        If pdfjob.cStart("/NoProcessingAtStartup") = False Then
            'PDF Creator is already running. Kill the existing process
            Shell "taskkill /f /im PDFCreator.exe", vbHide
            DoEvents
            Set pdfjob = Nothing
            bRestart = True
        End If
    Loop Until bRestart = False
 
    With pdfjob
        .cOption("UseAutosave") = 1
        .cOption("UseAutosaveDirectory") = 1
        .cOption("AutosaveDirectory") = fileDir
        .cOption("AutosaveFilename") = strName & ".pdf"
        .cOption("AutosaveFormat") = 0 ' 0 = PDF
    
        .cClearCache
    End With
 
    'Print the document to PDF
    Application.ActivePrinter = "PDFCreator"
    docNew.PrintOut Background:=False, Range:=wdPrintRangeOfPages, Pages:="1" & "-" & CStr(pagesTo)
    Do Until pdfjob.cCountOfPrintjobs = 1
        DoEvents
    Loop
    pdfjob.cPrinterStop = False
        'Wait until PDF creator is finished then release the objects
    Do Until pdfjob.cCountOfPrintjobs = 0
        DoEvents
    Loop
    pdfjob.cClose
    Set pdfjob = Nothing
  
            docNew.Close wdDoNotSaveChanges
            End If
End If
        ' Move the selection to the next section in the document
     Application.Browser.Next
    Next i
    ActiveDocument.Close savechanges:=wdDoNotSaveChanges

End Sub