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
| Option Explicit
Const EMBED_ATTACHMENT As Long = 1454
Sub EnvoiMail()
Dim stFileName As String
Dim vaRecipients As Variant
Dim vaCopyTo As Variant
Dim vaMsg As Variant
Dim stSubject As Variant
Dim stPath As String
Dim noSession As Object
Dim noDatabase As Object
Dim noDocument As Object
Dim noEmbedObject As Object
Dim noAttachment As Object
Dim stAttachment As String
Dim Workspace As Object
Dim EditDoc As Object
'Destinataire du mail A et CC ---- Début
Dim cellule_début As String
Dim ligne_dest_début As Integer
Dim colonne_dest_A As Integer
Dim colonne_dest_CC As Integer
Dim ligne_dest_suite As Integer
Dim colonne_mail As Integer
Dim Chemin As String
Chemin = Workbooks(ActiveWorkbook.Name).FullName
Range("D214").Value = Chemin
cellule_début = ActiveSheet.Range("D200").Value
ligne_dest_début = ActiveSheet.Range(cellule_début).Row
colonne_dest_A = ActiveSheet.Range(cellule_début).Column
colonne_dest_CC = colonne_dest_A + 1
colonne_mail = colonne_dest_A + 5
ligne_dest_suite = ligne_dest_début
Do While ligne_dest_suite < ligne_dest_début + ActiveSheet.Range("D201").Value
If ActiveSheet.Cells(ligne_dest_suite, colonne_dest_A).Value <> "" Then
vaRecipients = vaRecipients & ", " & ActiveSheet.Cells(ligne_dest_suite, colonne_mail)
End If
ligne_dest_suite = ligne_dest_suite + 1
Loop
ligne_dest_suite = ligne_dest_début
Do While ligne_dest_suite < ligne_dest_début + ActiveSheet.Range("D201").Value
If ActiveSheet.Cells(ligne_dest_suite, colonne_dest_CC).Value <> "" Then
vaCopyTo = vaCopyTo & ", " & ActiveSheet.Cells(ligne_dest_suite, colonne_mail)
End If
ligne_dest_suite = ligne_dest_suite + 1
Loop
MsgBox "Mail A:" & vbCrLf & vaRecipients & vbCrLf & "Mail CC:" & vbCrLf & vaCopyTo
'Destinataire du mail A et CC ---- Fin
'Objet du mail
stSubject = ActiveSheet.Range("D205").Value
'MsgBox vaRecipients(1)
'Corps du mail
Dim cellule As String
Dim cellule_col_check As String
Dim cellule_col_texte As String
Dim cellule_lin As String
'Définition de la cellule de début du texte
cellule_col_check = "C"
cellule_col_texte = "D"
cellule_lin = 210
' Pas toucher !!!! c'est pour la logique de boucle
cellule = ActiveSheet.Range(cellule_col_check & cellule_lin).Value
Do While cellule <> ""
'Construction du texte à adapter selon volonté
vaMsg = vaMsg & vbCrLf & ActiveSheet.Range(cellule_col_texte & cellule_lin)
' Pas toucher !!!! c'est pour la logique de boucle
cellule_lin = cellule_lin + 1
cellule = ActiveSheet.Range(cellule_col_check & cellule_lin).Value
Loop
' Titre de la boîte de message
MsgBox "Extrait du mail généré dans votre LOTUS NOTES" & vbCrLf & vaMsg
'Pas toucher LOTUS NOTES ***************************************************************************************************
'Instantiate the Lotus Notes COM's Objects.
Set noSession = CreateObject("Notes.NotesSession")
Set noDatabase = noSession.GETDATABASE("", "")
'If Lotus Notes is not open then open the mail-part of it.
If noDatabase.IsOpen = False Then noDatabase.OPENMAIL
'Create the e-mail and the attachment.
Set noDocument = noDatabase.CreateDocument
' Set noAttachment = noDocument.CreateRichTextItem("stAttachment")
' Set noEmbedObject = noAttachment.EmbedObject(EMBED_ATTACHMENT, "", stAttachment)
'Add values to the created e-mail main properties.
With noDocument
.Form = "Memo"
.SendTo = vaRecipients
.CopyTo = vaCopyTo
.Subject = stSubject
.Body = vaMsg
End With
'Disable signature in users mail profile (dés-activation de la signature)
Dim SigDoc As Object
Dim iSig As Variant
Dim iSigOption_old As String
Dim iSigOption_new As String
Set SigDoc = noDatabase.GetProfileDocument("CalendarProfile")
iSigOption_old = SigDoc.GetItemValue("SignatureOption")(0)
If iSigOption_old <> "" Then
SigDoc.SignatureOption = ""
End If
'Show memo to UI/front end (création du mail en mode édition)
Set Workspace = CreateObject("Notes.NotesUIWorkspace")
Set EditDoc = Workspace.EditDocument(True, noDocument)
'Re-enable signature in users mail profile (Ré-activation de la signature avec l'ancienne valeur)
iSigOption_new = SigDoc.GetItemValue("SignatureOption")(0)
If Not iSigOption_new = iSigOption_old Then
SigDoc.SignatureOption = iSigOption_old
End If
Call EditDoc.FieldSetText("EnterCopyTo", vaCopyTo)
'Delete the temporarily workbook.
' Kill stAttachment
'Release objects from memory.
' Set noEmbedObject = Nothing
' Set noAttachment = Nothing
Set noDocument = Nothing
Set noDatabase = Nothing
Set noSession = Nothing
Set Workspace = Nothing
Set EditDoc = Nothing
End Sub
'Pas toucher LOTUS NOTES *************************************************************************************************** |
Partager