Redimensionner une image dans un email outlook
Bonjour, je suis nouveau sur les forums donc merci à tous pour ce que vous avez posté, grâce à vous, j'ai réussi à générer un mail automatique avec une image depuis des cellules excel.
Mon problème, l'image apparait trop petit dans le corps du mail. Et je bloque sur le moyen de redimensionner l'image collée.
Quelqu'un a-t-il une solution ?
Voilà le code :
Sub DiffusionTdB()
Dim olk As Object, email As Object, wdDoc As Object
Dim erreur As Integer
Dim rng As Object
On Error Resume Next 'désactivation routine d'erreur
erreur = False
Sheets("test").Activate
Liste = Range("O14")
Datejour = Range("K2")
'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)
With email
'....... remplissage sujet, objet, et adresse
.To = Liste
.Subject = "Tableau de bord au " & Datejour
.Display
Set wdDoc = email.GetInspector.WordEditor
Set rng = wdDoc.Range(0, 0) ' Insertion avant la copie du tableau
rng.InsertAfter "Bonjour," & vbNewLine
Set rng = rng.Paragraphs.Add().Range
With Sheets("test")
'insertion tableau de bord
Range("B2:M79").Select
Selection.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
rng.InsertParagraphBefore
rng.Paste
' Insertion texte après tableau de bord
rng.InsertParagraphBefore
rng.InsertAfter vbNewLine & "Cordialement," & vbCrLf
End With
End With
'Désassignation objets
Set olk = Nothing
Set email = Nothing
Set wdDoc = Nothing
End SubMerci d'avance !
PierreGC
Bonjour PierreGC,
tu peux ajouter après la ligne
rng.Pastece code (réduire ou augmenter la valeur 500 jusqu’au résultat souhaité)
With wdDoc
.InlineShapes(1).Height = 500
.InlineShapes(1).Width = 500
End WithCordialement.
hello, j'ai essayé, sans résultat. Est ce que le (1) doit être adapté ?
Bonjour Pierre,
peux-tu joindre une copie de ton fichier, sans données confidentielles?
Bonjour Sequoyah,
voici l'onglet extrait avec la macro (données sensibles retirées). J'ai mis une adresse bidon pour éviter un envoi intempestif
Merci d'avance pour ton aide.
PierreGC
Bonjour Pierre,
en effet le résultat est assez médiocre, peut-être qu'on a une petite amélioration en utilisant
Selection.CopyPicture Appearance:=xlPrinter, Format:=xlPictureau lieu de
Selection.CopyPicture Appearance:=xlScreen, Format:=xlBitmapje te propose une autre solution:
Sub DiffusionTdB2()
Dim olApp As Object, NewMail As Object, objChart As Object
Dim ChartName As String, imgPath As String
Dim tmpImageName As String, Liste As String
Dim RangeToSend As Range
Dim sht As Worksheet
Dim Datejour As Date
On Error GoTo err
Set olApp = CreateObject("Outlook.Application")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Liste = Range("O14")
Datejour = Range("K2")
tmpImageName = VBA.Environ$("temp") & "\tempo.jpg"
Set RangeToSend = Worksheets("Test").Range("B2:M79")
RangeToSend.CopyPicture Appearance:=xlScreen, Format:=xlPicture
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
Set NewMail = olApp.CreateItem(0)
With NewMail
.Subject = "Tableau de bord au " & Datejour
.To = Liste
.HTMLBody = "<HTML><BODY>Bonjour,<br> <br>Veuillez trouver... <br><br><img src=" _
& "'" & tmpImageName & "'/><br> <br> Cordialement. <br>" & " </BODY></HTML>"
.Display
End With
err:
Kill tmpImageName
Set olApp = Nothing
Set NewMail = Nothing
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub