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
| Option Explicit
Sub EnvoiMail()
' Dimensionnement des variables----------------------------------------------------------------------------------------------------------------------------------------------------
Dim LeNom As String, MonTo As String, strBody As String
Dim LaLigne As Long, NbAd As Long, DerLig As Long, r As Long
Dim MaRech As Range, rng As Range
Dim Ol_App As Outlook.Application
Dim Ol_Item As Outlook.MailItem
Dim S As Shape
'----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
' Récupère le tableau -------------------------------------------------------------------------------------------------------------------------------------------------------------
Set rng = Nothing
Set rng = Sheets("Formulaire").UsedRange
'----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
' Récupération des adresses e-mail selon le choix du fournisseur-------------------------------------------------------------------------------------------------------------------
LeNom = Sheets("Formulaire").Range("LeFournisseur") 'Récupère le nom du fournisseur, servira à la recherche
DerLig = Sheets("BaseFournisseurs").Cells(Sheets("BaseFournisseurs").Columns(1).Cells.Count, 1).End(xlUp).Row 'récupère la dernière ligne remplie pour la plage de recherche
With Sheets("BaseFournisseurs").Range(Sheets("BaseFournisseurs").Cells(4, 1), Sheets("BaseFournisseurs").Cells(DerLig, 1))
Set MaRech = .Find(LeNom, LookIn:=xlValues) 'Recherche le nom dans la colonne 1
End With
NbAd = Sheets("BaseFournisseurs").Cells(MaRech.Row, Sheets("BaseFournisseurs").Rows(MaRech.Row).Cells.Count).End(xlToLeft).Column - 1 'Compte le nombre d'adresse !!ca ne gère pas le CC
For r = 2 To NbAd + 1 'Boucle sur les adresse e-mail via les colonnes, +1 car 1ère adresse en colonne B
MonTo = MonTo & Sheets("BaseFournisseurs").Cells(MaRech.Row, r) & "; " 'Ajout de l'adresse à la variable MonTo
Next r
'----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
' Envoi du mail via Outlook--------------------------------------------------------------------------------------------------------------------------------------------------------
strBody = "Bonjour," & "<br>" & _
"Veuillez trouver une nouvelle demande de livraison." & "<br>"
Set Ol_App = Outlook.Application
Set Ol_Item = Ol_App.CreateItem(olMailItem)
With Ol_Item
.To = MonTo 'Affecte les adresses e-mail
.Subject = "Demande de Livraison" 'Défini le sujet du message
.BodyFormat = olFormatHTML 'Défini le format du mail
.HTMLBody = strBody & RangetoHTML(rng) 'Affecte le corps du message et lance la function pour insérer la "tableau"
.Send 'Envoi le message !!cette procédure oblige une confirmation manuelle
End With
Set Ol_Item = Nothing 'Décharge
Set Ol_App = Nothing 'Décharge
'----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
End Sub
Function RangetoHTML(rng As Range)
' Inspiré d'une procédure de Ron de Bruin 28-Oct-2006
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
'Copie de la plage dans un nouveau classeur
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
End With
'Publie la feuille en format HTML
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
'Transpose en HTML
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.ReadAll
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
"align=left x:publishsource=")
'Ferme le fichier temporaire
TempWB.Close savechanges:=False
'Supprime le fichier HTML temporaire
Kill TempFile
'Libération
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function |
