Macro publipostage vers des fichiers Word - signets vides dans Word

Bonjour à tous,

Par avance merci de m'aider

j'ai vu le fil de discussion d'Andreas (désolée mais étant nouvellesur le forum je ne peux mettre le lien actif) :

Titre du post : Publipostage en format Word dans plusieurs dossier definis

j'ai adapté son code à mon problème mais mes signets dans Word ne sont pas remplacés.

Pourtant le code me permet bien et fonctionne pour récupérer la donnée d'une cellule pour construire le nom du fichier Word à sauver.

et ils le sont.

Je n'arrive pas à voir mon erreur, par avance merci

Option Explicit

Function ChoixFichier() As String

    'cette macro permet de reprendre le nom du fichier docx
    'La variable est de type Variant car elle peut prendre les valeurs :
        'Booleenne: (Vrai/Faux) quand l'utilisateur ne sélectionne rien, ou annule l'opération.
        'String: pour renvoyer le nom du fichier sélectionné.
    Dim Fichier As Variant

    'Affiche la boîte de dialogue "Ouvrir"
    Fichier = Application.GetOpenFilename("Fichiers Word (*.docx), *.docx", , "Sélectionner le fichier modèle du publipostage.")

    'On sort si aucun fichier n'a été sélectionné ou si l'utilisateur
    'a cliqué sur le bouton "Annuler", ou sur la croix de fermeture.
    If Fichier = False Then
        ChoixFichier = ""
        Exit Function
    Else
        ChoixFichier = Fichier
    End If

    'Affiche le chemin et le nom du fichier sélectionné.
    'MsgBox Fichier
End Function

Function ChoixRepertoire() As String
    'cette macro permet de récuperer le nom d'un répertoire
    Dim objShell As Object, objFolder As Object, oFolderItem As Object
    Dim Chemin As String

    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.BrowseForFolder(&H0&, "Choisir un répertoire pour enregistrer vos Lettres de Mission.", &H1&)

    On Error Resume Next
    Set oFolderItem = objFolder.Items.Item
    Chemin = oFolderItem.Path
    ChoixRepertoire = Chemin
    'Affiche le chemin et le nom du répertoire sélectionné.
    'MsgBox ChoixRepertoire
End Function

Sub Action()

    Dim WordApp As Word.Application
    Dim WordDoc As Word.Document
    Dim NomFicModel As String           ' le nom du fichier modèle WORD
    Dim NomExcelPub As String           ' le nom du fichier Excel avec la macro et la base
    Dim NomRepExcel As String           ' le nom du répertoire du fichier NomExcelPub
    Dim NomRepEnr As String             ' le nom du répertoire vers lequel enregistrer les fichiers Words
    Dim NewFicWord As String
    Dim NewRepFicWord As String
    Dim fin As Integer
    Dim i As Integer

    Application.ScreenUpdating = False

    NomFicModel = ChoixFichier

    ' === LES VERIFICATIONS ===
    ' 1 - Vérifier qu'un fichier a été choisi               --> sinon arrêt de la procédure
    ' 2 - Vérifier que le fichier est de nom Modele.docx    --> sinon MsgBox + arrêt de la procédure

    If NomFicModel = "" Then
        Exit Sub
    ElseIf Dir(NomFicModel) <> "Modele.docx" Then
        MsgBox "Le publipostage ne fonctionne que depuis le fichier Modele.docx"
        Exit Sub
    Else
        NomRepEnr = ChoixRepertoire
        If NomRepEnr = "" Then
            'MsgBox "Le publipostage ne fonctionne que depuis le fichier Modele.docx"
            Exit Sub
        Else
            NomRepEnr = NomRepEnr & "\"
            NomRepExcel = Mid(NomFicModel, 1, InStrRev(NomFicModel, "\") - 1) & "\"
            NomExcelPub = NomRepExcel & "TestPublipostage.xlsm"

            Application.ScreenUpdating = False
            'Set WordApp = CreateObject("Word.Application")
            Set WordApp = New Word.Application
            WordApp.Visible = True
            'Ouverture du document principal Word
            Set WordDoc = WordApp.Documents.Open(NomFicModel)

            With WordDoc.MailMerge
                .OpenDataSource Name:=NomExcelPub, _
                Connection:="Driver={Microsoft Excel Driver (*.xlsx)};" & _
                "DBQ=" & NomExcelPub & "; ReadOnly=True;", SQLStatement:="SELECT * FROM [Base$] Where ToDo ='OUI'"
                fin = .DataSource.RecordCount
            End With
            If fin = 0 Then
                MsgBox "Vous n'avez pas de LM à publier !" _
                & Chr(13) & Chr(10) & "Vérifier la colonne ToDo de vos LM à publier. " _
                & Chr(13) & Chr(10) & "Mettre OUI dans la colonne ToDo de vos LM à publier."
            Else
                For i = 1 To fin
                    'fonctionnalité de publipostage pour le document spécifié
                    With WordDoc.MailMerge
                        'Spécifie la fusion vers un nouveau doc
                        .Destination = wdSendToNewDocument
                        'Prend en compte uniquement l'enregistrement i
                        With .DataSource
                            .FirstRecord = i
                            .LastRecord = i
                        End With
                        'Exécute l'opération de publipostage
                        .Execute Pause:=False
                        'recupère le nom du fichier source excel
                        .DataSource.ActiveRecord = i
                        NewFicWord = .DataSource.DataFields(5).Value
                    End With

                    NewRepFicWord = NomRepEnr & NewFicWord & ".docx"

                    With WordApp.ActiveDocument
                        .SaveAs NewRepFicWord
                        WordApp.ActiveDocument.Close True 'Fermeture du document de fusion
                    End With
                Next i
            End If
        End If
    End If

    'NomFicModel.Close = False
    WordApp.Quit
End Sub

C'est bon j'ai avancé mais comment faire pour faire fermer par la macro mon modèle Word qui sert à faire le publipostage?

Merci d'avance

Bonjour,

Es-tu sûre que ton code s’exécute jusqu'au bout quand tu exécutes en pas a pas détaillé F8 ? Le WordApp.quit à la fin devrait fermer ton application WORD. Est-ce le cas ?

Bonne soirée.

Malheureusement non.

Ta fenêtre active WORD reste sur ta trame ?

Si tu rajoutes ce code juste avant le WordApp.Quit que se passe-t-il ?

WordApp.ActiveDocument.Close

Bonne soirée.

Mille mercis Ergotamine, cela fonctionne à merveille

J'avais testé le code

NomFicModel.Close False

Mais j'avais une erreur me disant que NomFicModel était un quantificateur incorrect.

j'ai un peu changé la fin du code pour mieux respecter les If Else imbriqués

'partie modifiée
                    With WordApp.ActiveDocument
                        .SaveAs NewRepFicWord
                        WordApp.ActiveDocument.Close True 'Fermeture du document de fusion
                    End With
                Next i
            End If
         End If
        WordApp.ActiveDocument.Close False
        WordApp.Quit
    End If
End Sub

je continue et j'aurais peut-être des questions mais j'ouvrirai un autre fil. Il faut que je crée en même temps un fichier Excel... pas finie cette histoire.

Encore merci Ergotamine et bonne soirée à toi