Save every page as a separate PDF with names?

[CaptainCsaba]

Hi!

I just wanted to say before that I would like to thank you for helping people like me who are still amateurs and need help in this stuff. You have no idea how much help you are.

So the thing if that our company generates reports. Many are generated into 1 big word file. The only difference is the company we are sending it to. Part of my job is to generate a pdf file from every page and name it corrently with the adress. For exmaple: I get a 63 page word file. every page is almost the same but the adress and the recipient is different. As you can guess doing this manually is a lot of Work.

I recentyl found somebody online who created a macro that basically creates a PDF out fo each page individually and it works perfectly. This kind of macro is way more complex than what I could currentyl figure out so here is where I need you guys' insights.

We need to change the code a bit. So that when it creates a PDF out of a page it names it correctly. So for example if it finds "John Smiths" on the page then it names it "John_Smiths". I had an Idea to have a separate excel file for this to make it furute proof. Maybe to have an A column and a B column. A contains the stuff it should find in the file and B what it should name it to. So if A1 contains "John Smith" the it then it names the page by B1 which is "John_Smith". This is so we can add recipients later. I'll include the current code and the page I found it in. How should we solve this?

I found the code here:

https://wellsr.com/vba/2015/word/examples/word-vba-saves-pages-as-separate-pdfs/


Option Explicit
Sub SaveAsSeparatePDFs()

Dim strDirectory As String, strTemp As String
Dim ipgStart As Integer, ipgEnd As Integer
Dim iPDFnum As Integer, i As Integer
Dim vMsg As Variant, bError As Boolean

1:
strDirectory = InputBox("Directory to save individual PDFs? " & _
vbNewLine & "(ex: C:\Users\Public)")
If strDirectory = "" Then Exit Sub
If Dir(strDirectory, vbDirectory) = "" Then
vMsg = MsgBox("Please enter a valid directory.", vbOKCancel, "Invalid Directory")
If vMsg = 1 Then
GoTo 1
Else
Exit Sub
End If
End If

2:
strTemp = InputBox("Begin saving PDFs starting with page __? " & _
vbNewLine & "(ex: 32)")
bError = bErrorF(strTemp)
If bError = True Then GoTo 2
ipgStart = CInt(strTemp)

3:
strTemp = InputBox("Save PDFs until page __?" & vbNewLine & "(ex: 37)")
bError = bErrorF(strTemp)
If bError = True Then GoTo 3
ipgEnd = CInt(strTemp)

iPDFnum = ipgStart
On Error GoTo 4:
For i = ipgStart To ipgEnd
ActiveDocument.ExportAsFixedFormat OutputFileName:= _
strDirectory & "\Page_" & iPDFnum & ".pdf", ExportFormat:=wdExportFormatPDF, _
OpenAfterExport:=False, OptimizeFor:=wdExportOptimizeForPrint, Range:= _
wdExportFromTo, From:=i, To:=i, Item:=wdExportDocumentContent, _
IncludeDocProps:=False, KeepIRM:=False, CreateBookmarks:= _
wdExportCreateHeadingBookmarks, DocStructureTags:=True, _
BitmapMissingFonts:=False, UseISO19005_1:=False
iPDFnum = iPDFnum + 1
Next i
End
4:
vMsg = MsgBox("Unknown error encountered while creating PDFs." & vbNewLine & vbNewLine & _
"Aborting", vbCritical, "Error Encountered")
End Sub

Private Function bErrorF(strTemp As String) As Boolean
Dim i As Integer, vMsg As Variant
bErrorF = False

If strTemp = "" Then
End
ElseIf IsNumeric(strTemp) = True Then
i = CInt(strTemp)
If i > ActiveDocument.BuiltInDocumentProperties(wdPropertyPages) Or i <= 0 Then
Call msgS(bErrorF)
End If
Else
Call msgS(bErrorF)
End If
End Function

Private Sub msgS(bMsg As Boolean)
Dim vMsg As Variant
vMsg = MsgBox("Please enter a valid integer." & vbNewLine & vbNewLine & _
"Integer must be > 0 and < total pages in the document (" & _
ActiveDocument.BuiltInDocumentProperties(wdPropertyPages) & ")", vbOKCancel, "Invalid Integer")
If vMsg = 1 Then
bMsg = True
Else
End
End If
End Sub




Thanks you for all your help!

[CaptainCsaba]

Hey! I realised that we don't need the excel file since the recipient is always in the 4th row. every page begins with 3 "paragraph ends" (the thing that happens when you press "Enter" in word) and the recipient is in the 4th row. So the only thing we need is tell excel that use the 4th row as name not the following code:


iPDFnum = ipgStartOn Error GoTo 4:
For i = ipgStart To ipgEnd
ActiveDocument.ExportAsFixedFormat OutputFileName:= _
strDirectory & "\Page_" & iPDFnum & ".pdf", ExportFormat:=wdExportFormatPDF, _
OpenAfterExport:=False, OptimizeFor:=wdExportOptimizeForPrint, Range:= _
wdExportFromTo, From:=i, To:=i, Item:=wdExportDocumentContent, _
IncludeDocProps:=False, KeepIRM:=False, CreateBookmarks:= _
wdExportCreateHeadingBookmarks, DocStructureTags:=True, _
BitmapMissingFonts:=False, UseISO19005_1:=False
iPDFnum = iPDFnum + 1
Next i End

[CaptainCsaba]

Hey! Does someone know how to solve this? Is there a command that says "use the 4th paragraph for the file name" for that 1 line?

[gmayor]

How are the pages separated? If they are separated by section breaks see http://www.gmayor.com/MergeAndSplit.htm
(http://www.gmayor.com/MergeAndSplit.htm)
If they are manual page breaks then use the macro below to convert them to section breaks first.


Sub ReplacePageBreaks()
Dim orng As Range
Set orng = ActiveDocument.Range
With orng.Find
Do While .Execute(FindText:="^m")
orng.Select
orng.Text = ""
orng.InsertBreak wdSectionBreakNextPage
Loop
End With
lbl_Exit:
Set orng = Nothing
Exit Sub
End Sub

[CaptainCsaba]

Hey gmayor!
Thanks but there is a section break at the end of every page. Since then I realised that the paragraph ends vary each time between 2 and 4. So every page begins with 2-4 paragraph ends and only then is the recipient name. I don't think they are necessary so we could put a line into the macro to delete all the paragraph ends until it reaches text and then use the first paragraph as file name.

[CaptainCsaba]

Okay I wrote a code to delete the empty paragraphs in the begining of every page. So now we only have to tell it that it should name it after the first paragraph.
What should I write instead of this?

ActiveDocument.ExportAsFixedFormat OutputFileName:= _
strDirectory & "\Page_" & iPDFnum & ".pdf"

[gmayor]

If each page is a separate section, the add-in I linked earlier would save re-inventing the wheel, however the following should work with provisos. Duplicate names will be overwritten (you will find code on my web site to allow the creation of unique names). The macro also makes no allowance for excessively long filenames or missng filenames


Option Explicit

Sub Macro1()
Dim oSection As Section
Dim strName As String
Dim strDirectory As String
Dim oRng As Range
Dim vMsg As Long
strDirectory = InputBox("Directory to save individual PDFs? " & _
vbNewLine & "(ex: C:\Users\Public)")
If strDirectory = "" Then Exit Sub
If Dir(strDirectory, vbDirectory) = "" Then
vMsg = MsgBox("Please enter a valid directory.", vbOKCancel, "Invalid Directory")
If vMsg = 0 Then Exit Sub
End If
For Each oSection In ActiveDocument.Sections
On Error GoTo lbl_Exit
Set oRng = oSection.Range.Paragraphs(1).Range
oRng.End = oRng.End - 1
strName = oRng.Text & ".pdf"
strName = CleanFileName(strName, "pdf")
oSection.Range.Select
ActiveDocument.ExportAsFixedFormat OutputFileName:=strDirectory & "\" & strName, ExportFormat:=wdFormatPDF, Range:=wdExportCurrentPage
Next oSection
lbl_Exit:
Exit Sub
Set oSection = Nothing
Set oRng = Nothing
End Sub

Private Function CleanFileName(strFilename As String, strExtension As String) As String
'Graham Mayor
'A function to ensure there are no illegal filename
'characters in a string to be used as a filename
'strFilename is the filename to check
'strExtension is the extension of the file
Dim arrInvalid() As String
Dim vfName As Variant
Dim lng_Name As Long
Dim lng_Ext As Long
Dim lng_Index As Long
'Ensure there is no period included with the extension
strExtension = Replace(strExtension, Chr(46), "")
'Record the length of the extension
lng_Ext = Len(strExtension)

'Remove the path from the filename if present
If InStr(1, strFilename, Chr(92)) > 0 Then
vfName = Split(strFilename, Chr(92))
CleanFileName = vfName(UBound(vfName))
Else
CleanFileName = strFilename
End If

'Remove the extension from the filename if present
If Right(CleanFileName, lng_Ext + 1) = "." & strExtension Then
CleanFileName = Left(CleanFileName, InStrRev(CleanFileName, Chr(46)) - 1)
End If

'Define illegal characters (by ASCII CharNum)
arrInvalid = Split("9|10|11|13|34|42|47|58|60|62|63|92|124", "|")
'Add the extension to the filename
CleanFileName = CleanFileName & Chr(46) & strExtension
'Remove any illegal filename characters
For lng_Index = 0 To UBound(arrInvalid)
CleanFileName = Replace(CleanFileName, Chr(arrInvalid(lng_Index)), Chr(95))
Next lng_Index
lbl_Exit:
Exit Function
End Function

[CaptainCsaba]

Wow! It works perfectly! It is amazing how much you have helped our team. Thank you!

[MikiTarsus20]

Bonjour à tous,
Je viens de m'inscrire et je demande votre aide.
J'ai un code qui me permet d'enregistrer les documents word microsoft en pdf séparément mais à la place de "I" je voudrai avec des noms qui sont dans le paragraphe 18.

Voici le code:


Sub SaveAsSeparatePDFs ()
'Updated by Extendoffice 20180906
Dim I As Long
Dim xStr As String
Dim xPathStr As Variant
Dim xDictoryStr As String
Dim xFileDlg As FileDialog
Dim xStartPage, xEndPage As Long
Dim xStartPageStr, xEndPageStr As String
Set xFileDlg = Application.FileDialog
-1 ensuite
MsgBox "Veuillez choisir un répertoire valide", vbInformation, "Kutools for Word"
Quitter Sub
End If
xPathStr = xFileDlg.SelectedItems (1)
xStartPageStr = InputBox ("Commencer à enregistrer les PDF à partir de la page __?" & VbNewLine & "(ex: 1 ) "," Kutools for Word ")
xEndPageStr = InputBox (" Enregistrer les PDF jusqu'à la page __? "& VbNewLine &" (ex: 7) "," Kutools for Word ")
Sinon (IsNumeric (xStartPageStr) Et IsNumeric (xEndPageStr) ) Puis
MsgBox "La page de démarrage et la page de fin doivent être au format numérique", vbInformation, "Kutools for Word"
Quitter Sub
End Si
xStartPage = CInt (xStartPageStr)
xEndPage = CInt (xEndPageStr)
Si xStartPage> xEndPage Then
MsgBox "Le numéro de page de démarrage ne peut pas être plus grand que la page de fin", vbInformation, "Kutools pour Word"
Exit Sub
End If
Si xEndPage> ActiveDocument.BuiltInDocumentProperties (wdPropertyPages) Alors
xEndPage = ActiveDocument.BuiltInDocumentProperties (wdPropertyPages)
End If
For I = Pour xStartPage xEndPage
ActiveDocument.ExportAsFixedFormat xPathStr & "\ page_" & I & ".pdf", _
wdExportFormatPDF, Faux, wdExportOptimizeForPrint, wdExportFromTo, I, I, wdExportDocumentWithMarkup, _
Faux, faux, wdExportCreateHeadingBookmarks, True, False, False
Next
End Sub