Enregistrer chaque page en tant que fichier PDF séparé avec des noms du doc

Version imprimable

Bonjour,

J'ai un code qui me permet d'enregistrer les documents word microsoft en pdf séparément qui fonctionne très bien mais, lors de l'enregistrement du document word (avec plusieurs pages) en pdf j'ai : page_1.pdf, pour la première page du document, page_2.pdf pour la deuxième page du document ect....
Et ce que je voudrai c'est avoir le texte qui est dans le paragraphe 18 en plus. Exemple : si dans la première page du doc au paragraphe 18, j'ai Mr Dupont, j'aimerai que lors de l'enregistrement en pdf j'ai : page_Mr Dupont_1.pdf
Si dans la deuxième page au paragraphe 18, j'ai Mr ALEX, j'aimerai avoir : page_Mr ALEX_2.pdf
Merci d'avance et bonne journée.

Voici le code :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
Sub SaveAsSeparatePDFs()
    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(msoFileDialogFolderPicker)
    If xFileDlg.Show <> -1 Then
        MsgBox "Please chose a valid directory", vbInformation, "Kutools for Word"
        Exit Sub
    End If
    xPathStr = xFileDlg.SelectedItems(1)
    xStartPageStr = InputBox("Begin saving PDFs starting with page __? " & vbNewLine & "(ex: 1)", "Kutools for Word")
    xEndPageStr = InputBox("Save PDFs until page __?" & vbNewLine & "(ex: 7)", "Kutools for Word")
    If Not (IsNumeric(xStartPageStr) And IsNumeric(xEndPageStr)) Then
        MsgBox "The enterng start page and end page should be number format", vbInformation, "Kutools for Word"
        Exit Sub
    End If
    xStartPage = CInt(xStartPageStr)
    xEndPage = CInt(xEndPageStr)
    If xStartPage > xEndPage Then
        MsgBox "The start page number can't be larger than end page", vbInformation, "Kutools for Word"
        Exit Sub
    End If
    If xEndPage > ActiveDocument.BuiltInDocumentProperties(wdPropertyPages) Then
        xEndPage = ActiveDocument.BuiltInDocumentProperties(wdPropertyPages)
    End If
    For I = xStartPage To xEndPage
        ActiveDocument.ExportAsFixedFormat xPathStr & "\Page_" & I & ".pdf", _
        wdExportFormatPDF, False, wdExportOptimizeForPrint, wdExportFromTo, I, I, wdExportDocumentWithMarkup, _
        False, False, wdExportCreateHeadingBookmarks, True, False, False
    Next
End Sub

18/02/2021, 15h40
Invité

Citation:

Envoyé par Mikitars20

Bonjour,

Comment se présenterait un paragraphe 18 ?
18/02/2021, 16h00
Mikitars20

1 pièce(s) jointe(s)

Citation:

Envoyé par Eric KERGRESSE

Bonjour,

Comment se présenterait un paragraphe 18 ?

Bonjour,

Mr ou Mme "prénom" "Nom"

Voici un exemple en pièce jointe (j'ai du enregistrer sans macro pour pouvoir l'ajouter en pièce jointe)

Citation:

Envoyé par Mikitars20

Cette fonction récupère la chaîne complète :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
 
Function NomPrenom(ByVal DocEnCours As Document, ByVal NumeroDePage As Integer) As String
 
Dim I As Integer
 
    NomPrenom = ""
    With DocEnCours
         With .Tables(NumeroDePage).Range.Cells(2).Range.Paragraphs(17)
              If Len(.Range.Text) > 1 Then
                 For I = 1 To Len(.Range.Text)
                     Select Case Mid(.Range.Text, I, 1)
                            Case "*", "?", ",", ".", "@", Chr(10), Chr(11), Chr(13)
 
                            Case Else
                                  NomPrenom = NomPrenom & Mid(.Range.Text, I, 1)
                     End Select
                 Next I
              End If
        End With
    End With
 
End Function

Dans votre code principal :

Code:

1
2
3
4
5
6
7
 
        For I = xStartPage To xEndPage
            NomPrenom2 = xPathStr & "\Page_" & NomPrenom(ActiveDocument, I) & "_" & I & ".pdf" '
            ActiveDocument.ExportAsFixedFormat NomPrenom2, _
            wdExportFormatPDF, False, wdExportOptimizeForPrint, wdExportFromTo, I, I, wdExportDocumentWithMarkup, _
            False, False, wdExportCreateHeadingBookmarks, True, False, False
        Next

18/02/2021, 17h42
Mikitars20

Merci infiniment Eric. Je viens d'essayer et c'est exactement ce que je voulais. :)

Dernière petite info, si jamais j'ai besoin d'enlever le Mr ou Mme et garder que le prénom et le nom, quel code devront nous appliquer .
Je vous remercie .

Citation:

Envoyé par Mikitars20

Il faut utiliser la fonction Split :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
 
 
Function NomPrenom(ByVal DocEnCours As Document, ByVal NumeroDePage As Integer) As String
 
Dim NomPrenomTableau As Variant
 
    NomPrenom = ""
    With DocEnCours
             With .Tables(NumeroDePage).Range.Cells(2).Range.Paragraphs(17)
                  NomPrenomTableau = Split(Mid(.Range.Text, 1, Len(.Range.Text) - 1), " ")
                  If UBound(NomPrenomTableau) >= 2 Then
                      NomPrenom = NomPrenomTableau(1) & " " & NomPrenomTableau(2)
                  End If
        End With
    End With
 
End Function

18/02/2021, 17h55
Mikitars20

Merci beaucoup :)

Citation:

Envoyé par Mikitars20

Cette variante :D répond au cas Jean Michel DUPONT :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
 
Function NomPrenom(ByVal DocEnCours As Document, ByVal NumeroDePage As Integer) As String
 
Dim I As Integer, CaractereDebut As Integer
Dim NomPrenomTableau As Variant
 
    NomPrenom = ""
    With DocEnCours
         With .Tables(NumeroDePage).Range.Cells(2).Range.Paragraphs(17)
              If Len(.Range.Text) > 1 Then
                 NomPrenomTableau = Split(.Range.Text, " ")
                 CaractereDebut = Len(NomPrenomTableau(0)) + 2
                 For I = CaractereDebut To Len(.Range.Text)
                     Select Case Mid(.Range.Text, I, 1)
                            Case "*", "?", ",", ".", "@", Chr(10), Chr(11), Chr(13)
 
                            Case Else
                                  NomPrenom = NomPrenom & Mid(.Range.Text, I, 1)
                     End Select
                 Next I
                 NomPrenom = Trim(NomPrenom)
              End If
        End With
    End With
 
End Function

19/02/2021, 09h48
Mikitars20

Ah oui je n'y avais pas pensé. Merci beaucoup :D
09/07/2024, 16h12
SunCanBurn

1 pièce(s) jointe(s)

Bonjour,

Je suis désolé de faire ressortir ce sujet mais il répondait partiellement à un de mes sujets du moment.
Je n'arrive juste pas à adapter la formule pour le nommage du fichier pdf.
J'avoue que les macros sur EXCEL ça me parle mais je découvre WORD et j'ai du mal à me calibrer sur "comment faire comprendre à l'outil quel champ il doit prendre en variable".
Si vous avez une seconde pour m'expliquer ou à quoi ressemblerait la partie macro ?
Je mets en PJ le fichier, le nom de sauvegarde doit être la partie 1234

Merci par avance pour votre aide.

PS : la partie découpe et sauvegarde page par page en PDF fonctionne nickel sinon.

Bonne journée,Pièce jointe 656950
09/07/2024, 23h31
Nain porte koi

Hello,

le doc que vous avez joint est le document principal de fusion, et, si je ne me trompe pas, les codes ci dessus sont pour le document final.