Mettre 2 captures d'écran dans un même mail outlook

Bonjour,

J'ai repris une macro qui fonctionne très bien qui consiste à créer un mail outlook et y insérer une capture d'écran d'un onglet. Tout fonctionne très bien pour une capture mais lorsque je veux en faire une deuxième il me garde uniquement la deuxième et ne m'affiche pas l'autre. De plus, il m'affiche dans le corps du mail le tableau en premier alors que je voudrais qu'il soit après ma phrase "Voici mes deux premiers tableaux" et l'autre capture après ma phrase " Et mes deux suivants".

Je vous mets en PJ mon fichier et mon voici le code qui serait à modifier :

Sub test()

Dim smail As Worksheet
Set smail = ActiveWorkbook.Sheets("Tableaux")

Dim smail2 As Worksheet
Set smail2 = ActiveWorkbook.Sheets("Tableaux")

Dim r As Range
Set r = smail.Range("B4:R26")
r.CopyPicture xlScreen, xlBitmap

Dim s As Range
Set s = smail2.Range("v4:AJ26")
s.CopyPicture xlScreen, xlBitmap

Dim Corps As Variant

 On Error Resume Next
        Set OutApp = GetObject(, "Outlook.Application")
        If Err <> 0 Then Set OutApp = CreateObject("Outlook.Application")
        On Error GoTo 0

         Set OutMail = OutApp.CreateItem(0)
        With OutMail
            .BodyFormat = 3
            .To = "blabla@test.fr"
            .CC = "dupont@test.fr"
            .BCC = ""
            .Subject = "Test 1"
            .HTMLBody = "<br /><br /> Bonjour, <br /><br />" _
            & "Voici mes deux premiers tableaux : <br /><br />" _
            & "Et mes deux suivants : "
            Set olInsp = .GetInspector
            Set wdDoc = olInsp.WordEditor
            Set oRng = wdDoc.Range
            oRng.collapse 1
            oRng.Paste
            .Display
           ' .send
        End With

End Sub

Et l'aperçu du mail actuel :

Et voici à quoi j'aimerais qu'il ressemble : (je l'ai fait à la main)

Merci d'avance pour votre aide !!

Bonjour Laguilo

Voici le code à utiliser pour ce que vous souhaitez faire

Option Explicit

Const wdParagraph As Long = 4

Sub Test()
  Dim Sht As Worksheet
  Dim OutApp As Object
  Dim MyItem As Object, wDoc As Object, Rng As Object

  Set Sht = ActiveWorkbook.Sheets("Tableaux")
  On Error Resume Next
  Set OutApp = GetObject(, "Outlook.Application")
  If Err <> 0 Then Set OutApp = CreateObject("Outlook.Application")
  On Error GoTo 0
  Set MyItem = OutApp.CreateItem(0)
  Set wDoc = MyItem.GetInspector.WordEditor
  With MyItem
    .BodyFormat = 3
    .Display
    .To = "blabla@test.fr"
    .CC = "dupont@test.fr"
    .BCC = ""
    .Subject = "Test 1"
    .HTMLbody = "Bonjour, <br><br>" _
    & "Voici mes deux premiers tableaux : <br>"
    ' 1er tableau
    Sht.Range("B4:R26").CopyPicture xlScreen, xlBitmap
    Set Rng = wDoc.Content
    Rng.InsertParagraphAfter
    Rng.Move wdParagraph, 1
    Rng.Paste
    Rng.Move wdParagraph
    .HTMLbody = .HTMLbody & "<br>Et mes deux suivants : "
    ' 2ème tableau
    Sht.Range("V4:AJ26").CopyPicture xlScreen, xlBitmap
    Set Rng = wDoc.Content
    Rng.InsertParagraphAfter
    Rng.Move wdParagraph, 1
    Rng.Paste
    Rng.Move wdParagraph
    ' .send
  End With
  ' Penser à effacer les variables objet pour libérer de la mémoire
  Set Rng = Nothing: Set wDoc = Nothing: Set MyItem = Nothing: Set OutApp = Nothing
End Sub

@+

Bonjour,

Merci beaucoup c'est exactement ce que je voulais !

Je voulais savoir si c'était aussi possible de mettre deux tableaux côte à côte?

Exemple : Maintenant au lieu de deux tableaux avec les plages (B4:R26) et (V4:AJ26), je veux quatre tableaux :

- (B4:I26), (V4:AB26) qui sont côte à côte dans le mail

- (K4:R26), (AD4:AJ26) qui sont aussi à côte l'un de l'autre dans le mail.

J'ai essayé de mettre plusieurs plages dans mon Range, comme ceci mais cela ne fonctionne pas :

    ' 1er et 2ème tableaux
    Sht.Range("B4:I26,V4:AB26").CopyPicture xlScreen, xlBitmap
    Set Rng = wDoc.Content
    Rng.InsertParagraphAfter
    Rng.Move wdParagraph, 1
    Rng.Paste

J'ai aussi crée 4 tableaux mais du coup il me les met l'un en dessous de l'autre et j'aimerais qu'ils soient l'un à côté de l'autre, voici le code :

Option Explicit

Const wdParagraph As Long = 4

Sub Test()
  Dim Sht As Worksheet
  Dim OutApp As Object
  Dim MyItem As Object, wDoc As Object, Rng As Object

  Set Sht = ActiveWorkbook.Sheets("Tableaux")
  On Error Resume Next
  Set OutApp = GetObject(, "Outlook.Application")
  If Err <> 0 Then Set OutApp = CreateObject("Outlook.Application")
  On Error GoTo 0
  Set MyItem = OutApp.CreateItem(0)
  Set wDoc = MyItem.GetInspector.WordEditor
  With MyItem
    .BodyFormat = 3
    .Display
    .To = "blabla@test.fr"
    .CC = "dupont@test.fr"
    .BCC = ""
    .Subject = "Test 1"
    .HTMLbody = "Bonjour, <br><br>" _
    & "Voici mes deux premiers tableaux : <br>"
    ' 1er tableau
    Sht.Range("B4:I26").CopyPicture xlScreen, xlBitmap
    Set Rng = wDoc.Content
    Rng.InsertParagraphAfter
    Rng.Move wdParagraph, 1
    Rng.Paste
    Rng.Move wdParagraph
    ' 2ème tableau
    Sht.Range("V4:AB26").CopyPicture xlScreen, xlBitmap
    Set Rng = wDoc.Content
    Rng.InsertParagraphAfter
    Rng.Move wdParagraph, 1
    Rng.Paste
    Rng.Move wdParagraph
    .HTMLbody = .HTMLbody & "<br>Et mes deux suivants : "
    ' 3ème tableau
    Sht.Range("K4:AR26").CopyPicture xlScreen, xlBitmap
    Set Rng = wDoc.Content
    Rng.InsertParagraphAfter
    Rng.Move wdParagraph, 1
    Rng.Paste
    Rng.Move wdParagraph
    ' 4ème tableau
    Sht.Range("AD4:AJ26").CopyPicture xlScreen, xlBitmap
    Set Rng = wDoc.Content
    Rng.InsertParagraphAfter
    Rng.Move wdParagraph, 1
    Rng.Paste
    Rng.Move wdParagraph
    ' .send
  End With
  ' Penser à effacer les variables objet pour libérer de la mémoire
  Set Rng = Nothing: Set wDoc = Nothing: Set MyItem = Nothing: Set OutApp = Nothing
End Sub

Merci d'avance pour ta réponse !