Envoi d'un mail via Outlook à partir d'Excel

Le 10/06/2019 à 14:54

Bonjour à tous,

J'ai une macro qui me créée des tableaux et qui les importe dans des feuilles de calcul.

Ainsi, je souhaite via cette macro, envoyer le contenu importé dans chaque feuille, vers un interlocuteur spécifique.

Dans l'exemple ci-dessous, je souhaite envoyer le contenu de la feuille WsS2 à "blabla1@BLABLA.com" et le contenu de WsS5 à "blabla2@BLABLA.com".

Ca fonctionne assez bien pour le 1er, il reçoit son mail, en revanche, ca s'arrête là et le 2nd ne reçois jamais rien.

'*****
'-----
'blabla1
'-----
'*****

    Dim olk As Object, email As Object, wdDoc As Object
    Dim erreur As Integer, nb_lignes As Integer, v As Integer
    Dim rng As Object

    On Error Resume Next    'désactivation routine d'erreur
    erreur = False

    'Assignation des applications Outlook ,de l'objet email et du body de l'email en tant que document Word
    Set olk = CreateObject("outlook.application")
    Set email = olk.CreateItem(olMailItem)
    Set wdDoc = email.GetInspector.WordEditor

    With email

        'Remplissage sujet, objet, et adresse
         .To = "blabla1@BLABLA.com"
        .Subject = "Daily_NCR_report"

        'Corps du mail
         .Display

        With WsS2

            bLR = .Range("A" & Rows.Count).End(xlUp).Row
            .Range("$A$1:$F$" & bLR).Copy

            'premier tableau

            'nb_lignes = .Range("A1:F10").Rows.Count
            nb_lignes = .Range("A" & Rows.Count).End(xlUp).Row

            Set rng = wdDoc.Content
            rng.PasteSpecial , DataType:=wdPasteMetafilePicture

            'Pour insérer du texte après le tableau
                For v = 1 To nb_lignes

                    rng.InsertParagraphAfter

                Next v

            'Insertion texte premier tableau
            rng.InsertAfter vbNewLine & "Commentaires !" & vbCrLf
            rng.InsertAfter vbNewLine
            rng.Move wdParagraph

            .Columns("A:F").Clear

        End With

        '....... envoie le message
'******
        .Send
        If Err.Number <> 0 Then erreur = True

    End With

    'Désassignation objets
     Set olk = Nothing
     Set email = Nothing
     Set wdDoc = Nothing

'*****
'-----
'blabla2
'-----
'*****

    Dim olkA As Object, emailA As Object, wdDocA As Object
    Dim erreurA As Integer, nb_lignesA As Integer, vA As Integer
    Dim rngA As Object

    On Error Resume Next    'désactivation routine d'erreur
    erreurA = False

    'Assignation des applications Outlook ,de l'objet email et du body de l'email en tant que document Word
    Set olk = CreateObject("outlook.application")
    Set emailA = olkA.CreateItem(olMailItem)
    Set wdDocA = emailA.GetInspector.WordEditor

    With emailA

        'Remplissage sujet, objet, et adresse
         .To = "blabla2@BLABLA.com"
        .Subject = "Daily_NCR_report"

        'Corps du mail
         .Display

        With WsS5

            bLR = .Range("A" & Rows.Count).End(xlUp).Row
            .Range("$A$1:$F$" & bLR).Copy

            'premier tableau

            'nb_lignes = .Range("A1:F10").Rows.Count
            nb_lignesA = .Range("A" & Rows.Count).End(xlUp).Row

            Set rngA = wdDoc.Content
            rngA.PasteSpecial , DataType:=wdPasteMetafilePicture

            'Pour insérer du texte après le tableau
                For vA = 1 To nb_lignes

                    rngA.InsertParagraphAfter

                Next vA

            'Insertion texte premier tableau
            rngA.InsertAfter vbNewLine & "Commentaires !" & vbCrLf
            rngA.InsertAfter vbNewLine
            rngA.Move wdParagraph

            '.Columns("A:F").Clear

        End With

        '....... envoie le message
'****** '.Send
        If Err.Number <> 0 Then erreurA = True

    End With

    'Désassignation objets
     Set olkA = Nothing
     Set emailA = Nothing
     Set wdDocA = Nothing

Je n'ai malheureusement pas de fichier à mettre en pièce jointe et je m'en excuse. Si c'est trop compliqué, j'essayerai de créer un fichier en retirant les infos que je ne souhaite pas communiquer.

Merci d'avance,

Bon après-midi,

Floo

Le 10/06/2019 à 15:36

Bonjour,

Un passage dans le code en mode pas-à-pas ( touche F8 ) t'aurais permis de trouver les coquilles.

Un essai ...

Sub EnvoiMail()

Dim olk As Object, email As Object, wdDoc As Object
Dim erreur As Integer, nb_lignes As Integer, v As Integer
Dim rng As Object, bLR As Integer

On Error Resume Next      'désactivation routine d'erreur
   erreur = False

   'Assignation des applications Outlook ,de l'objet email et du body de l'email en tant que document Word
   Set olk = CreateObject("outlook.application")
   Set email = olk.CreateItem(olMailItem)
   Set wdDoc = email.GetInspector.WordEditor

   With email

      'Remplissage sujet, objet, et adresse
      .To = "blabla1@BLABLA.com"
      .Subject = "Daily_NCR_report"

      'Corps du mail
      .Display

      With Worksheets("WsS2")
         bLR = .Range("A" & Rows.Count).End(xlUp).Row
         .Range("$A$1:$F$" & bLR).Copy

         'premier tableau
         'nb_lignes = .Range("A1:F10").Rows.Count
         nb_lignes = .Range("A" & Rows.Count).End(xlUp).Row

         Set rng = wdDoc.Content
         rng.PasteSpecial , DataType:=wdPasteMetafilePicture

         'Pour insérer du texte après le tableau
         For v = 1 To nb_lignes + 2
            rng.InsertParagraphAfter
         Next v

         'Insertion texte premier tableau
         rng.InsertAfter vbNewLine & "Commentaires !" & vbCrLf
         rng.InsertAfter vbNewLine
'         rng.Move wdParagraph

'         .Columns("A:F").Clear  << désactivé pour les tests
      End With

      '....... envoie le message
      '******
      .Send
      If Err.Number <> 0 Then erreur = True
   End With

   'Désassignation objets
   Set olk = Nothing
   Set email = Nothing
   Set wdDoc = Nothing

   '*****
   '-----
   'blabla2
   '-----
   '*****

   Dim olkA As Object, emailA As Object, wdDocA As Object
   Dim erreurA As Integer, nb_lignesA As Integer, vA As Integer
   Dim rngA As Object

   On Error Resume Next      'désactivation routine d'erreur
   erreurA = False

   'Assignation des applications Outlook ,de l'objet email et du body de l'email en tant que document Word
   Set olkA = CreateObject("outlook.application")
   Set emailA = olkA.CreateItem(olMailItem)
   Set wdDocA = emailA.GetInspector.WordEditor

   With emailA

      'Remplissage sujet, objet, et adresse
      .To = "blabla2@BLABLA.com"
      .Subject = "Daily_NCR_report"

      'Corps du mail
      .Display

      With Worksheets("WsS5")
         bLR = .Range("A" & Rows.Count).End(xlUp).Row
         .Range("$A$1:$F$" & bLR).Copy

         'premier tableau
         'nb_lignes = .Range("A1:F10").Rows.Count
         nb_lignesA = .Range("A" & Rows.Count).End(xlUp).Row

         Set rngA = wdDocA.Content
         rngA.PasteSpecial , DataType:=wdPasteMetafilePicture

         'Pour insérer du texte après le tableau
         For vA = 1 To nb_lignes + 2
            rngA.InsertParagraphAfter
         Next vA

         'Insertion texte premier tableau
         rngA.InsertAfter vbNewLine & "Commentaires !" & vbCrLf
         rngA.InsertAfter vbNewLine
         '            rngA.Move wdParagraph

         '.Columns("A:F").Clear  << désactivé pour les tests
      End With

      '....... envoie le message
      .Send
      If Err.Number <> 0 Then erreurA = True

   End With

   'Désassignation objets
   Set olkA = Nothing
   Set emailA = Nothing
   Set wdDocA = Nothing
End Sub

ric

Le 11/06/2019 à 09:01

Bonjour,

Merci ! Ca fonctionne !

Bonne journée,

Floo

Rechercher des sujets similaires à "envoi mail via outlook partir"