Problème code VBA

Le 24/09/2020 à 19:06

Bonjour,

J'ai un dossier Excel comportant 2 feuille de travail. Sur chaque feuille de travail j'ai installer un bouton avec macros pour envoyer envoyer par email l'image de la feuille. Le problème est que sur une feuille cest l'image de l'autre qui est envoyé et pourtant j'ai pris la peine de modifier le code ainsi que le titre pour l'assignation du bouton pour la bonne feuille.

Voici mon code pour la 1ere feuille

En rouge cest ce que j'ai changer sur l'autre code pour l'autre feuille. Qu'est-ce que je dois changer ou ajouter?

Sub Mail_small_Text_And_JPG_Range_Outlook_PDCA()
MakeJPG = CopyRangeToJPG("PDCA", "A1:K23")

Sub Mail_small_Text_And_JPG_Range_Outlook_PDCA()
'Ron de Bruin, 25-10-2019
'This macro use the function named : CopyRangeToJPG
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Dim MakeJPG As String

With Application
.EnableEvents = False
.ScreenUpdating = False
End With

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

strbody = "Voici ce que je planifie aujourd'hui." & "<br><br>" & _
"Bonne journée!<br>"

'Create JPG file of the range
'Only enter the Sheet name and the range address
MakeJPG = CopyRangeToJPG("PDCA", "A1:K23")

If MakeJPG = "" Then
MsgBox "Something go wrong, we can't create the mail"
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Exit Sub
End If

On Error Resume Next
With OutMail
.To = "xxx.xxxx@xxxx.com"
.CC = "xxx.xxxxxx@xxxx.com;xxxx.xxxx@xxxx.com;"
.BCC = ""
.Subject = "PDCA du jour"
.Attachments.Add MakeJPG, 1, 0
'Note: Change the width and height as needed
.HTMLBody = "<html><p>" & strbody & "</p><img src=""cid:NamePicture.jpg"" width=750 height=800></html>"
.Display 'or use .Send
End With
On Error GoTo 0

With Application
.EnableEvents = True
.ScreenUpdating = True
End With

Set OutMail = Nothing
Set OutApp = Nothing
End Sub

Function CopyRangeToJPG(NameWorksheet As String, RangeAddress As String) As String
'Ron de Bruin, 25-10-2019
Dim PictureRange As Range

With ActiveWorkbook
On Error Resume Next
.Worksheets(NameWorksheet).Activate
Set PictureRange = .Worksheets(NameWorksheet).Range(RangeAddress)

If PictureRange Is Nothing Then
MsgBox "Sorry this is not a correct range"
On Error GoTo 0
Exit Function
End If

PictureRange.CopyPicture
With .Worksheets(NameWorksheet).ChartObjects.Add(PictureRange.Left, PictureRange.Top, PictureRange.Width, PictureRange.Height)
.Activate
.Chart.Paste
.Chart.Export Environ$("temp") & Application.PathSeparator & "NamePicture.jpg", "JPG"
End With
.Worksheets(NameWorksheet).ChartObjects(.Worksheets(NameWorksheet).ChartObjects.Count).Delete
End With

CopyRangeToJPG = Environ$("temp") & Application.PathSeparator & "NamePicture.jpg"
Set PictureRange = Nothing
End Function

Le 24/09/2020 à 23:47

Bonjour Lagrande,

Voici un fichier corrigé pour avoir une seule procédure

26lagrande-exemple.xlsm (24.06 Ko)

Le 25/09/2020 à 13:37

Je suis vraiment débutante en VBA. J'ai regarder ton fichier Excel sans le sauvegarder, je l'ai fermer, j'ai ouvert mon fichier pour tester la formule et c'est l'image de ton fichier qui apparait dans mon mail. Il dois avoir un truc que je sais pas que je dois faire.

Ma procédure VBA:

Insérer un module

Assigné le module au bouton.

Le 26/09/2020 à 03:08

Bonjour Lagrande

J'ai ajouté une ligne pour supprimer le fichier image qui pourrait trainer, j'ai désactiver le saut d'erreur

Avec le code commenté, j'espère que cela pourra t'aider

Sub RangeToMail()
  Dim OutApp As Object, OutMail As Object
  Dim strbody As String, Signature As String, MakeJPG As String
  Dim Sujet As String
  ' Désactiver uniquement les évènements
  Application.EnableEvents = False
  ' Créer l'instance Outlook et un nouveau mail
  Set OutApp = CreateObject("Outlook.Application")
  Set OutMail = OutApp.CreateItem(0)

  strbody = "Voici ce que je planifie aujourd'hui." & "<br><br>" & _
    "Bonne journée!<br>"
  ' ### Ajout du 26/09
  ' Supprimer le fichier image qui pourrait trainer
  On Error Resume Next
  Kill Environ$("temp") & Application.PathSeparator & "NamePicture.jpg"
  On Error GoTo 0
  ' Faire une image de la plage souhaitée
  MakeJPG = CopyRangeToJPG(ActiveSheet.Name, "A1:K23")
  ' S'il n'y a rien en retour
  If MakeJPG = "" Then
    MsgBox "Something go wrong, we can't create the mail"
    With Application
      .EnableEvents = True
      .ScreenUpdating = True
    End With
    Exit Sub
  End If
  ' Sujet du mail
  Sujet = ActiveSheet.Name & " du jour"
  On Error Resume Next
  With OutMail
    .Display
    Signature = .HtmlBody
    '
    .To = "xxx.xxxx@xxxx.com"
    .CC = "xxx.xxxxxx@xxxx.com;xxxx.xxxx@xxxx.com;"
    .BCC = ""
    .Subject = Sujet
    .Attachments.Add MakeJPG, 1, 0
    'Note: Change the width and height as needed
    .HtmlBody = "<html><p>" & strbody & "</p><img src=""cid:NamePicture.jpg"" width=750 height=800></html>" & Signature
    '.Send
  End With
  On Error GoTo 0
  ' Réactiver les évènements
  Application.EnableEvents = True

  Set OutMail = Nothing
  Set OutApp = Nothing
End Sub

Function CopyRangeToJPG(NameWorksheet As String, RangeAddress As String) As String
  Dim PictureRange As Range
  ' Avec le classeur actif
  With ActiveWorkbook
    ' Activer la feuille nommée
    .Worksheets(NameWorksheet).Activate
    ' En cas d'erreur on continue le code
    On Error Resume Next
    ' Définir la plage à capturer
    Set PictureRange = .Worksheets(NameWorksheet).Range(RangeAddress)
    ' si la plage ne contient rien
    If PictureRange Is Nothing Then
      MsgBox "Sorry this is not a correct range"
      On Error GoTo 0
      Exit Function
    End If
    ' Gestion normale des erreurs
    On Error GoTo 0
    ' Sinon, copier la plage
    PictureRange.CopyPicture
    ' Ajouter un objet : graphique
    With .Worksheets(NameWorksheet)
      .ChartObjects.Add(PictureRange.Left, PictureRange.Top, PictureRange.Width, PictureRange.Height).Select
      ' Coller l'image dans le graphique
      .Chart.Paste
      ' Exporter le graphique en image
      .Chart.Export Environ$("temp") & Application.PathSeparator & "NamePicture.jpg", "JPG"
    End With
    ' Supprimer l'objet : graphique
    .Worksheets(NameWorksheet).ChartObjects(.Worksheets(NameWorksheet).ChartObjects.Count).Delete
  End With
  ' Mémoriser le chemin d'accès à l'image
  CopyRangeToJPG = Environ$("temp") & Application.PathSeparator & "NamePicture.jpg"
  ' Effacer la variable objet
  Set PictureRange = Nothing
End Function

Le 28/09/2020 à 14:30

J'ai un message d'erreur quand j'essaie le code Runtime error 1004

' Ajouter un objet : graphique

With .Worksheets(NameWorksheet).ChartObjects.Add(PictureRange.Left, PictureRange.Top, PictureRange.width, PictureRange.height) .Activate

Le 28/09/2020 à 19:16

Re,

As-tu essayé directement le fichier, plutôt que le code ?

Le 28/09/2020 à 19:46

les deux

Le 29/09/2020 à 10:27

Re,

Arf, je viens de voir que tu es en 2010... certainement là le souci

Je ne pourrais rien faire, désolé.

Le 29/09/2020 à 13:06

Alors mon problème pourrais être régler si je trouve une formule qui effacera l'image?

Le 29/09/2020 à 14:16

J'ai trouver un nouveau code qui semble bien fonctionner et efface l'image temporaire

Sub SendHTML_And_RangeImage_As_Body_UsingOutlook_PDCA()
Dim olApp As Object
Dim NewMail As Object
Dim ChartName As String
Dim imgPath As String
Dim tmpImageName As String
Dim RangeToSend As Range
Dim sht As Worksheet
Dim objChart As Chart
'On Error GoTo err
Set olApp = CreateObject("Outlook.Application")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'define a temp path for your image
tmpImageName = VBA.Environ$("temp") & "\tempo.jpg"
'Range to save as an image
Set RangeToSend = Worksheets("PDCA").Range("A1:K23")
' Now copy that range as a picture
RangeToSend.CopyPicture Appearance:=xlScreen, Format:=xlPicture
' To save this as an Image we need to do a workaround
' First add a temporary sheet and add a Chart there
' Resize the chart same as the size of the range
' Make the Chart border as Zero
' Later once we export that chart as an image
' and save it in the above temporary path
' will delete this temp sheet
Set sht = Sheets.Add
sht.Shapes.AddChart
sht.Shapes.Item(1).Select
Set objChart = ActiveChart
With objChart
.ChartArea.height = RangeToSend.height
.ChartArea.width = RangeToSend.width
.ChartArea.Fill.Visible = msoFalse
.ChartArea.Border.LineStyle = xlLineStyleNone
.Paste
.Export Filename:=tmpImageName, FilterName:="JPG"
End With
'Now delete that temporary sheet
sht.Delete
' Create a new mail message item.
Set NewMail = olApp.CreateItem(0)
With NewMail
.subject = "Planification du jour" ' Replace this with your Subject
.To = "caroline@xxxx.com"
.CC = "michel@xxxx.com;andre@xxxx.com" ' Replace it with your actual email
' **************************************************
' You can desing your HTML body for this email.
' below HTML code will display the image in
' Body of the email. It will not go in attachment.
' **************************************************
.HTMLBody = "<body>Voici ce que je planifie pour les inspections aujourd'hui! <br><br>" & _
"<img src=" & "'" & tmpImageName & "'/> <br><br> Bonne journée :) Marc </body>"
.Display
End With
err:
'Release memory.
' Kill tmpImageName
Set olApp = Nothing
Set NewMail = Nothing
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

Rechercher des sujets similaires à "probleme code vba"