1. Ce site utilise des "témoins de connexion" (cookies) conformes aux textes de l'Union Européenne. Continuer à naviguer sur nos pages vaut acceptation de notre règlement en la matière. En savoir plus.

XL 2013 Automatisation publipostage avec word depuis excel

Discussion dans 'Forum Excel' démarrée par escouger, 3 Décembre 2018.

  1. escouger

    escouger XLDnaute Occasionnel

    Inscrit depuis le :
    13 Octobre 2011
    Messages :
    136
    "J'aime" reçus :
    0
    Sexe :
    Masculin
    Habite à:
    Saverne
    Utilise:
    Excel 2013 (PC)
    Bonjour,
    J'utilise depuis plusieurs années un tableau excel qui fait dynamiquement appel à Word pour effectuer un "publipostage" d'un mini article destiné à la presse locale dans le cadre de mon association de randonneurs.
    Depuis que, suite à un souci hardware sur mon installation, j'ai reinstallé Office 2013 ce publipostage ne se fait plus et se plante avec le message suivant : -2147023170 (800706be) Erreur automation. Echec de l'appel de la procédure distante.
    Malgré mes recherches je ne comprends pas ce qui se passe car rien n'a changé dans cet excel, ce qui me conduit à penser que c'est la reinstallation de Office 2013 qui est la cause du problème.

    Voyez ci-dessous mon code en rouge à du plantage.

    Merci de votre aide.

    ---------------------------------------------------------------------------------------------
    Sub Publipostage()
    Application.ScreenUpdating = True
    Dim Wd As Word.Application
    Dim WdDoc As Word.Document, Doc As Word.Document
    Dim Chemin As String, Fichier As String
    Dim Chemin_Fichier As String
    Sheets("Rando ").Select
    zguide = Range("ab8")
    Sheets("DNA").Visible = True
    Sheets("DNA").Select
    Worksheets("DNA").Activate
    ActiveSheet.Unprotect

    NBAS1 = "C:\CVS\"
    NBAS2 = Range("nom_tableau_courant")
    NBAS = NBAS1 & NBAS2

    nom_out1a = Range("RAN_AA")
    nom_out1b = Range("RAN_MM")
    nom_out1c = Range("RAN_JJ")
    nom_out1 = nom_out1a & nom_out1b & nom_out1c

    nom_out2 = Range("AUJ_AA")
    nom_out3 = Range("AUJ_MM")
    nom_out4 = Range("AUJ_JJ")
    nom_out5 = Range("AUJ_HH")
    nom_out6 = Range("AUJ_MN")
    nom_out7 = Range("AUJ_SEC")
    nom_outx = "0"

    If nom_out1 = " " Or nom_out1 = "" Or nom_out1 = "0" Or nom_out1 = "19000100" Then
    nom_outx = "1"
    Else
    If NBAS2 = "Formulaire de randonnées.xls" Then
    nom_outx = "2"
    Else
    nom_outx = "3"
    End If
    End If
    If nom_outx > 1 Then 'xxxxx
    If nom_outx = 2 Then
    nom_out = nom_out1 & "_" & Left(Range("categ"), 4) & "_" & nom_out2 & nom_out3 & nom_out4 & nom_out5 & nom_out6 & nom_out7 & ""
    Else
    nom_out = Range("nom_tableau_courantw") & "_" & nom_out2 & nom_out3 & nom_out4 & nom_out5 & nom_out6 & nom_out7 & ""
    End If
    Nmail = Range("EA1")
    Nmail1 = Range("EA2")
    ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
    ActiveWindow.SelectedSheets.Visible = False
    '
    Application.ScreenUpdating = False
    Worksheets("rando ").Activate
    Sheets("Rando ").Select
    ' Récupère le chemin des fichiers de la feuille "saisie"
    ' cellule "Chemin"
    Chemin = ThisWorkbook.Path & "\"
    ' Chemin du répertoire de la lettre type et des documents résultats (Lettres)
    Chemin1 = Chemin & "DNA\"
    'Nom de la lettre DOC pour le publipostage
    Fichier = "_Article_DNA_Modele.docx"
    'Chemin & lettre Word pour publipostage
    Chemin_Fichier = Chemin1 & Fichier
    'Chemin est nom du fichier Excel o? est la base de données
    'pour le publipostage
    Source = ThisWorkbook.FullName
    'Nom de la feuille ou se retrouvent les données du classeur.
    Feuille = ThisWorkbook.Worksheets("DNA").Name
    'Démarrer Word en ouvrant la lettre type
    Set Wd = CreateObject("Word.Application")
    Wd.Visible = True
    Set WdDoc = Wd.Documents.Open(Chemin_Fichier)
    With WdDoc
    'Créer la liaison à la base de données afin de pouvoir
    ' déplacer facilement les fichiers.
    ' Source contient le chemin d'accès au fichier
    .MailMerge.OpenDataSource _
    Name:=Source, _
    LinkToSource:=True, _
    Format:=wdOpenFormatAuto, _
    SqlStatement:="SELECT * FROM [" & Feuille & "$] WHERE NOM_RANDO is not null;"

    ' Lancer la fusion du 1er et seul enreg vers un nouveau doc
    With .MailMerge
    '.MainDocumentType = wdDirectory
    .Destination = wdSendToNewDocument
    .SuppressBlankLines = True
    With .DataSource
    .FirstRecord = wdDefaultFirstRecord
    .LastRecord = wdDefaultLastRecord
    End With
    .Execute Pause:=False
    Call SaveRecsAsFiles(Wd, nom_out)
    End With
    ' Ferme le doc ayant servi de mod?le sans l'enregistrer
    For Each Doc In .Parent.Documents
    Doc.Close (False)
    Next
    Wd.Quit
    End With
    'Ouvrir le r?pertoire o? se retrouvent tous les fichiers (Observer le r?sultat)
    Shell "C:\Windows\EXPLORER.EXE /e,/root," & ThisWorkbook.Path & "\" & Feuille & "\", vbNormalFocus
    End If 'XXXXX
    ' Lib?re la m?moire
    Set Doc = Nothing: Set WdDoc = Nothing: Set Wd = Nothing
    Sheets("Rando ").Select
    Range("Nom_Rando").Select
    znameword = "C:\CVS\" & Feuille & "\" & nom_out & "_" & nomdocument_w & "_" & zguide & _
    ".docx"
    Range("aG1") = znameword
    txtquest1 = "Voulez-vous envoyer le texte g?n?r? vers le responsable du site internet de CVS ?"
    txtquest2 = Nmail
    txtquest = txtquest1 & " (" & txtquest2 & ")"
    'question = InputBox(txtquest) (Supprim? le 01/03/2017)
    'If questio1 = "OUI" Or questio1 = "Oui" Or questio1 = "oui" Or questio1 = "o" Or questio1 = "O" Then
    'Call Envoyer_Mail_Outlook(znameword)
    'End If
    txtquest3 = "Voulez-vous envoyer le texte g?n?r? vers le responsable des affiches du CVS ?"
    txtquest4 = Nmail1
    txtquest = txtquest3 & " (" & txtquest4 & ")"
    questio1 = InputBox(txtquest)
    If questio1 = "OUI" Or questio1 = "Oui" Or questio1 = "oui" Or questio1 = "o" Or questio1 = "O" Then
    Call Envoyer_Mail1_Outlook(znameword)


    End If
    End Sub
    Function NOMRAND(T())
    'n?cessite une r?f?rence ? la librairie
    'Microsoft ActiveX Data Object 2.8 Library
    Dim Rst As ADODB.Recordset
    Dim StConnect As String
    Dim Requete As String
    If Val(Application.version) < 12 Then
    ' Cr?e la cha?ne de connexion
    StConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
    "Data Source=" & Source & ";" & _
    "Extended Properties=Excel 8.0;"
    Else
    StConnect = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
    "Data Source=" & Source & ";" & _
    "Extended Properties=""Excel 12.0;HDR=Yes"";"
    End If
    ' La requ?te est bas?e sur le nom de la feuille. Ce nom
    ' doit se terminer par un $ et doit ?tre entour? de crochets droits.

    Requete = "SELECT NOM_RANDO FROM [" & Feuille & "$] WHERE NOM_RANDO is not null;"
    Set Rst = New ADODB.Recordset
    Rst.Open Requete, StConnect, adOpenStatic, _
    adLockReadOnly, adCmdText
    If Rst.RecordCount > 0 Then
    T = Rst.GetRows
    End If
    End Function
     

    Pièces jointes:

  2. Chargement...

    Discussions similaires - Automatisation publipostage word Forum Date
    Automatisation de ma numérotation de factures Forum Excel 22 Octobre 2018
    Automatisation graphique sans Excel Forum Excel 29 Août 2018
    XL 2010 Automatisation du coût moyen Forum Excel 27 Juin 2018
    Automatisation de mon bon de commande et historique de ceux-ci Forum Excel 24 Juin 2018
    Automatisation en fonction de valeurs Forum Excel 15 Juin 2018

  3. tatiak

    tatiak XLDnaute Accro

    Inscrit depuis le :
    25 Février 2005
    Messages :
    1883
    "J'aime" reçus :
    277
    Habite à:
    Morbihan
    Page d'accueil :
    Utilise:
    Excel 2016 (PC)
    Bonsoir,

    J'ai la flemme de relire ton code, en revanche voici un code parfaitement fonctionnel (à adapter à ton besoin)
    nb : ne nécessite de cocher aucune référence

    Souhaitant que ça t'aide,
    Pierre

    Code (Visual Basic):
    Option Explicit

    ' ******************************************
    ' *****                                *****
    ' *****            pierrep56           *****
    ' *****  http://tatiak.canalblog.com/  *****
    ' *****                                *****
    ' ******************************************

    Public Const wdDefaultFirstRecord = 1
    Public Const wdDefaultLastRecord = -16


    Sub Publipostage()
    Dim NDXL As String, NDF As String, NDF2 As String, Rep As String
    Dim WordApp As Object ' Word.Application
    Dim WordDoc As Object ' Word.Document

        Application.ScreenUpdating = False

        NDXL = ActiveWorkbook.Path & "\" & ActiveWorkbook.Name
        NDF = ActiveWorkbook.Path & "\BULL.docx"
        Rep = ActiveWorkbook.Path & "\SousDossier\"
        If Not ExisteRep(Rep) Then MkDir Rep
        NDF2 = Rep & "DocBULL_" & Format(Now(), "yyyymmddhhmm")

        Set WordApp = CreateObject("Word.Application")
        WordApp.Visible = False
        Set WordDoc = WordApp.Documents.Open(NDF, ReadOnly:=False)
        With WordDoc.mailMerge
            .OpenDataSource Name:=NDXL, Connection:="Driver={Microsoft Excel Driver (*.xls)};" & _
                "DBQ=" & NDXL & "; ReadOnly=True;", SQLStatement:="SELECT * FROM [Feuil1$]"
            '.Destination = wdSendToPrinter 'Si besoin de fusion vers l'imprimante
            .suppressBlankLines = True
            With .DataSource
                .firstRecord = wdDefaultFirstRecord
                .lastRecord = wdDefaultLastRecord
            End With
            .Execute Pause:=False 'Exécute l'opération de publipostage
        End With

        WordDoc.Application.ActiveDocument.SaveAs NDF2
        WordDoc.Close
        WordApp.Application.Quit
        Set WordDoc = Nothing
        Set WordApp = Nothing
     
        Application.ScreenUpdating = True
        MsgBox "Publipostage OK"
    End Sub


    Function ExisteRep(NDF As String) As Boolean
        On Error Resume Next
        ExisteRep = GetAttr(NDF) And vbDirectory
    End Function
     
  4. escouger

    escouger XLDnaute Occasionnel

    Inscrit depuis le :
    13 Octobre 2011
    Messages :
    136
    "J'aime" reçus :
    0
    Sexe :
    Masculin
    Habite à:
    Saverne
    Utilise:
    Excel 2013 (PC)
    Bonsoir tatiak et merci de t'être penché sur la question.
    Je rencontre hélas le même souci en utilisant ton code.
    Il doit y avoir un souci chez moi lié soit à Excel ou Word ou à une mise à jour Windows ou encore à la réinstallation de mon office 2013.
    Ce classeur fonctionnait depuis plusieurs années sans souci, et voilà qu'il dysfonctionne ….subitement.
    J'en déduis que mon code n'est certainement pas en cause, mais que quelque chose a changé dans l'environnement ou il tourne. J'ai bien tenté de désactiver puis réactiver MSCOMCTL.OCX comme le conseillait un site mais cela ne change rien.
    (erre 800706be erreur automation, échec de l'appel de procédure à distance)
    J'ai aussi tenté de désinstaller les Windows Update des dernières semaines, mais le problème persiste.
    J'ai aussi désactivé un complément installé par Cordial (Contrôles orthographe et grammaire), mais sans changement.
    Merci
     
  5. escouger

    escouger XLDnaute Occasionnel

    Inscrit depuis le :
    13 Octobre 2011
    Messages :
    136
    "J'aime" reçus :
    0
    Sexe :
    Masculin
    Habite à:
    Saverne
    Utilise:
    Excel 2013 (PC)
    Voici quelques éléments supplémentaires qui pourraient peut-être aider à la compréhension de mon sujet.
    Dans le fichier joint, j'ai analysé le code "Err" pour en savoir plus.
    Au delà de la valeur du code (-2147023170) il est question d'un fichier d'aide qui n'existe pas sur mon PC.
    "C:\Program Files (x86)\Common Files\Microsoft Shared\VBA\VBA7.1\1036\VbLR6.chm"
    Je n'ai même pas de répertoire VBA sous le répertoire "C:\Program Files (x86)\Common Files\Microsoft Shared\"
    Une piste à creuser ?
    Gérard
     

    Pièces jointes:

  6. escouger

    escouger XLDnaute Occasionnel

    Inscrit depuis le :
    13 Octobre 2011
    Messages :
    136
    "J'aime" reçus :
    0
    Sexe :
    Masculin
    Habite à:
    Saverne
    Utilise:
    Excel 2013 (PC)
    Encore une information complémentaire.
    Je constate que j'ai installé ACCESS 2016 fin Novembre et il se peut que le dysfonctionnement que je rencontre avec cette erreur d'automation se soit faite jour après cette installation. Pensez-vous que cela pourrait avoir un rapport ?
    Access est en version 2016 alors que Excel et Word sont en version 2013...
    Je vais tenter une désinstallation de Access et vous tiendrez informé de mon nouveau test.
    GE
     
  7. escouger

    escouger XLDnaute Occasionnel

    Inscrit depuis le :
    13 Octobre 2011
    Messages :
    136
    "J'aime" reçus :
    0
    Sexe :
    Masculin
    Habite à:
    Saverne
    Utilise:
    Excel 2013 (PC)
    Bingo, après désinstallation de ACCESS 2016, l'erreur "automation" a disparu.
    Maintenant reste à résoudre de comment réinstaller ACCESS sans reperturber Excel 2013?
    GE
     

Partager cette page