Babuto00 v 24. 3. 2017, 06:08

2017-03-24T06:08:27Z

← Starší verze		Verze z 24. 3. 2017, 08:08
Řádek 1:		Řádek 1:
	~~test~~		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

Babuto00: Založena nová stránka s textem „test“

2017-03-24T06:08:15Z

Založena nová stránka s textem „test“

Nová stránka

test

Makro - Historie editací

Babuto00 v 24. 3. 2017, 06:08

Babuto00: Založena nová stránka s textem „test“