Macro pour enregistrer un fichier pdf avec un nom différent

Raan

XLDnaute Nouveau
Bonjour, j'utilise cette macro pour enregistré un publipostage en version pdf mais le nom du document enregistré ne change pas ...

Comment puis-je faire pour que le nom enregistré corresponde à une des lignes de mon documents ?
Ou que le nom enregistré corresponde à un champ de fusion que j'aurai choisi ?

Sub Macro1()
'
' Macro1 Macro
'
'
ActiveDocument.ExportAsFixedFormat OutputFileName:= _
"C:\Users\istef\Desktop\pDF PUBLI\LM ATCA Sàrl.pdf", ExportFormat:= _
wdExportFormatPDF, OpenAfterExport:=True, OptimizeFor:= _
wdExportOptimizeForPrint, Range:=wdExportAllDocument, From:=1, To:=1, _
Item:=wdExportDocumentContent, IncludeDocProps:=True, KeepIRM:=True, _
CreateBookmarks:=wdExportCreateNoBookmarks, DocStructureTags:=True, _
BitmapMissingFonts:=True, UseISO19005_1:=False
End Sub
 
Dernière édition:

laurent3372

XLDnaute Impliqué
Supporter XLD
Si le nom souhaité est dans la cellule B4 de la feuille active, il faut spécifier Range("B4").Value à la place du nom de fichier:
VB:
ActiveDocument.ExportAsFixedFormat OutputFileName:= _
Range("B4").Value, ExportFormat:= _
wdExportFormatPDF, OpenAfterExport:=True, OptimizeFor:= _
wdExportOptimizeForPrint, Range:=wdExportAllDocument, From:=1, To:=1, _
Item:=wdExportDocumentContent, IncludeDocProps:=True, KeepIRM:=True, _
CreateBookmarks:=wdExportCreateNoBookmarks, DocStructureTags:=True, _
BitmapMissingFonts:=True, UseISO19005_1:=False
End Sub
 

Raan

XLDnaute Nouveau
J'ai trouvé la solution si ça peut aider quelqu'un :)



Sub publipostage()
'imprime enregistrement par enregistrement
Dim fusion As MailMerge
Dim x As Integer, nb As Integer
Dim chemin As String, nom As String
Set fusion = ActiveDocument.MailMerge
chemin = "D:\Mes documents\" 'mettre ici le chemin complet du dossier où stocker les fichiers sans oublier le \ à la fin
nb = fusion.DataSource.RecordCount
For x = 0 To nb - 1
With fusion
.DataSource.FirstRecord = x + 1
.DataSource.LastRecord = x + 1
.Destination = wdSendToNewDocument
.DataSource.ActiveRecord = x + 1
nom = .DataSource.DataFields("Nom") 'Remplacer Nom" par le champ à utiliser
.Execute
End With
ActiveDocument.ExportAsFixedFormat OutputFileName:=chemin & nom & ".pdf", ExportFormat:=wdExportFormatPDF, openafterexport:=False
ActiveDocument.Close savechanges:=False

Next
End Sub
 

kiki29

XLDnaute Barbatruc
Salut, à adapter à ton contexte, cela permet d'éviter les doublons en ajoutant un indice au nom du fichier ( voir pj ).

VB:
Option Explicit

Sub Test()
Dim sDossier As String, sNom As String

    sDossier = "C:\Essai1\Essai2\Essai3\Essai4\Essai5"
    sNom = "test.pdf"

    CreationDossier sDossier
    sNom = RenommerFichier(sDossier, sNom)

    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=sNom, _
                                    Quality:=xlQualityStandard, _
                                    IncludeDocProperties:=True, _
                                    IgnorePrintAreas:=False, _
                                    OpenAfterPublish:=False
End Sub

Private Sub CreationDossier(sDossier As String)
Dim sChaine As String
    sChaine = Environ("comspec") & " /c mkdir " & sDossier
    Shell sChaine, 0
End Sub

Private Function RenommerFichier(sDossier As String, sNomfichier As String) As String
Dim sNouveauNom As String
Dim sPre As String, sExt As String
Dim i As Long
Dim FSO As Object

    Set FSO = CreateObject("Scripting.FileSystemObject")
    If Dir(sDossier & "\" & sNomfichier, vbNormal) <> vbNullString Then
        sNouveauNom = sNomfichier
        sPre = FSO.GetBaseName(sNomfichier)
        sExt = FSO.GetExtensionName(sNomfichier)

        i = 0
        While Dir(sDossier & "\" & sNouveauNom, vbNormal) <> vbNullString
            i = i + 1
            sNouveauNom = sPre & Chr(40) & Format(i, "000") & Chr(41) & Chr(46) & sExt
        Wend
        sNomfichier = sNouveauNom
    End If
    Set FSO = Nothing

    RenommerFichier = sDossier & "\" & sNomfichier
End Function
 

Pièces jointes

  • 1.png
    1.png
    7.4 KB · Affichages: 53
  • Test.xlsb
    16.3 KB · Affichages: 17

Discussions similaires

Réponses
2
Affichages
793

Statistiques des forums

Discussions
314 626
Messages
2 111 294
Membres
111 093
dernier inscrit
Yvounet