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