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
| '-----------------------------------------------------------------------
'
'Quand on clicke sur le bouton de commande 2, la routine SendRangeByMail est lancée.
'
'certain VBA methods are disabled when an ActiveX control is active.
'The workaround is to activate something else before doing what you need to.
'That's the purpose of the 1st line. Otherwise the macro doesn't work.
'(from <a href="http://forums.anandtech.com/showthread.php?t=313822" target="_blank">http://forums.anandtech.com/showthread.php?t=313822</a>)
'
'-----------------------------------------------------------------------
Private Sub CommandButton2_Click()
Range("A1").Activate
SendRangeByMail
End Sub
'-----------------------------------------------------------------------
'
' La routine SendRangeByMail exporte la plage de données vers un fichier tampon de type HTML.
' Ce format est utilisé afin de respecter la mise en page de la plage dans la feuille Excel.
' Ensuite, cette plage sera collée dans le corps d'un e-mail par une autre routine.
'
'-----------------------------------------------------------------------
Public Sub SendRangeByMail()
Dim rngeSend As Range
Set rngeSend = Range("O1:R36")
With ActiveWorkbook.PublishObjects.Add(4, "C:\temp\XLRange.htm", rngeSend.Parent.Name, rngeSend.Address, 0, "", "")
.Publish (True)
End With
Call SendFile2DistributionList_IO("C:\Temp\XLRange.htm") 'Appelle la routine qui va créer le mail
Kill "C:\Temp\XLRange.htm" 'Le fichier HTML n'étant plus nécessaire, il est supprimé
End Sub
Option Explicit
'-----------------------------------------------------------------------
'
' Lit le contenu d'un fichier texte et retourne son contenu
'
'-----------------------------------------------------------------------
Public Function ReadFile(sFileName) As String
Dim fso, fFile As Object
Dim sTemp As String
Set fso = CreateObject("Scripting.FileSystemObject")
Set fFile = fso.OpenTextFile(sFileName, 1, False)
sTemp = fFile.ReadAll
fFile.Close
Set fFile = Nothing
ReadFile = sTemp
End Function
'----------------------------------------------------------------------
Sub SendFile2DistributionList_IO(ByVal sFileName As String)
Dim PromptMsg
Dim n As Integer
Dim OutApp As Object
Dim OutMail As Object
Dim directory As String
Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = "recipient@domaine.com"
.CC = ""
.BCC = ""
.Subject = "Reporting " & Date
.HTMLBody = ReadFile(sFileName)
.Display
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
'-------------------------------------------------------------------
'-------------------------------------------------------------------
'------------------------------------------------------------------- |
Partager