XL 2013 Automatisation publipostage avec word depuis excel

[escouger]

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

 

[tatiak]

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

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

 

[escouger]

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

 

[escouger]

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

 

[escouger]

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