XL 2019 Mail d'alerte automatique contenant tableau si condition remplie

Bidexcel

XLDnaute Nouveau
Bonjour à tous,

Je viens vers vous ce matin pour demander votre sur un projet. J'ai un tableau contenu dans une feuille nommée "Résumé", je souhaiterais tout d'abord effectuer un filtre sur la colonne "L" des lignes du tableau contenant le critère "Vrai". Ensuite faire une capture écran du tableau filtré et insérer dans le corps d'un Email pour envoi.
Le mail devra etre envoyer automatiquement à l'ouverture du fichier.

Je suis pas callé en VBA mais j'essaie d'adapter ce code que j'ai retrouver sur internet à mon modele :
VB:
Sub Filtrer_colonne_L_et_envoyer_email()
    
    'Activer la feuille contenant le tableau
    Sheets("Resumé").Activate
    
    'Définir le tableau
    Dim Tableau As ListObject
    Set Tableau = ActiveSheet.ListObjects("Tableau_resume")
    
    'Appliquer le filtre sur la colonne L avec le critère spécifié
    Tableau.Range.AutoFilter Field:=11, Criteria1:="Vrai"
    
    'Copier le tableau filtré en tant qu'image
    Dim img As Picture
    Set img = Tableau.Range.CopyPicture(xlScreen, xlPicture)
    
    'Coller l'image dans le corps d'un nouvel e-mail
    Dim OutApp As Object
    Dim OutMail As Object
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    
    With OutMail
        .To = "aa@gmail.com"
        .Subject = "Tableau filtré"
        .HTMLBody = "<html><body><p>Le tableau filtré est ci-dessous:</p>" & _
                    "<p><img src='cid:tableau'></p></body></html>"
        .Display
    End With
    
    'Ajouter l'image en tant que pièce jointe et définir son nom en tant que "tableau_filtre.png"
    Dim chemin_image As String
    chemin_image = Environ("temp") & "\" & "tableau_filtre.png"
    img.Copy
    With OutMail
        .Attachments.Add chemin_image, olByValue, 0
        .Attachments.Item(1).DisplayName = "tableau_filtre.png"
        .HTMLBody = Replace(.HTMLBody, "cid:tableau", .Attachments.Item(1).PropertyAccessor.BinaryToString(.Attachments.Item(1).PropertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x3712001F")))
        .Display
    End With
    
    'Effacer le filtre
    Tableau.Range.AutoFilter
    
End Sub


Je bloque cependnat sur cette ligne de code avec l'erreur 424
bbbb.png

aaaa.png


Si vous pouviez m'aider à résoudre cela ca serait TOP. Merci d'avance
Le fichier en question
 

Pièces jointes

  • Test 1.xlsm
    33.3 KB · Affichages: 8

Bidexcel

XLDnaute Nouveau
Bonsoir à tout le monde
S'il vous plait personne pour m'aider ?
j'ai toujours la même erreur avec ce code je sais vraiment pas ce qui cloche si vous pouviez m'orienté

VB:
Sub EnvoiMail()

    Dim rng As Range
    Dim tbl As ListObject
    Dim olApp As Object
    Dim olMail As Object
    Dim dest As String
   
    'Définir la plage à filtrer
    Set rng = Sheets("Resumé").Range("A1:K100")
   
    'Vérifier si la colonne K contient Vrai
    If WorksheetFunction.CountIf(rng.Columns("K"), "Vrai") = 0 Then
        'Annuler le filtre, afficher un message et sortir de la procédure
        rng.AutoFilter
        MsgBox "Pas de plus à réaliser pour le moment"
        Exit Sub
    Else
        'Filtrer la colonne K avec comme critère Vrai
        rng.AutoFilter Field:=11, Criteria1:="Vrai"
       
        'Nommer la plage filtrée en TableauFiltre
        Set tbl = rng.ListObject
        tbl.Name = "TableauFiltre"
       
        'Copier TableauFiltre et le coller comme image modifiable dans le corps du mail
        Set olApp = CreateObject("Outlook.Application")
        Set olMail = olApp.CreateItem(0)
        dest = "amouedra@bou.com"
        With olMail
            .To = dest
            .Subject = "Plus-values réalisables"
            .HTMLBody = "Voici les plus-values réalisables : <br><br>" & tbl.Range.CopyPicture(xlScreen, xlPicture).ToHTMLTable & "<br>"
            .Display
        End With
       
        'Envoyer le mail
        olMail.Send
       
        'Annuler le filtre
        rng.AutoFilter
    End If
1679680676559.png


1679680635681.png

Cordialement
 
Dernière édition:

fanch55

XLDnaute Barbatruc
Bonjour,
Un peu tard, mais si toujours d'actualité , code pour classeur fourni .
VB:
Sub Filtrer_colonne_L_et_envoyer_email()
'Activer la feuille contenant le tableau
 Sheets("Resumé").Activate
 
    With CreateObject("Outlook.Application").CreateItem(0)
        .To = "aa@gmail.com"
        .Subject = "Tableau filtré"
        .Display ' pour pouvoir exploiter le wordeditor
         Sig = .body ' Pour récupérer la signature éventuelle
        .body = ""
        With .GetInspector.WordEditor
            .Content.InsertBefore _
                "Bonjour, " & vbLf & _
                "Le tableau filtré est ci-dessous:" & vbLf
            
            .Content.InsertParagraphAfter
             Range("Tableau_resume[#All]").AutoFilter Field:=11, Criteria1:="Vrai"
             Range("Tableau_resume[#All]").CopyPicture
            .Paragraphs(4).Range.Paste
            
            .Content.InsertParagraphAfter
            .Content.InsertAfter vbLf & "Cordialement,"
            .Content.InsertAfter Sig
        End With
'        .send   ' à decommenter pour envoi effectif
    End With
End Sub
 

Statistiques des forums

Discussions
311 720
Messages
2 081 904
Membres
101 834
dernier inscrit
Jeremy06510