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 |
Partager