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
| Sub Envoi_Mail()
Dim olapp As Outlook.Application
Dim malist, Count, Envoi, AdresseRépertoire As Variant
'On Error Resume Next
'-------Contrôler dans Visual Basic/Outils/Références/que Microsoft Outlook --,- Object Librairy est bien coché
Dim Sujet As String
Dim Corps As String
' Effacement des doonées sur feuille Matrice Mail
Sheets("Matrice Mail").Select
Cells.Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlUp
Range("A1").Select
'Boucle
Do
'Boite de dialogue demandant le sujet du mail
Sujet = InputBox("Veuillez saisir le sujet de votre @mail :" & Chr$(13) & "ATTENTION : la saisie est obligatoire.", "Sujet")
'si sujet non saisi alors retour jusqu a saisi
If Sujet = "" Then
MsgBox "Vous n'avez pas saisi de sujet." _
& "La zone est obligatoire", vbExclamation
End If
Loop Until Sujet <> "" 'Fin de boucle
'Boucle
Do
'Boite de dialogue demandant le corps du message
Corps = InputBox("Veuillez saisir le corps de votre message : " & Chr$(13) & "ATTENTION : la saisie est obligatoire.", "Corps")
'si Corps non saisi alors retour jusqu a saisi
If Corps = "" Then
MsgBox "Vous n'avez pas saisi de texte pour le corps de votre message." _
& "La zone est obligatoire", vbExclamation
End If
Loop Until Corps <> "" ' Fin de boucle
Dim adresse(1 To 150)
'----------------------Création de la liste d'adresses mail contenus de la ligne 2 à 151
Set malist = Sheets("Envoi Mail").Range("A2:A151")
Count = 1
For Each Envoi In malist
If Len(Envoi) Then adresse(Count) = Envoi: Count = Count + 1
Next
'----------------------Copie de la liste d'adresse dans une cellule vide exemple H1
For i = 1 To 150
If adresse(i) = "" Then Exit For
If adresse(i) Like "*@*" Then [H1] = [H1] & ";" & adresse(i)
Next i '-------adresse du répertoire ou sera enregistré le fichier
AdresseRépertoire = ActiveWorkbook.Path
'---------------------copie de la feuille à envoyer
Application.DisplayAlerts = False
Sheets("Matrice Mail").Copy
'---------------------Nom du fichier à envoyer
Dim NameXls As String
Do
'Boite de dialogue demandant le Nom du fichier à envoyer
NameXls = InputBox("Veuillez saisir le nom du fichier à envoyer :" & Chr$(13) & "ATTENTION : la saisie est obligatoire.", "Nom du fichier à envoyer")
'si NameXls non saisi alors retour jusqu a saisi
If NameXls = "" Then
MsgBox "Vous n'avez pas saisi de nom pour le fichier à envoyer." _
& "La zone est obligatoire", vbExclamation
End If
Loop Until NameXls <> ""
'ActiveWorkbook.SaveAs AdresseRépertoire & "\" & "Class.xls" ' ou adresse si le nom est dans une cellule Range("E2").Value & ".xls"
'ActiveWindow.Close
ActiveWorkbook.SaveAs AdresseRépertoire & "\" & NameXls & ".xls"
ActiveWindow.Close
'---------------------Envoi par mail
Sheets("Envoi Mail").Select
Range("H1").Select
'---------------------contrôle la validité ou la présence d'adresse mail en H1
Dim msg As MailItem
Set olapp = New Outlook.Application
Set msg = olapp.CreateItem(olMailItem)
msg.To = Range("H1").Value 'Adresse de la cellule contenant la liste des adesses mails
'--------------------Saisir le sujet de l'envoi
'msg.Subject = "Coucou c'est moi "
' ou saisir le sujet dans une cellule ex. Range("H2").Value
'msg.Subject = Range("H2").Value
msg.Subject = Sujet 'Sujet étant la InputBox
'---------------------saisie du message
'msg.Body = "Bonjour" & Chr(13) & Chr(13) & "Veuillez trouver ci-joint" & Chr(13) & "copie du dossier" & Chr(13) & Chr(13) & "Cordialement"
'---------------------ou saisir le message dans des cellules
'msg.Body = Range("E5").Value & Chr(13) & Chr(13) & Range("E7").Value & Chr(13) & Chr(13) & Range("E9").Value
'---------------------ou saisir le message dans InputBox Corps
msg.Body = Corps
'---------------------Adresse de la pièce jointe
'msg.Attachments.Add Source:=AdresseRépertoire & "\" & "Class.xls" ' ou adresse si le nom est dans une cellule Range("E2").Value & ".xls"
'msg.Attachments.Add Source:=AdresseRépertoire & "\" & Range("E2").Value & ".xls"
msg.Attachments.Add Source:=AdresseRépertoire & "\" & NameXls & ".xls"
msg.Send
'---------------------effacement de la liste d'envoi
[H1].ClearContents
Application.ScreenUpdating = True
[A2:A151].ClearContents
Range("A1").Select
Sheets("Requete").Select
Range("A1").Select
'rep = MsgBox("Votre @mail a été transmis aux différents destinataires, le " & Date & " à " & Time, vbYes + vbInformation, " Transmission de mail / Application développée par XXXXXXXXX.")
' Select Case MsgBox("Désirez-vous effectuer une autre requête ?", vbYesNo, "Application développée par XXXXXXX C.")
' Case vbYes
'procédure si click sur Oui
' rep = MsgBox("Veuillez sélectionner une nouvelle requête.", vbYes + vbInformation, "Sélection nouvelle requête / Application développée par XXXXXXXXX.")
' Case vbNo
'procédure si click sur Non
' Sheets("Accueil").Select
'End Select
End Sub |
Bug sur Envoi de mail Outlook à partir d'une macro
Répondre avec citation
Partager