'La référence Microsoft Word xx Objects Library" a été ajoutée
'à la liste des références.
'Une autre référence a été ajoutée :
'Microsoft ActiveX Data Object 2.8 Library
'Le document (lettre) servant au publipostage doit débuté obligatoirement
'par ce qu'on appelle en anglais : Microsoft Word’s built-in heading. Si
'tu affiches les symboles non imprimables, tu as un petit carré au tout début
'de ton document afin de pouvoir scinder chacune des sections du document
'contenant le Publipostage en document unique.
'Pour ce faire, le menu "Références" du ruban et dans la section "Table des matières",
'clique sur la petite flèche à l'extrémité de la commande "Ajouter le texte" et tu cliques
'dans la fenêtre ouvrante "Niveau 1"
'La ou les conditions "WHERE" dans les 2 requêtes, l'une dans la procédure "Publipostage" et l'autre
'dans la fonction "Prénom_Nom" doivent être identiques...
'Dans l'exemple,
'Requete = "SELECT * FROM [" & Feuille & "$] WHERE Prénom is not null;"
'On ne tient pas compte des enregistrements où le Prénom est absent.
Dim Feuille As String
Dim Source As String
'---------------------------------------------------------------------------
Sub Publipostage()
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
Application.ScreenUpdating = False
'l'Exemple suppose que le fichier Excel et la lettre Word
'sont dans le même répertoire. À adapter au besoin
' récupère le chemin des fichiers de la feuille "saisie"
' cellule "Chemin"
Chemin = ThisWorkbook.Path & "\"
'Nom de la lettre DOC pour le publipostage
Fichier = "Test.docm"
'Chemin & lettre Word pour publipostage
Chemin_Fichier = Chemin & Fichier
'Chemin est nom du fichier Excel où est la base de données
'pour le publipostage
Source = ThisWorkbook.FullName
'Nom de la feuille où se retrouvent les données du classeur.
Feuille = ThisWorkbook.Worksheets("Data").Name
'Démarrer Word en ouvrant la lettre type
Set Wd = CreateObject("Word.Application")
Wd.Visible = False
Set WdDoc = Wd.Documents.Open(Chemin_Fichier)
With WdDoc
'Créé 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 Prénom 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 = 1
.LastRecord = -5
End With
.Execute Pause:=False
Call SaveRecsAsFiles(Wd)
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
' Libère la mémoire
Set Doc = Nothing: Set WdDoc = Nothing: Set Wd = Nothing
'Ouvrir le répertoire où se retrouvent tous les fichiers (Observer le résultat)
Shell "C:\Windows\EXPLORER.EXE /e,/root," & ThisWorkbook.Path, vbNormalFocus
End Sub
'---------------------------------------------------------------------------
Sub SaveRecsAsFiles(Wd As Word.Application)
Dim T()
' Convert all sections to Subdocs
AllSectionsToSubDoc Wd.ActiveDocument
'Save each Subdoc as a separate file
SaveAllSubDocs Wd.ActiveDocument, T()
End Sub
'---------------------------------------------------------------------------
Sub AllSectionsToSubDoc(ByRef Doc As Word.Document)
Dim secCounter As Long
Dim NrSecs As Long
NrSecs = Doc.Sections.Count - 1
'Start from the end because creating
'Subdocs inserts additional sections
Doc.ActiveWindow.View.Type = wdMasterView
For secCounter = NrSecs To 1 Step -1
With Doc
Doc.Subdocuments.AddFromRange Doc.Sections(secCounter).Range
End With
Next secCounter
End Sub
'---------------------------------------------------------------------------
Sub SaveAllSubDocs(ByRef Doc As Word.Document, T())
Dim subdoc As Word.Subdocument
Dim NewDoc As Word.Document
Dim DocCounter As Long
Dim NomDocument As String
'Extrait le prénom et le nom de chaque enregistrement de la base de données
'de la feuille de calcul.
Prénom_Nom T()
DocCounter = 1
'Must be in MasterView to work with
'Subdocs as separate files
Doc.ActiveWindow.View = wdMasterView
For Each subdoc In Doc.Subdocuments
'Extrait le nom du prénom et du nom pour l'attribuer au nom du fichier.
NomDocument = T(0, DocCounter - 1) & " " & T(1, DocCounter - 1)
Set NewDoc = subdoc.Open
'Remove NextPage section breaks
'originating from mailmerge
RemoveAllSectionBreaks NewDoc
With NewDoc
.SaveAs2 Filename:=ThisWorkbook.Path & "\" & NomDocument & _
".docx", FileFormat:=wdFormatDocumentDefault
.Close False
End With
DocCounter = DocCounter + 1
Next subdoc
End Sub
'---------------------------------------------------------------------------
Sub RemoveAllSectionBreaks(Doc As Word.Document)
With Doc.Range.Find
.ClearFormatting
.Text = "^b"
With .Replacement
.ClearFormatting
.Text = ""
End With
.Execute Replace:=wdReplaceAll
End With
End Sub
'---------------------------------------------------------------------------
Function Prénom_Nom(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.
'Évidemment il faut adapter le nom des champs au besoin...
Requete = "SELECT Prénom, Nom FROM [" & Feuille & "$] WHERE Prénom 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
'---------------------------------------------------------------------------
