Sub Envoi_avancement()
Dim Destinataire As String, Sujet As String
Dim AccuseReception As Boolean
Dim ETL(10) As String
Dim ETL_tab(10) As Boolean
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
' Gestion des onglets dans le carnet de commande source
Dim Onglet(30)
Dim Liste_demandeur(30)
Dim Feuille As Worksheet
Dim it_dem As Integer, NomOnglet As Integer
Set principal = ActiveWorkbook
principal.Activate
ActiveWorkbook.Sheets("Admin").Activate
'Déclaration des variables
Dim MyOlapp As Object
Dim myItem
Dim olMailItem
Dim myRecipients
Dim myAttachments
Dim strHTML As String
it_dem = 0
i_tab1 = 2
' Ouverture du document initial
Workbooks.Open Filename:=Fichier
' SERIE DE BOUCLE PERMETTANT DE RECUPERER DES INFORMATIONS SUR DIFFERENTS ONGLETS
' Puis on "incrémente" une variable add_DE de la façon suivante
Workbooks("pj").Activate
ActiveWorkbook.Sheets(Onglet(NomOnglet)).Activate
If attrib <> Cells(j, 30).Value Then
add_DE = 1
End If
If Date_CS <> Cells(j, 40).Value Then
add_DE = add_DE + 2
End If
If UO_FR <> Cells(j, 41).Value Then
add_DE = add_DE + 4
End If
If UO_RO <> Cells(j, 42).Value Then
add_DE = add_DE + 8
End If
If Date_liv <> Cells(j, 43).Value Then
add_DE = add_DE + 16
End If
If Status_liv <> Cells(j, 54).Value Then
add_DE = add_DE + 32
End If
If Progress <> Cells(j, 55).Value Then
add_DE = add_DE + 64
End If
If Ref_liv <> Cells(j, 57).Value Then
add_DE = add_DE + 128
End If
If Date_delivery <> Cells(j, 58).Value Then
add_DE = add_DE + 256
End If
' Plusieurs lignes de code où add_DE n'est plus exploitée
If add_DE <> 0 Then
' Ajouter une nouvelle Feuille à la fin du Classeur et la nommer
principal.Activate
FeuilleExiste = False
For Each Feuille In Worksheets
If Feuille.Name = Demandeur Then
FeuilleExiste = True
End If
Next Feuille
' Ajour d'une feuille car FeuilleExiste est toujours False
If FeuilleExiste = False Then
Sheets.Add(After:=Worksheets(Worksheets.Count)).Name = Demandeur
ActiveWorkbook.Sheets(Demandeur).Activate
' Première partie du tableau / "Validation estimations"
Cells(1, 1) = "Request number"
Cells(1, 2) = "Project"
Cells(1, 3) = "Function"
Cells(1, 4) = "Attribution"
Cells(1, 5) = "Date of supplier quotation (jj/mm/aaaa)"
Cells(1, 6) = "Number of UO FR"
Cells(1, 7) = "Number of UO Nearshore"
' Date à mettre dans l'ordre RequestedExpected-Proposed-Convergence-
Cells(1, 8) = "Proposed Delivery Date (jj/mm/aaaa)"
Cells(1, 9) = "Requested Delivery Date (jj/mm/aaaa)"
Cells(1, 10) = "Expected Delivery Date (jj/mm/aaaa)"
' Seconde partie du tableau / "Advancement"
Cells(1, 11) = "Request number"
Cells(1, 12) = "Project"
Cells(1, 13) = "Function"
Cells(1, 14) = "Attribution"
Cells(1, 15) = "Status"
Cells(1, 16) = "Work Progress (%)"
Cells(1, 17) = "Deliverables references"
Cells(1, 18) = "Delivery Date (jj/mm/aaaa)"
Liste_demandeur(it_dem) = Demandeur
it_dem = it_dem + 1
End If
i_tab = Range("C1048576").End(xlUp).Row + 1
Cells(i_tab, 1) = Num_QIA
Cells(i_tab, 2) = projet
Cells(i_tab, 3) = Module
Cells(i_tab, 4) = attrib
Cells(i_tab, 5) = Date_CS
Cells(i_tab, 6) = UO_FR
Cells(i_tab, 7) = UO_RO
Cells(i_tab, 8) = Date_liv
Cells(i_tab, 9) = Req_Date
Cells(i_tab, 10) = Expect_Date
Cells(i_tab, 11) = Num_QIA
Cells(i_tab, 12) = projet
Cells(i_tab, 13) = Module
Cells(i_tab, 14) = attrib
Cells(i_tab, 15) = Status_liv
Cells(i_tab, 16) = Progress
Cells(i_tab, 17) = Ref_liv
Cells(i_tab, 18) = Date_delivery
Cells(i_tab, 19) = add_DE
End If
End If
Next j
NomOnglet = NomOnglet + 1
Wend
principal.Activate
For it_dem_fin = 0 To it_dem - 1
' On passe à la construction d'un mail, je vous épargne le code, aucune référence à add_DE
'Boucle mail
ActiveWorkbook.Sheets(Liste_demandeur(it_dem_fin)).Activate
' Création du corps de texte pour chaque interlocuteur
For liv = 2 To DernLigne_lble_env 'nombre de lignes (exemple plage A1:B5)
strHTML = strHTML & "<TR halign='middle'nowrap>"
For j = 1 To 10 ' Nombre de colonnes
strHTML = strHTML & "<TD bgcolor='grey'align='center'><FONT COLOR='black'SIZE=3>" _
& Cells(liv, j) & "</FONT></TD>"
Next j
strHTML = strHTML & "</TR>"
End If
Next liv
' Code
For j = 11 To 18 ' Nombre de colonnes
strHTML = strHTML & "<TD bgcolor='blue'align='center'><FONT COLOR='white'SIZE=3>" _
& Cells(1, j) & "</FONT></TD>" ' Récupération des noms des colonnes pour mise en forme du tableau "Advancement"
Next j
DernLigne_lble_env = Range("A" & Rows.Count).End(xlUp).Row
For liv = 2 To DernLigne_lble_env 'nombre de lignes (exemple plage A1:B5)
If (Cells(liv, 19).Value And 32) = 32 Or (Cells(liv, 19).Value And 64) = 64 Or (Cells(liv, 19).Value And 128) = 128 Or (Cells(liv, 19).Value And 256) = 256 Then
strHTML = strHTML & "<TR halign='middle'nowrap>"
For j = 11 To 18 ' Nombre de colonnes
strHTML = strHTML & "<TD bgcolor='grey'align='center'><FONT COLOR='black'SIZE=3>" _
& Cells(liv, j) & "</FONT></TD>"
Next j
strHTML = strHTML & "</TR>"
End If
Next liv
' Récupération du mail du demandeur
Destinataire = ""
Dest = 2
While Not IsEmpty(Cells(Dest, 22).Value)
If Liste_demandeur(it_dem_fin) = Cells(Dest, 22).Value Then
Destinataire = Cells(Dest, 24).Value
End If
Dest = Dest + 1
Wend
' Si on ne trouve pas le mail du destinataire, il faut le créer
If Destinataire = "" Then
MsgBox "Le demandeur n'a pas été trouvé, merci de le créer"
NomUser = InputBox("Veuillez saisir Prénom Nom du demandeur :")
Cells(Dest, 23).Value = NomUser
NomUser = InputBox("Veuillez saisir l'identifiant du demandeur :")
Cells(Dest, 22).Value = NomUser
NomUser = InputBox("Veuillez saisir l'adresse mail du demandeur :")
Cells(Dest, 24).Value = NomUser
Destinataire = NomUser
End If
Set MyOlapp = CreateObject("Outlook.Application")
Set myItem = MyOlapp.CreateItem(olMailItem)
Set myRecipients = myItem.Recipients
' Destinataire pour les tests
myRecipients.Add ("A")
' Destinataires pour la production / A METTRE EN COMMENTAIRE PENDANT LES TESTS
' myRecipients.Add (Destinataire)
' myRecipients.Add ("B")
' myRecipients.Add (C")
' myRecipients.Add ("D")
Set myAttachments = myItem.Attachments
myItem.HTMLBody = strHTML
myItem.Subject = "[Updated request] Informations about your request"
' myItem.Send
Application.DisplayAlerts = False
ActiveWorkbook.Sheets(Liste_demandeur(it_dem_fin)).Delete
Application.DisplayAlerts = True
Next it_dem_fin
'xlBook.Save
'xlBook.Close
'Kill ("test.xls")
Workbooks.Item(old_version).Close
End Sub