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
| Sub Mail()
On Error GoTo erreur
Dim ol As Object, myItem As Object
Dim FSObj As Scripting.FileSystemObject, TStream As Scripting.TextStream
Dim rngeSend As Range, strHTMLBody As String
ActiveWorkbook.ActiveSheet.Unprotect Password:="xxxxx"
Set ol = CreateObject("outlook.application")
Set myItem = ol.CreateItem(olMailItem)
Set rngeSend = Range("A1:F15")
'Crée le fichier HTML
Dim temp As String
temp = UCase(Environ("TEMP"))
ActiveWorkbook.PublishObjects.Add(xlSourceRange, temp & "\sht.htm", _
rngeSend.Parent.Name, rngeSend.Address, xlHtmlStatic).Publish True
'Ouvre le fichier HTML avec FilesystemObject et le met dans un objet TextStream
Set FSObj = New Scripting.FileSystemObject
Set TStream = FSObj.OpenTextFile(temp & "\sht.htm", ForReading)
strHTMLBody = TStream.ReadAll
'Crée et envoie le courriel
myItem.To = "_Boite Traitement Documents"
myItem.Subject = "Demande de documents : " & ActiveSheet.Range("A1").Value
myItem.htmlBody = strHTMLBody
myItem.Send
Set ol = Nothing
MsgBox "Demande envoyée avec succès.", vbOKOnly, "Courriel"
ActiveWorkbook.ActiveSheet.Protect Password:="xxxxx"
Exit Sub
erreur:
MsgBox Err.Number & ": " & Err.Description & " Impossible d'envoyer la demande. Contactez le support informatique.", vbOKOnly, "Courriel"
End Sub |
Partager