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
| ' --------- Envoi d'un mail avec Lotus Notes ---------- .
'Ajouter la référence Lotus Domino Objects (domobj.tlb) .
'Cocher Référence [x]Lotus Domino Objects .
'entrée du CheminEtFichier s'il y a lieu
'entrée Sujet et Message As String
Sub UseLotus() '(CheminEtFichier As String, Sujet As String, Message As String)
Dim oSession As Object 'CreateObject("Notes.NotesSession")
Dim UserName As String 'Nom d'utilisateur
Dim DataBase As Object 'Base des mails
Dim DataBaseName As String 'Nom de la base
Dim Document As Object 'Mail
Dim AttachME As Object 'Fich joint en RTF
Dim AttachF1 As Object '1' pièce attachée
Dim i, j, txtbody, CheminEtFichier, Msg$, T$
On Error GoTo ErreurNET: Err.Clear '*****
' Crée la session
Set oSession = CreateObject("Notes.NotesSession")
Set Workspace = CreateObject("Notes.NotesUIWorkspace") '''''
' Récupère nom d'utilisateur
UserName = oSession.UserName
DataBaseName = Left$(UserName, 1) & Right$(UserName, (Len(UserName) - InStr(1, UserName, " "))) & ".nsf"
' Ouvre la base des mails (si fermé, ouvre et demande le password)
Set DataBase = oSession.GETDATABASE("", DataBaseName)
If Not DataBase.IsOpen Then DataBase.OPENMAIL
'########################## envoi ###############################################
'récupère dans la feuille nommée NomDeLaFeuilDATA$ et le Range nommé "CellDATA_AdresDestinataire"
'les adresses séparées par ";"
Dim Tablo As Variant, AdresDestinataire As String
' AdresDestinataire = Sheets("data").Range("b5")
AdresDestinataire = "toto@toto.com"
If InStr(AdresDestinataire, ";") = 0 Then AdresDestinataire = AdresDestinataire & ";"
Tablo = Split(AdresDestinataire, ";")
' boucle envoi .
For i = LBound(Tablo) To UBound(Tablo)
If Trim(Tablo(i)) > "" Then
AdresDestinataire = Tablo(i)
'crée le document et colle /AdresDestinataire /Sujet /Message
Set Document = DataBase.CREATEDOCUMENT
Document.Form = "Memo"
Document.SendTo = AdresDestinataire
Document.Subject = AC_New_Number & " - Une nouvelle action a été crée par " & Sheets("Description").TextBox1
'définition du corps du message
'For j = 1 To 10
txtbody = txtbody & Range("D" & j + 4) & vbLf
txtbody = "Problème : " & Sheets("Description").TextBox6 & vbLf
txtbody = txtbody & "Cause potentielle : " & Sheets("Description").TextBox5 & vbLf
txtbody = txtbody & vbLf & vbLf & vbLf & "E-mail généré automatiquement par la base Amélioration Continue"
'Next j
Document.Body = txtbody
'Joint le Fichier s'il y en a un !?
If CheminEtFichier <> "" Then
Set AttachME = Document.CREATERICHTEXTITEM("Attachment")
Set AttachF1 = AttachME.EmbedObject(1454, "", CheminEtFichier, "Attachment")
End If
'Envoi le Mail
Document.SAVEMESSAGEONSEND = False 'True svg dans les courriers envoyés
Document.PostedDate = Now()
Document.send 0, AdresDestinataire
' suite...
Set Document = Nothing: Set AttachME = Nothing: Set AttachF1 = Nothing
End If
Next
GoTo FinMail ' fin ##############################################################
ErreurNET:
Msg$ = "Erreur " & Err.Source & " No " & Err.Number & vbLf & vbLf & Err.Description
T$ = "Envoi Mail: Problème de connexion !?"
MsgBox Msg$, vbCritical, T$, Err.HelpFile, Err.HelpContext
GoTo FinMail
FinMail:
Set oSession = Nothing: Set DataBase = Nothing
Set Document = Nothing: Set AttachME = Nothing: Set AttachF1 = Nothing
On Error GoTo 0: Err.Clear
End Sub |
