Envoi mail en vba avec corps message

Option Explicit

' Procédure Envoi_Courriel
' Michel Blais
' Création  : Samedi, le 22 Décembre 2007
' Modifier  :
' Version 2.0.0
' Utilisation de OutlookExpress pour courrier sortant
' Sortie : Notification d'automatisme

' Déclaration de constantes
  Const cteLecture = 1
  Const cteEcriture = 2
  Const cteAjouter = 8
  Const cteAdresseSource = "mon.nom@serveur.net"
  Const cteAdresseDefaut = "ton.nom@serveur.net"
'

' Paramètre [ Boite ]
' Boite(0) -> "destination@serveur.net"     ' Adresse courriel de destination
' Boite(1) -> "Automatisme"                 ' Titre du message
' Boite(2) -> "Message"                     ' Texte du message
' Boite(3) -> "Fichier.txt"                 ' Fichier joint
' Boite(4) ->  "True"                       ' Indice d'inclusion de la pièce jointe

Sub Envoi_Courriel()

    Dim BigBox(0 To 5) As Variant
    
    BigBox(0) = "Mon.Adresse@monserveur.net"
    BigBox(1) = "Automatisme"
    BigBox(2) = "Contenu du message"
    BigBox(3) = "Rapport.txt"
    BigBox(4) = "False"
    BigBox(5) = ThisWorkbook.Path & "\" & BigBox(3)

    Call Master(BigBox)
    
End Sub
'

Sub Master(Boite)

  ' Déclaration de variables
  Dim objMail As Object
  Dim sDestination As String, sPieceJointe As String
  Dim msgTitre As String, msgTexte As String
  Dim Drapeau As Boolean

  Set objMail = CreateObject("CDO.Message")
  'set objMail = Server.CreateObject("CDO.Message")

  Drapeau = False
  If (UBound(Boite) > 0) Then
    If (Boite(0) <> "") Then
      sDestination = Boite(0)
    Else
      'Destinataire par défaut
      sDestination = "Mon.Adresse@monserveur.net"
    End If
    If (UBound(Boite) > 1) Then
      If (Boite(1) <> "") Then
        msgTitre = Boite(1)
      Else
        msgTitre = "Automatisme"
      End If
      If (UBound(Boite) > 2) Then
        If (Boite(2) <> "") Then
          msgTexte = Boite(2)
        Else
          msgTexte = "Automatisme"
        End If
        If (UBound(Boite) > 3) Then
          If (Boite(3) <> "") Then
            sPieceJointe = Boite(5)
            If (UBound(Boite) > 4) Then
              Drapeau = Boite(4)
            End If
          Else
            sPieceJointe = ""
          End If
        Else
          sPieceJointe = ""
        End If
      Else
        msgTexte = "Automatisme"
        sPieceJointe = ""
      End If
    Else
      msgTitre = "Automatisme"
      msgTexte = "Automatisme"
      sPieceJointe = ""
    End If
  Else
    MsgBox "Arguments incomplet !"
    Exit Sub
  End If

  With objMail
    ' Ligne à modifier selon l'adresse de l'envoyeur
    .From = cteAdresseSource
    .To = sDestination
    .Subject = msgTitre
    ' Ligne à modifier selon le texte voulu !
    If (sPieceJointe <> "") Then
      If (Drapeau = True) Then
        .TextBody = msgTexte & vbCrLf & LirePieceJointe(sPieceJointe) & vbCrLf
      Else
        .TextBody = msgTexte & vbCrLf & "Pièce jointe incluse : " & vbCrLf
      End If
    Else
      .TextBody = msgTexte & vbCrLf & "Aucune Pièce jointe" & vbCrLf
    End If
    ' Ligne à modifier selon l'adresse du serveur SMTP
    .Configuration.Fields("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "172.27.51.8"
    .Configuration.Fields("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
    .Configuration.Fields.Update
    If ((sPieceJointe <> "") And (Drapeau = False)) Then
      .AddAttachment (sPieceJointe)
    End If
    .Send
  End With
  Set objMail = Nothing

End Sub
'

Function LirePieceJointe(LeFichier)
' Fonction permettant d'inclure le
' contenu texte d'une pièce jointe

  Dim objFSO As Object, CeFichier As Object
  
  Set objFSO = CreateObject("Scripting.FileSystemObject")
  If (objFSO.FileExists(LeFichier)) Then
    Set CeFichier = objFSO.OpenTextFile(LeFichier, cteLecture)
    LirePieceJointe = CeFichier.ReadAll
    CeFichier.Close
    Set CeFichier = Nothing
  End If

  Set objFSO = Nothing

End Function
'

Function Parcourir() As String
    
    Dim Chemin As String, NomLong As String, LeFichier As String
    Dim Position As Integer
    Dim Drapeau As Boolean
    Dim Dlg As FileDialog

    Parcourir = ""
    Chemin = ThisWorkbook.Path
    Set Dlg = Application.FileDialog(msoFileDialogOpen)
    With Dlg
        .InitialFileName = ThisWorkbook.Path
    End With
    
    If (Dlg.Show <> False) Then
        Parcourir = Dlg.SelectedItems(1)
    End If

End Function
'

Sub Send_Mail_Outlook()

'Il faut activer la référence "Microsoft Outlook Library" Avant de lancer cette macro,
' Dans l'éditeur VBA: Faire Menu / Tools / Reference / Cocher "Microsoft Outlook Library"
   Dim ObjOutlook As New Outlook.Application
   Dim ObjOutlookmail As MailItem
   Dim NomFichier As String
   
   Set ObjOutlook = New Outlook.Application
   Set oBjMail = ObjOutlook.CreateItem(olMailItem)
   
   Nom_Fichier = Application.GetOpenFilename("Fichier excel (*.xls;*.xlsx;*.xlsm), *.xls;*.xlsx;*.xlsm")
    If Nom_Fichier = "Faux" Then Exit Sub
    If VarType(Nom_Fichier) = vbBoolean Then Exit Sub


   
   
   With oBjMail

        .To = Range("a3").Value
        .To = "prénom.nom@laboitemail.fr"     ' le destinataire
        .Subject = "Ici c'est l'objet"          ' l'objet du mail
        .Body = "Ici le texte Blblblbla "  'le corps du mail ..son contenu
        .Attachments.Add "C:\Data\essai.txt" ' ou Nomfichier
        .Display  '   Ici on peut mettre '.Send' pour l'envoyer sans vérification
   End With
    
    ObjOutlook.Quit
   
End Sub

Dim ObjOutlook  As New Application       
Set ObjOutlook  = CreateObject("Outlook.application") 

Dim ObjOutlook As New Outlook.Application 

Set ObjOutlook = New Outlook.Application

    Nb = Nb + 1 
   Call Reporter 
   Debug.Print G 
End Sub

Sub Reporter() 
   If NB > 0 Then R = "J'ai Trouvé !!" : Exit Sub 
    R = "Je passe à côté !!!!" 
End Sub