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 |
Partager