Envoi par mail d'une sélection de cellules aléatoires

Bonjour à tous,

Régulièrement j'ai besoin de sélectionner une plage de cellules dans une feuille excel et l'envoyer par mail via Outlook. Pour ce faire, j'utilise le code ci-dessous et cela fontionne parfaitement. Par contre j'aimerais rajouter plusieurs choses afin d'automatiser encore plus cette tâche récurrente :

• les destinataires du mail (ce sont toujours les mêmes),
• l'objet du mail (toujours le même)
• Un message dans le corps du mail (message type toujours identique)

Merci pour votre aide précieuse.

Option Explicit

'-----------------------------------------------------------------------
'
' Lit le contenu d'un fichier texte et retourne son
' contenu
'
'-----------------------------------------------------------------------

 Public Function ReadFile(sFileName) As String

Dim fso As Object, 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

'-----------------------------------------------------------------------'
' Cette routine va créer une instance de Outlook (si
' pas encore démarré) et va ensuite ouvrir une
' fenêtre de type mail.   Le corps du message sera
' initialisé avec le contenu d'un fichier de type
' HTML.   Ce fichier aura été préalablement
' créé par la routine SendRangeByMail
'
' Nécessite l'ajout d'une référence vers "Microsoft
' Outlook Object Library"
'
'-----------------------------------------------------------------------

 Sub PrepareOutlookMail(ByVal sFileName As String)

Dim appOutlook As Outlook.Application
Dim oMail As Outlook.MailItem

   Set appOutlook = CreateObject("Outlook.Application")

   ' Si Outlook n'était pas ouvert, l'instruction
    ' ci-dessus aura eu pour conséquence de
    ' démarrer Outlook.
    'Ce type de démarrage par automation fait
    'apparaître une fenêtre de sécurité qui demande
    'à l'utilisateur de permettre au programme de
    'continuer.
    '
    'Le message est "A program is trying to send an
    'email.   Do you want to allow..."
    '
    'Dans le cas où l'utilisateur aurait cliqué sur No,
    'l'objet appOutlook est égal à Nothing.  Il est
    'donc impossible de continuer.

   If Not (appOutlook Is Nothing) Then

      Set oMail = appOutlook.CreateItem(olMailItem)

      oMail.HTMLBody = ReadFile(sFileName)

      oMail.Display

      Set oMail = Nothing
      Set appOutlook = Nothing

   End If

End Sub

'-----------------------------------------------------------------------
'
' La routine SendRangeByMail va proposer à
' l'utilisateur de sélectionner une plage de cellules
' en Excel et va ensuite envoyer cette plage par
' mail, dans le corps du mail.
'
'-----------------------------------------------------------------------

 Sub SendRangeByMail()

Dim rngeSend As Range

   With Application

      On Error Resume Next

      ' Demande à l'utilisateur de sélectionner la
      ' plage de cellule

      Set rngeSend = .InputBox(Prompt:="Sélectionnez une plage de cellules avec la souris", Type:=8, Default:=.Selection.Address)

      ' rngeSend Is Nothing lorsque l'utilisateur ne fait
      ' aucun choix

       If rngeSend Is Nothing Then Exit Sub

      On Error GoTo 0

      ' Exporte la plage vers un fichier de type HTML;
      ' ceci afin de respecter la mise en page de la
      ' plage

      .ActiveWorkbook.PublishObjects.Add(4, "C:\Temp\XLRange.htm", rngeSend.Parent.Name, rngeSend.Address, 0, "", "").Publish True

      ' Appelle la routine qui va se charger de créer
      ' un mail

      Call PrepareOutlookMail("C:\Temp\XLRange.htm")

      ' Le fichier HTML n'est plus nécessaire

      Kill "C:\Temp\XLRange.htm"

   End With ' With Application

End Sub

Bonsoir,

la partie du ode qu'il faut adapter, que j'ai remplie avec un exemple. tu peux aussi provoquer automatiquement l'envoi du mail en ajoutant une instruction omail.send au lieu de l'instruction omail.display

 Sub PrepareOutlookMail(ByVal sFileName As String)

Dim appOutlook As Outlook.Application
Dim oMail As Outlook.MailItem
Dim monmessage As String

   Set appOutlook = CreateObject("Outlook.Application")

   ' Si Outlook n'était pas ouvert, l'instruction
   ' ci-dessus aura eu pour conséquence de
   ' démarrer Outlook.
   'Ce type de démarrage par automation fait
   'apparaître une fenêtre de sécurité qui demande
   'à l'utilisateur de permettre au programme de
   'continuer.
   '
   'Le message est "A program is trying to send an
   'email.   Do you want to allow..."
   '
   'Dans le cas où l'utilisateur aurait cliqué sur No,
   'l'objet appOutlook est égal à Nothing.  Il est
   'donc impossible de continuer.

   If Not (appOutlook Is Nothing) Then

      Set oMail = appOutlook.CreateItem(olMailItem)
      oMail.To = "arthur@nimportequoi.com"
      oMail.Subject = "sujet vachement intéressant"

      monmessage = "cher ami, tu trouveras ci-joint une tartine excel pleine de bon sens" & vbCrLf
      monmessage = monmessage & " Je t'invite à en prendre connaissance et à me communiquer ton impression générale sur la pertinence"
      monmessage = monmessage & " du contenu envoyé." & vbCrLf & vbCrLf & ReadFile(sFileName)
      monmessage = monmessage & vbCrLf & vbCrLf & "un ami qui te veut du bien ..."

      oMail.HTMLBody = monmessage

      oMail.Display

      Set oMail = Nothing
      Set appOutlook = Nothing

   End If

End Sub

Merci h2so4,

Tu as parfaitement répondu au résultat que j'attendais, et de plus avec humour

Encore merci à toi