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 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171
| Sub envoi_mail_Suivi()
'Déclaration
Dim Maildb As Object 'La database des mails
Dim UserName As String 'Le nom d'utilisateur
Dim MailDbName As String 'Le nom de la database des mails
Dim MailDoc As Object 'Le mail
Dim Session As Object 'La session Notes
Dim Signature As String 'La signature
Dim Sujet As String 'Le sujet du mail
Dim sHeaders(4) As String 'Les noms d'en-têtes du tableau
Dim Reference(50) As String 'Les valeurs de la colonne 1 du tableau
Dim Defaut(50) As String 'Les valeurs de la colonne 2 du tableau
Dim Action(50) As String 'Les valeurs de la colonne 3 du tableau
Dim Cible(50) As String 'Les valeurs de la colonne 4 du tableau
Dim rtsTableHeader As Object 'Mise en forme du texte en-têtes
Dim rtsTableRow As Object 'Mise en forme du texte cellules tableau
Dim Destinataire(0) As Variant 'Liste destinataire
Dim ccDestinataires(2) As Variant 'Liste destinataires en copie
Dim derligne As Integer 'Dernière ligne de la liste des destinataires
Dim ligdeb As Integer 'Première ligne, après filtre, de la liste des actions
Dim ligfin As Integer 'Dernière ligne, après filtre, de la liste des actions
Dim nbrow As Integer 'Nombre de lignes du tableau
Dim nbcol As Integer 'Nombre de colonnes du tableau
Dim rtnav As Object 'Variable de recherche dans le tableau
Dim jour As Long 'Date du jour
'------------------------------------------------------------------------------------------------------------------------------
'RECUPERATION DES DONNEES CLASSEUR:
Sheets("SUIVI CRIMES").Select
Range("$B$5:$Q$60000").AutoFilter Field:=5
Range("$B$5:$Q$60000").AutoFilter Field:=7
Range("$B$5:$Q$60000").AutoFilter Field:=14
Range("$B$5:$Q$60000").AutoFilter Field:=14, Criteria1:="=" 'Filtre sur les actions non soldées
jour = Date
Range("$B$5:$Q$60000").AutoFilter Field:=7, Criteria1:="<" & jour 'Filtre sur les actions ayant dépassé la date cible
' Défini les numéro de lignes (début et fin) lors du filtrage sur la colonne G)
Set Plage = [_filterdatabase].Offset(1).Resize(, 1)
Set Plage = Plage.Resize(Plage.Count - 1).SpecialCells(xlCellTypeVisible) 'Détermine la plage de cellules visibles
' Identifie les destinataires et mails à envoyer
ligdeb = Plage.Row 'Première ligne de la plage filtrée
ligfin = Range("F60000").End(xlUp).Row 'Dernière ligne de la plage filtrée
Range("F" & ligdeb & ":F" & ligfin).SpecialCells(xlCellTypeVisible).Copy 'On copie la plage de données visible
Sheets("Calculs").Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Sheets("Calculs").Range("$A$1:$A$" & ligfin - 5).RemoveDuplicates columns:=1, Header:=xlNo
If Sheets("Calculs").Range("A2").Value = "" Then 'Détermine la dernière ligne de la liste des destinataires
derligne = 1
Else
derligne = Sheets("Calculs").Range("A1").End(xlDown).Row
End If
For d = 1 To derligne 'Créé le mail et l'envoi pour chaque déstinataire : 1 boucle = 1 destinataire
Range("$B$5:$Q$60000").AutoFilter Field:=5, Criteria1:=Sheets("Calculs").Range("A" & d).Value 'Filtre sur l'action du destinataire
Set Plage = [_filterdatabase].Offset(1).Resize(, 1)
Set Plage = Plage.Resize(Plage.Count - 1).SpecialCells(xlCellTypeVisible)
If Range("G" & Plage.Row).Value = "" Then GoTo IterationSuivante 'Si le mail n'est pas renseigné, le mail n'est pas créé et on passe au destinataire suivant
Range("B5").Offset(1, 0).Select 'Donne la première ligne de notre tableur après le filtre
i = 0
j = 0
Do While j < 2 'Va jusqu'à 2 lignes vides après la dernière ligne visible filtrée
Do While ActiveCell.EntireRow.Hidden = True 'Teste si la ligne est visible
ActiveCell.Offset(1, 0).Select 'On se déplace dans notre tableur : +1 ligne
Loop
i = i + 1
If ActiveCell = "" Then 'Si la cellule ext vide alors...
j = j + 1
Else
Reference(i) = ActiveCell.Value 'Enregistre les valeurs, pour chaque ligne visible, dans des tables définies
Defaut(i) = ActiveCell.Offset(0, 1).Value
Action(i) = ActiveCell.Offset(0, 3).Value
Cible(i) = ActiveCell.Offset(0, 6).Value
End If
ActiveCell.Offset(1, 0).Select
Loop
'------------------------------------------------------------------------------------------------------------------------------
'CREATION DU MAIL:
Sujet = "Suivi du portefeuille des actions CRIME" 'On défini la variable Sujet
Destinataire(0) = Range("G" & Plage.Row).Value 'On défini la variable Destinataire
ccDestinataires(0) = "tutu@gmail.com" 'On défini la variable ccDestinataire
Set Session = CreateObject("Notes.NotesSession") 'Crée une session notes
UserName = Session.UserName 'Récupère le nom d'utilisateur et crée le nom de la base des mails
MailDbName = Left$(UserName, 1) & Right$(UserName, (Len(UserName) - InStr(1, UserName, " "))) & ".nsf"
Set Maildb = Session.GetDatabase("", MailDbName) 'Ouvre la base des mails
If Not Maildb.IsOpen Then Maildb.OPENMAIL 'Test si la base mail est bien ouverte
Set MailDoc = Maildb.CreateDocument 'Paramètre le mail à envoyer
'Call MailDoc.AppendItemValue("Form", "Memo")
'Call MailDoc.AppendItemValue("sendTo", Destinataire) 'Paramètre les destinataires des mails (par la table Destinataires)
'Call MailDoc.AppendItemValue("CopyTo", ccDestinataires) 'Paramètre les destinataires en copie des mails (par la table ccDestinataires)
'Call MailDoc.AppendItemValue("Subject", Sujet)
nbcol = 4 'Paramètre le nombre de colonnes du tableau
nbrow = Plage.Count + 1 'Paramètre le nombre de lignes du tableau (basé sur le nombre d'actions affectées au destinataire)
sHeaders(0) = "Référence" 'Première en-tête du tableau
sHeaders(1) = "Défaut" 'Seconde en-tête du tableau
sHeaders(2) = "Action" 'Troisième en-tête du tableau
sHeaders(3) = "Date Cible" 'Quatrième en-tête du tableau
'Signature = Maildb.GetProfileDocument("CalendarProfile").GetItemValue("Signature")(0) 'Récupération de la signature Notes
'MailDoc.AppendItemValue ("iTitle"), Maildb.GetProfileDocument("CalendarProfile").GetItemValue("iTitle") 'Récupération du titre
'MailDoc.Logo = "StdNotesLtr99"
'CORPS DU MESSAGE:
Set rtitem = MailDoc.CreateRichTextItem("Body") 'Paramètre le corps du mail
Call rtitem.AppendText("Bonjour,") 'Marque "Bonjour"
Call rtitem.AddNewLine(2) 'Ajoute un saut de ligne
If nbrow = 1 Then Call rtitem.AppendText("Voici, ci-dessous, l'action en cours qui vous est affectée :") 'Si une seule action alors ce texte
If nbrow >= 2 Then Call rtitem.AppendText("Voici, ci-dessous, les actions en cours qui vous sont affectées :") 'Si plusieurs actions alors ce texte
Call rtitem.AddNewLine(2)
Set rtsTableHeader = Session.CreateRichTextStyle 'Paramètre la police des en-têtes
rtsTableHeader.Bold = True 'Texte en gras
rtsTableHeader.FontSize = 12 'Texte en taille 12
Set rtsTableRow = Session.CreateRichTextStyle 'Paramètre la police des cellules
rtsTableRow.Bold = False 'Texte pas en gras
rtsTableRow.FontSize = 10 'Texte en taille 10
Call rtitem.AppendTable(nbrow, nbcol) 'Création du tableau avec nbrow lignes et nbcol colonnes
Set rtnav = rtitem.CreateNavigator 'Paramètre la variable de navigation dans le tableau
'La navigation dans le tableau fonctionne comme ceci : balayage des cellules de gauche à droite en priorité, puis de haut en bas.
Call rtitem.AppendStyle(rtsTableHeader) 'Renseigne les en-têtes
Call rtnav.FindFirstElement(RTELEM_TYPE_TABLECELL) 'Trouve la première cellule de mon tableau
For iCol = 1 To nbcol Step 1
Call rtitem.BeginInsert(rtnav) 'Insère un élément dans le tableau via rtnav
Call rtitem.AppendText(sHeaders(iCol - 1))
Call rtitem.EndInsert 'Arrête l'insertion de texte
Call rtnav.FindNextElement(RTELEM_TYPE_TABLECELL) 'Va à la prochaine cellule de mon tableau
Next
Call rtitem.AppendStyle(rtsTableRow) 'Renseigne les cellules du tableau
For iRow = 1 To nbrow Step 1
For iCol = 1 To nbcol Step 1
Call rtitem.BeginInsert(rtnav)
If iCol = 1 Then Call rtitem.AppendText(Reference(iRow))
If iCol = 2 Then Call rtitem.AppendText(Defaut(iRow))
If iCol = 3 Then Call rtitem.AppendText(Action(iRow))
If iCol = 4 Then Call rtitem.AppendText(Cible(iRow))
Call rtitem.EndInsert
Call rtnav.FindNextElement(RTELEM_TYPE_TABLECELL)
Next
Next
'signature
Call rtitem.AddNewLine(1)
Call rtitem.AppendText("Cordialement,")
Call rtitem.AddNewLine(1)
Call rtitem.AppendText("Prenom Nom")
'Call rtitem.appendtext(Signature)
'Call rtitem.AddNewLine(2)
MailDoc.SaveMessageOnSend = True 'Sauvegarde le mail envoyé
MailDoc.PostedDate = Now()
Call MailDoc.Save(True, False)
MailDoc.Send 0 'Envoie le mail
Erase Reference 'Initialise les variable tableau pour les mails des prochains contacts
Erase Defaut
Erase Action
Erase Cible
IterationSuivante:
Next
End Sub |
Partager