Public Sub GenerateWord()
Dim l_o_wdDoc As Object 'Word.Document
Dim l_l_i As Long
Dim l_s_pathNewFile As String
Dim l_o_collCc As VBA.Collection
Dim l_o_dicoCc As Object 'Scripting.Dictionary
'créer un nouveau document
Set l_o_wdDoc = CreateDocFromTemplate(ThisWorkbook.Path & "\Charlie doc type.docx")
'récupérer les contrôles de contenus
Set l_o_collCc = GetAllDocumentContentControls(l_o_wdDoc)
'trier les contrôles de contenus
Set l_o_dicoCc = GetDicoContentContolsByTitle(l_o_collCc)
'renseigner les contrôles de contenu
With Feuil1
For l_l_i = 2 To 4
WriteInContentControls l_o_dicoCc, .Cells(l_l_i, "A").Value, .Cells(l_l_i, "B").Value
Next l_l_i
End With
'supprimer les contrôles de contenu du document
For l_l_i = l_o_collCc.Count To 1 Step -1
l_o_collCc.Item(l_l_i).Delete
Next l_l_i
'enregistrer le document
l_o_wdDoc.SaveAs ThisWorkbook.Path & "\" & Range("B2") & " " & Format(Range("B4"), "dd mm yyyy") & ".docx"
MsgBox "Document généré.", vbInformation, "Info"
Set l_o_wdDoc = Nothing
Set l_o_dicoCc = Nothing
Set l_o_collCc = Nothing
End Sub
'fonction dédiée à créer un document Word à partir d'un modèle
'Private Function CreateDocFromTemplate(p_s_pathTemplate As String, Optional p_o_wdApp As Word.Application = Nothing) As Word.Document
Private Function CreateDocFromTemplate(p_s_pathTemplate As String, Optional p_o_wdApp As Object = Nothing) As Object
Static s_o_fso As Object 'Scripting.FileSystemObject
Dim l_o_wdApp As Object 'Word.Application
'vérifier si le modèle de document existe
If s_o_fso Is Nothing Then Set s_o_fso = CreateObject("Scripting.FileSystemObject")
If Not s_o_fso.FileExists(p_s_pathTemplate) Then Err.Raise vbObjectError, , "Le modèle de document '" & p_s_pathTemplate & "' n'a pas été trouvé."
'gérer l'instance Word (soit utiliser celle passée en paramètre, soit récupérer celle ouverte, soit en créer une nouvelle)
If p_o_wdApp Is Nothing Then
On Error Resume Next
Set l_o_wdApp = GetObject(, "Word.Application")
If l_o_wdApp Is Nothing Then Set l_o_wdApp = CreateObject("Word.Application")
On Error GoTo 0
If l_o_wdApp Is Nothing Then Err.Raise vbObjectError, , "Impossible d'ouvrir Word."
l_o_wdApp.Visible = True
Else
Set l_o_wdApp = p_o_wdApp
End If
Set CreateDocFromTemplate = l_o_wdApp.Documents.Add(p_s_pathTemplate)
Set l_o_wdApp = Nothing
End Function
'fonction dédiée à trier les contrôles de contenu par titre (les contrôles de contenu sans titres sont ignorés)
'ils sont retourné dans un dictionnaire :
' - clef : titre du contrôle de contenu
' - valeur : VBA Collection contenant tous les contrôles de contenu ayant ce titre
Private Function GetDicoContentContolsByTitle(p_o_collWdCc As VBA.Collection) As Object 'Scripting.Dictionary
Dim l_o_wdCc As Object 'Word.ContentControl
Set GetDicoContentContolsByTitle = CreateObject("Scripting.Dictionary")
GetDicoContentContolsByTitle.CompareMode = 1 '1 = Scripting.CompareMethod.TextCompare
For Each l_o_wdCc In p_o_collWdCc
If Not l_o_wdCc.Title Like vbNullString Then
If Not GetDicoContentContolsByTitle.Exists(l_o_wdCc.Title) Then GetDicoContentContolsByTitle.Add l_o_wdCc.Title, New VBA.Collection
GetDicoContentContolsByTitle.Item(l_o_wdCc.Title).Add l_o_wdCc
End If
Next l_o_wdCc
Set l_o_wdCc = Nothing
End Function
'procédure dédiée à renseigner les controles de contenu partageant le même titre
'Private Sub WriteInContentControls(p_o_dicoContentControls As Scripting.Dictionary, p_s_ccTitle As String, p_v_value As Variant)
Private Sub WriteInContentControls(p_o_dicoContentControls As Object, p_s_ccTitle As String, p_v_value As Variant)
Dim l_o_wdCc As Object 'Word.ContentControl
'vérifier qu'il existe bien un ou plusieurs contrôles de contenu avec ce titre
If Not p_o_dicoContentControls.Exists(p_s_ccTitle) Then Err.Raise vbObjectError, , "Aucun contrôle de contenu ayant pour titre '" & p_s_ccTitle & "' n'a été trouvé dans le document."
For Each l_o_wdCc In p_o_dicoContentControls.Item(p_s_ccTitle)
l_o_wdCc.Range.Text = p_v_value
Next l_o_wdCc
Set l_o_wdCc = Nothing
End Sub
'procédure dédiée à récupérer les contrôles de contenu d'un document (dans le corps du document, les entêtes et les pieds de pages)
'Private Function GetAllDocumentContentControls(p_o_wdDoc As Word.Document) As VBA.Collection
Private Function GetAllDocumentContentControls(p_o_wdDoc As Object) As VBA.Collection
Dim l_o_wdSection As Object 'Word.Section
Dim l_o_wdHf As Object 'Word.HeaderFooter
Dim l_o_wdCc As Object 'Word.ContentControl
Set GetAllDocumentContentControls = New VBA.Collection
For Each l_o_wdCc In p_o_wdDoc.ContentControls
GetAllDocumentContentControls.Add l_o_wdCc
Next l_o_wdCc
For Each l_o_wdSection In p_o_wdDoc.Sections
For Each l_o_wdHf In l_o_wdSection.Headers
For Each l_o_wdCc In l_o_wdHf.Range.ContentControls
GetAllDocumentContentControls.Add l_o_wdCc
Next l_o_wdCc
Next l_o_wdHf
For Each l_o_wdHf In l_o_wdSection.Footers
For Each l_o_wdCc In l_o_wdHf.Range.ContentControls
GetAllDocumentContentControls.Add l_o_wdCc
Next l_o_wdCc
Next l_o_wdHf
Next l_o_wdSection
Set l_o_wdSection = Nothing
Set l_o_wdHf = Nothing
Set l_o_wdCc = Nothing
End Function