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 |
procédure VBA écrite dans MS Project 2003
Répondre avec citation
Partager