Macro VBA depuis project vers word

Voici une procédure VBA écrite dans MS Project 2003, qui ouvre Word et y dépose des stats dans un tableau word
Cordialement,
Code:
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
Sub BuildWordReference()
Dim Ref As String
Dim R As Object
    On Error Resume Next
 
'No need to carry on if the Word Object Library is already there:
'---------------------------------------------------
For Each R In ThisProject.VBProject.References
     If R.GUID = "{00020905-0000-0000-C000-000000000046}" Then
        Exit Sub
     End If
Next
 
ThisProject.VBProject.References.AddFromGuid _
GUID:="{00020905-0000-0000-C000-000000000046}", Major:=0, Minor:=0
 
On Error GoTo 0
End Sub
 
Sub AppelleWord()
 
Dim wrdApp As Word.Application
Dim wrdDoc As Word.document
    Dim FichePilotage As String, Clic As Integer, Service As Variant, Chemin As String
    Dim Deb As Date
    Dim Fin As Date
 
    FichePilotage = ActiveProject.BuiltinDocumentProperties("Category")
    If FichePilotage = "" Then
        MsgBox "Vous devez indiquer le nom de la Fiche de pilotage : " & Chr(13) & "document Word sans l'extension "".doc""" & Chr(13) & "dans la zone ""Catégorie"" de Fichier / Propriétés", vbCritical, "Arrêt de la procédure"
        Exit Sub
    End If
 
    If ActiveProject.ProjectSummaryTask.BaselineWork = 0 Then
        MsgBox "Le projet " & ActiveProject.Name & " n'a pas été planifié : " & Chr(13) & "Outils / Suivi / Enregistrer la planification initiale", vbCritical, "Export des données vers Excel interrompu"
    Exit Sub
 
    End If
    Set wrdApp = CreateObject("Word.Application")       '=/= New Word.Application (Late Binding)
 
    On Error Resume Next
 
    With wrdApp
        Chemin = CreateObject("wscript.shell").SpecialFolders("mydocuments") & "\Pilotage\" 'Retrouve dynamiquement le répertoire "Mes documents"
        On Error Resume Next
        '=========================================
        'Late Binding = Référence Tardive (Pas de référence sur Word dans Outils / Références
        Set wrdDoc = wrdApp.Documents.Open(FileName:=Chemin & FichePilotage & ".doc")
 
        If Err.Number = 5174 Then
            MsgBox "Vous devez préciser le nom correct de la Fiche de pilotage : " & Chr(13) & "document Word sans l'extension "".doc""" & Chr(13) & "dans la zone ""catégorie"" de Fichier / Propriétés", vbCritical, "Arrêt de la procédure : Fiche de pilotage non trouvée"
            Exit Sub
        End If
        wrdDoc.Activate
        'wrdDoc.GoTo what:=wdGoToBookmark, Name:="MonTablo"  'Va sur le signet. Pas de () sinon exige '= valeur'
        .Visible = False
        'Nom du projet :
        wrdDoc.Tables(2).Cell(Row:=2, Column:=4).Range.Text = Left(ActiveProject.Name, Len(ActiveProject.Name) - 7)   'Nom du projet sans l'extension ".publié"
        'Nom du CdP :
        wrdDoc.Tables(2).Cell(Row:=1, Column:=4).Range.Text = ActiveProject.ProjectSummaryTask.EnterpriseProjectOutlineCode3 'Nom du CdP
 
        'Vérifie date de dernier export :
        Dim DateMaJ As Date, LundiPrec As Date, VendSuivant As Date, Cloc As Integer
        If ActiveProject.ProjectSummaryTask.EnterpriseProjectDate1 = "NC" Or ActiveProject.ProjectSummaryTask.EnterpriseProjectDate1 = "NA" Then
        ActiveProject.ProjectSummaryTask.EnterpriseProjectDate1 = Date
        End If
 
        DateMaJ = ActiveProject.ProjectSummaryTask.EnterpriseProjectDate1
        LundiPrec = Date - (Weekday(Date, 2) - 1)
        VendSuivant = LundiPrec + 5
        'Debug.Print DateMaJ, LundiPrec, VendSuivant
        If DateMaJ > LundiPrec And DateMaJ < VendSuivant Then
            Cloc = MsgBox("La mise à jour de la Fiche de Pilotage du projet a déja été effectuée le : " & Format(DateMaJ, "dd/mm/yyyy") & Chr(13) & "Voulez vous la remplacer ?", vbYesNo + vbDefaultButton2, "Mise à jour hebdomadaire de la Fiche de pilotage du planning " & ActiveProject.Name)
            If Cloc = vbNo Then     'vbNo = 7, vbYes = 8
                wrdDoc.Close SaveChanges:=False     'Ferme le document sans sauvegarde !
                wrdApp.Quit
                Set wrdApp = Nothing
                Set wrdDoc = Nothing
                Exit Sub
            End If
        End If
 
ActiveProject.ProjectSummaryTask.EnterpriseProjectDate1 = Date
MsgBox "Le travail d'export va commencer" & Chr(13) & "Vous patienterez 30 secondes"
 
        'Si pas de période définie :
        If Left(wrdDoc.Tables(1).Cell(Row:=1, Column:=4).Range.Text, Len(wrdDoc.Tables(1).Cell(Row:=1, Column:=4).Range.Text) - 2) = "" Then 'Pas de date de période
            Deb = Date - (Weekday(Date, 2) + 6)     '-1
            Fin = Deb + 4
        Else
            'Incrémentation systématique des dates de période:
            Deb = Left(wrdDoc.Tables(1).Cell(Row:=1, Column:=4).Range.Text, Len(wrdDoc.Tables(1).Cell(Row:=1, Column:=4).Range.Text) - 2)
            Deb = Deb + 3
            Fin = Deb + 4
        End If
 
        Clic = MsgBox("Confirmez-vous les dates de début et de fin de la période : " & Chr(13) & _
            " - Début : " & Format(Deb, "dd/mm/yyyy") & Chr(13) & _
            " - Fin : " & Format(Fin, "dd/mm/yyyy") & Chr(13) & "sinon redéfinissez les dates de la période précédante dans la Fiche de Pilotage", vbOKCancel, "Définition de la semaine du rapport")
 
        If Clic = vbCancel Then
            wrdDoc.Close SaveChanges:=False     'Ferme le document sans sauvegarde !
            wrdApp.Quit
            Set wrdApp = Nothing
            Set wrdDoc = Nothing
            Exit Sub
        End If
 
        wrdDoc.Tables(1).Cell(Row:=1, Column:=2).Range.Text = Deb
        wrdDoc.Tables(1).Cell(Row:=1, Column:=4).Range.Text = Fin
        'Date de mise à jour : "Charges arrêtées le :"
        wrdDoc.Tables(3).Cell(Row:=1, Column:=2).Range.Text = Format(Date, "dd/mm/yyyy")
 
        'Si la cellule "Service" est vide...
        If Left(wrdDoc.Tables(2).Cell(Row:=1, Column:=2).Range.Text, Len(wrdDoc.Tables(2).Cell(Row:=1, Column:=2).Range.Text) - 1) = Chr(13) Then
            Service = InputBox("Saisissez le code Service : " & Chr(13) & "Entité / Direction / Pôle / Domaine", "Définition de la fiche de Pilotage du projet " & ActiveProject.Name)
            If Service = vbCancel Then Exit Sub
            wrdDoc.Tables(2).Cell(Row:=1, Column:=2).Range.Text = Service
        End If
 
        Call CelluleTablo
        Call JalonsPérimètre
    End With
    wrdDoc.Close SaveChanges:=True     'Ferme le document avec sauvegarde !
    wrdApp.Quit
    Set wrdApp = Nothing
    Set wrdDoc = Nothing
    Call RemoveWordReference
MsgBox "Export des données Project vers " & FichePilotage & Chr(13) & "Terminé", , "Fiche de pilotage de " & ActiveProject.Name
 
End Sub