escouger
XLDnaute Occasionnel
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
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