Range de cellule dans corps de mail ne fonctionne pas

Le 08/05/2023 à 11:26

Bonjour au forum,

J'ai une procédure qui me permet d'envoyer 3 images dans un corps de mail, à partir de 3 plages de cellules.

Je rencontre aléatoirement un problème sur l'image n°1 (et uniquement celle-ci) qui parfois est vide.

Je ne trouve pas de raisons particulières, ce n'est pas dépendant du poste, ni de l'utilisateur, etc.

J'avais déjà posté pour ce problème il y a quelque temps et on m'avait recommandé de mettre un timer d'attente entre chaque génération d'image.

Malheureusement, le problème persiste malgré tout (je suis actuellement à une attente de 600ms entre chaque génération).

Auriez-vous une idée du problème ?

Option Explicit
Option Private Module

Sub Attendre()
    Dim t1, t2
    t1 = Timer
    t2 = Timer + 0.6   'attendre 600 ms
    Do
        DoEvents
    Loop While t1 <= Timer And Timer < t2
End Sub

Sub Chrt_Delete()
    Err.Clear
    On Error Resume Next
    Do While Err.Number = 0     'normalement il n'y a qu'une image
        Sheets("Graphique").Shapes(1).Delete
    Loop
    Attendre
    On Error GoTo 0
End Sub

Sub EnvoiMail()

    Dim oRange1, oRange2, oRange3 As Range
    Dim oCht1 As Chart
    Dim oImg As Picture
    Dim objOL As Object, ObjMail As Object
    Dim oAttach1, oAttach2, oAttach3 As Object, ColAttach As Object
    Dim DestinatairesPrincipaux, DestinatairesCopie As String
    Dim i As Long
    '---------------------------------------------------------------------------------------------
    Application.CutCopyMode = False
    Application.ScreenUpdating = False
    '---------------------------------------------------------------------------------------------
    Set oCht1 = Sheets("Graphique")
    oCht1.Visible = xlSheetVisible
    Chrt_Delete
    Set oRange1 = Sheets("Tableau de bord").Range("B10:G39")
    oRange1.CopyPicture xlScreen, xlPicture
    Attendre
    oCht1.Paste
    oCht1.Export Filename:="C:\Documents\Stock.jpg", Filtername:="JPG"
    '---------------------------------------------------------------------------------------------
    Chrt_Delete
    Set oRange2 = Sheets("Tableau de bord").Range("L10:O39")
    oRange2.CopyPicture xlScreen, xlPicture
    Attendre
    oCht1.Paste
    oCht1.Export Filename:="C:\Documents\Alerte.jpg", Filtername:="JPG"
    '---------------------------------------------------------------------------------------------
    Chrt_Delete
    Set oRange3 = Sheets("Tableau de bord").Range("T10:AB39")
    oRange3.CopyPicture xlScreen, xlPicture
    Attendre
    oCht1.Paste
    oCht1.Export Filename:="C:\Documents\Tendance.jpg", Filtername:="JPG"
    '---------------------------------------------------------------------------------------------
        Set objOL = CreateObject("Outlook.Application")
        Set ObjMail = objOL.createitem(0)
        Set ColAttach = ObjMail.Attachments
        Set oAttach1 = ColAttach.Add("C:\Documents\Stock.jpg") 'Changer le chemin et le nom de l'image
        Set oAttach2 = ColAttach.Add("C:\Documents\Alerte.jpg") 'Changer le chemin et le nom de l'image
        Set oAttach3 = ColAttach.Add("C:\Documents\Tendance.jpg") 'Changer le chemin et le nom de l'image
    '---------------------------------------------------------------------------------------------
        With ObjMail
            .To = "Monemail@domaine.fr" ' changer email
            '.CC = DestinatairesCopie
            '.BCC = ""
            .Subject = "blabla"
            .HTMLBody = "<BODY><FONT face=Arial color=#000080 size=2></FONT>" & _
                "Bonjour, <br><br> Veuillez trouver ci-joint un récapitulatif de l'état du stock au " _
                & Date & " à " & Time & " (Normes ISO incluses) : <br><br> <IMG src=cid:Stock.jpg> <br><br> <IMG src=cid:Alerte.jpg> <br><br> <IMG src=cid:Tendance.jpg> <br><br> Bonne journée !</BODY>"   'Nom de l'image sans chemin
            Attendre
            ObjMail.Save
            .Send
        End With
    '---------------------------------------------------------------------------------------------
        Set oAttach1 = Nothing
        Set oAttach2 = Nothing
        Set oAttach3 = Nothing
        Set ColAttach = Nothing
        Set ObjMail = Nothing
        Set objOL = Nothing
    '---------------------------------------------------------------------------------------------
    oCht1.Visible = xlSheetVeryHidden
    '---------------------------------------------------------------------------------------------
    Application.ScreenUpdating = True
End Sub
8mail-fof.xlsm (50.16 Ko)
Le 08/05/2023 à 15:22

Bonjour,

Peut être tout simplement, ne pas désactiver la mise à jour de l'écran (mise en commentaire)

'Application.ScreenUpdating = False
Le 08/05/2023 à 16:07
Bonjour Thev, Merci pour la suggestion, je vais essayer. Y'a t'il une raison pour que cela empêche parfois la génération d'uniquement la 1ere image ou c'est une réponse sans conviction ?
Le 09/05/2023 à 07:44

Bonjour Thev,

J'ai testé votre proposition mais malheureusement le problème persiste...

Auriez-vous d'autres idées ?

Le 09/05/2023 à 08:56

bonjour,

0.6 sec est déjà beaucoup !?!

Je commencerais par ajouter un nouveau "Attendre" après "oCht1.paste", uniquement pour votre 1ere image et si cela ne fonctionne pas encore, un autre après le "Set oRange1=...." . A ce point, si tout fonctionne, peut-être ce vous pouvez réduire ce temps d'attendre de 0.6 à ... 0.4 (?).

Vous utilisez ceci avec Exce2013 ou 365 ?

image
Le 09/05/2023 à 08:58

Bonjour,

Croquignol des Pieds Nickelés vous suggère d'en faire une quatrième qui prendra la place de la première.

Nb : Je décline toute responsabilité dans cette proposition...

Le 09/05/2023 à 09:11

Bonjour BsAlv,

Merci pour la proposition, je vais tester cela dans la journée.

J'utilise Excel 365. Et effectivement, 600ms est beaucoup, mais j'y suis allé par palier, et le problème persistait à chaque fois. Cela dit, parfois cela fonctionne sans même aucun appel à "Attendre".

@Eric, c'est une idée qui mérite réflexion en effet ! Merci !

Le 09/05/2023 à 12:37

Re,

Malheureusement cela ne fonctionne toujours pas, malgré les ajouts des deux procédures "Attendre".

Je commence à désespérer

Le 10/05/2023 à 01:56

re,

système "Eric Kergresse" (= 1ier fois = blague, 2ième fois sérieux)

     '---------------------------------------------------------------------------------------------
     Set oCht1 = Sheets("Graphique")
     oCht1.Visible = xlSheetVisible
     For i = 1 To 2
          Chrt_Delete
          Set oRange1 = Sheets("Tableau de bord").Range("B10:G39")
          oRange1.CopyPicture xlScreen, xlPicture
          Attendre
          oCht1.Paste
          oCht1.Export Filename:="C:\Documents\Stock.jpg", Filtername:="JPG"
     Next
     '---------------------------------------------------------------------------------------------
Le 10/05/2023 à 12:32

Re,

Et bien même cette solution ne fonctionne pas...

C'est incompréhensible ce truc

Le 10/05/2023 à 15:17

Y-a-t-il quelque chose spécial dans la première plage ?

Donc si on échange le premier et le 2ième, on commence avec "alerte" au lieu de "stock", alors la problème se déplace aussi ?

Le 11/05/2023 à 07:26

Oui le problème se déplace, du coup ma plage de cellule "Stock" est bien là mais c'est "Alerte" qui ne s'affiche pas.

Le 11/05/2023 à 11:03

Je suis en train de tester une variante du système Eric Kergresse :

    Set oCht1 = Sheets("Graphique")
    oCht1.Visible = xlSheetVisible
    Chrt_Delete
    Set oRange1 = Sheets("Tableau de bord").Range("B10:G39")
    oRange1.CopyPicture xlScreen, xlPicture
    'Attendre
    oCht1.Paste
    oCht1.Export Filename:="P:\MGL-SHARE\Labo LIHT\NREV\Tests\Stock.jpg", Filtername:="JPG"
    '-----------------------------------------------------------------------------------------------------------------------
    Chrt_Delete
    Set oRange2 = Sheets("Tableau de bord").Range("L10:O39")
    oRange2.CopyPicture xlScreen, xlPicture
    'Attendre
    oCht1.Paste
    oCht1.Export Filename:="P:\MGL-SHARE\Labo LIHT\NREV\Tests\Alerte.jpg", Filtername:="JPG"
    '-----------------------------------------------------------------------------------------------------------------------
    Chrt_Delete
    Set oRange3 = Sheets("Tableau de bord").Range("T10:AB39")
    oRange3.CopyPicture xlScreen, xlPicture
    'Attendre
    oCht1.Paste
    oCht1.Export Filename:="P:\MGL-SHARE\Labo LIHT\NREV\Tests\Tendance.jpg", Filtername:="JPG"
    '-----------------------------------------------------------------------------------------------------------------------
    Chrt_Delete
    Set oRange1 = Sheets("Tableau de bord").Range("B10:G39")
    oRange1.CopyPicture xlScreen, xlPicture
    Attendre
    oCht1.Paste
    oCht1.Export Filename:="P:\MGL-SHARE\Labo LIHT\NREV\Tests\Stock.jpg", Filtername:="JPG"

Pour l'instant, ça à l'air de fonctionner (même sans les "Attendre").

Mais vu que le problème est aléatoire, je vais attendre un peu

Rechercher des sujets similaires à "range corps mail fonctionne pas"