XL 2010 Redimensionner une image avec méthode Range(" ").CopyPicture

spike29

XLDnaute Occasionnel
Bonjour,

J'ai un code me permettant d'envoyer un mail avec dans le corps de mail une copie image d'une plage de cellule de ma Feuil1 ( méthode Range(" ").CopyPicture)

Seule problématique, la taille de cette copie est trop petite et le rendu par mail n'est pas très lisible.

Cela m'oblige donc systématiquement à venir manuellement augmenter au maximum la taille de la copie image.

Deux questions :

1) Comment faire en sorte qu'avec ma méthode .CopyPicture la taille de mon image dans le corps de mail soit maximale ?

2) Comment faire en sorte que l'image copié dans le corps de mail soit de la meilleure qualité possible. A l'heure actuelle même en l'augmentant de manière manuelle elle reste de qualité moyenne.


Merci d'avance pour vos votre aide.

Bonne fin de journée

Ci-dessous le code que j'utilise. Il n'est certainement pas parfait, mais mis à part les deux problèmes cités plus haut il me va pour l'instant très bien :)

En commentaire dans le bas du code, les différents "test" que j'ai pu réaliser sans succès notamment avec la méthode
.Width
.Height


VB:
Sub Mail()

Dim FileExtStr As String
Dim Texte As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim destwb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim OutApp As Object
Dim OutMail As Object
Dim S As Shape
Dim shp As Shape
Dim sNomFic As String, sRep As String, WshShell As Object
LD As String
Dim OL As Object, myItem As Object, wDoc As Object, rng As Object
Dim nb_lignes As Integer

    Set OL = CreateObject("Outlook.Application")
    Set myItem = OL.CreateItem(olMailItem)

    Sheets("Feuil1").Activate



Dim oOutlook As Object

On Error Resume Next
Set oOutlook = GetObject(, "Outlook.application")
On Error GoTo 0

If oOutlook Is Nothing Then
    Shell "Outlook.exe", vbHide
End If


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


destrapportTT = ""
    With Sheets("MAIL")
        For idest = 1 To .[A1].End(xlDown).Row
            destrapportTT = destrapportTT & .Cells(idest, "A").Value & ";"
        Next idest
    End With



Texte = Texte & "Bonjour," & vbCrLf
Texte = Texte & vbCrLf
Texte = Texte & "Cordialement" & vbCrLf
Texte = Texte & vbCrLf



LD = destrapportTT


Set OutApp = CreateObject("outlook.application")
Set OutMail = OutApp.CreateItem(0)
    With OutMail
        .To = LD
        .CC = ""
        .Subject = " TEST "
        .Body = Texte
        .Display
        .OriginatorDeliveryReportRequested = True ' Accusé de dépôt
        .ReadReceiptRequested = True ' Accusé de lecture
        .Importance = 2 ' Niveau d'importance du mail
        


'For Each shp In wordDoc.InlineShapes
'    shp.ScaleHeight = 90
'    shp.ScaleWidth = 90
'Next
        
'ActiveWindow.Zoom = 300
        
Set wDoc = myItem.GetInspector.WordEditor
Range("A3:Y95").CopyPicture xlScreen, xlPicture


':=xlPrinter, Format:=xlBitmap
'xlScreen, xlBitmap
' With .Shapes(ShapeCount)
'            .Width = .Width * 0.75
'            .Height = .Height * 0.75
'            .Copy: .Delete
'        End With
'Selection.ShapeRange.ScaleWidth 5.0965906893, msoFalse, msoScaleFromBottomRight
'    Selection.ShapeRange.ScaleHeight 5.0965905176, msoFalse, _
'        msoScaleFromBottomRight
        
wDoc.Application.Selection.Start = Len(.Body)
wDoc.Application.Selection.End = wDoc.Application.Selection.Start
wDoc.Application.Selection.Paste
        
 
'ActiveWindow.Zoom = 100

    
        
End With
    

End Sub
 

spike29

XLDnaute Occasionnel
Bonsoir Staple,

Merci pour la PJ, j'ai eu peur j'ai crût un instant qu'il s'agissait d'un XLSM en PJ ^^

Alors j'ai inséré cet élément de code présent dans ton fichier :

VB:
 With ThisWorkbook.Worksheets(Feuil1).ChartObjects.Add(rngToPicture.Left, rngToPicture.Top, rngToPicture.Width, rngToPicture.Height)

Comme ceci dans mon code mais cette fois ci plus de PJ et le debogeur qui s'affole.

Sur la base de mon code que manquerait-il donc pour arriver à mes fins ?

Code:
Set wDoc = myItem.GetInspector.WordEditor
Range("A3:Y95").CopyPicture xlScreen, xlPicture

    With ThisWorkbook.Worksheets(Rapport_TT).ChartObjects.Add(rngToPicture.Left, rngToPicture.Top, rngToPicture.Width, rngToPicture.Height)

':=xlPrinter, Format:=xlBitmap
'xlScreen, xlBitmap
' With .Shapes(ShapeCount)
'            .Width = .Width * 0.75
'            .Height = .Height * 0.75
'            .Copy: .Delete
'        End With
'Selection.ShapeRange.ScaleWidth 5.0965906893, msoFalse, msoScaleFromBottomRight
'    Selection.ShapeRange.ScaleHeight 5.0965905176, msoFalse, _
'        msoScaleFromBottomRight
        
wDoc.Application.Selection.Start = Len(.Body)
wDoc.Application.Selection.End = wDoc.Application.Selection.Start
wDoc.Application.Selection.Paste


Je suis quasiment persuadé que la solution doit se trouver parmi les éléments en commentaire qu'ils faut adapter et mettre au bon endroit moi je ne vois vraiment pas.

Merci d'avance.
 

spike29

XLDnaute Occasionnel
J'ai justement testé les deux....

VB:
C'est cet élément qui est présent dans ma PJ
With ThisWorkbook.Worksheets(wksName)
et absolument pas
With ThisWorkbook.Worksheets(Feuil1)
Commence d'abord par tester le code proposé sans l'altérer, et on en reparle ensuite...
 

spike29

XLDnaute Occasionnel
Je teste systématiquement dans mon code comme posté précédemment.

J'ai pas l'intention de remodeler l'ensemble de ma macro en repartant d'une feuille blanche...

Tu n'as pas plutôt une piste avec width et height a utiliser avec le code que j'ai fournis ?
 

Staple1600

XLDnaute Barbatruc
Re

=>spike29
Dommage...
Donc j'ai fait l'effort de ceci pour le reste de communauté des XLDiens
(qui pourront confirmer que l'export fonctionne)
Je mets le mode d'emploi pour ceux qui auront la curiosité de faire le test.
1) Lancer la macro Créer_Test
2) Enregistrer le classeur de test en *.xlsm
3) Lancer la macro test_Export_To_Rng
Vous obtenez un fichier PNG, copie conforme de la plage A1:F33
(qui se trouvera dans votre %temp%)
VB:
Sub Créer_TEST()
Dim c As Range
Randomize 1600
Application.ScreenUpdating = False
[A1:F1] = "=""ENTETE""&COLUMN()": [A2:F33] = "=REPT(ADDRESS(ROW(),COLUMN(),4),3)"
[A1:F33] = [A1:F33].Value: [A1:F33].Borders.Weight = 2
For Each c In [A2:F33]
c.Interior.ColorIndex = Application.RandBetween(1, 56)
Next
End Sub
Sub test_Export_To_Rng()
createPNG Range("A1:F33"), "testOK"
End Sub

Private Sub createPNG(ByRef rngToPicture As Range, nameFile As String)
    Dim wksName As String
    wksName = rngToPicture.Parent.Name
    On Error Resume Next
        Kill Environ$("temp") & "\" & nameFile & ".png"
    On Error GoTo 0
    rngToPicture.CopyPicture
    'Paste the picture in Chart area of same dimensions
    With ThisWorkbook.Worksheets(wksName).ChartObjects.Add(rngToPicture.Left, rngToPicture.Top, rngToPicture.Width, rngToPicture.Height)
        .Activate
        .Chart.Paste
        'Export the chart as PNG File to Temp folder
        .Chart.Export Environ$("temp") & "\" & nameFile & ".png", "PNG"
    End With
    Worksheets(wksName).ChartObjects(Worksheets(wksName).ChartObjects.Count).Delete
End Sub
NB: spike29=> merci de prendre le temps de tester le code fourni tel quel (et sur un classeur vierge)
Ce qui m'évitera de "perdre du temps" à re-tester ce que je sais déjà fonctionnel (puisque rangé dans mes archives)
Sur ce, vu l'heure, je vais me coucher. ;)
 

Staple1600

XLDnaute Barbatruc
Bonjour lefil

Par acquis de conscience, j'ai testé ce matin (au boulot)
Et j'ai un peu étoffé le code
Test OK - l'export se fait correctement, le mail est bien généré.
NB: Comme j'ai fait le test avec ma propre adresse mail, il manque un test avec le test vers un mail externe
(Car dans mon test, l'image est sur mon PC)
Il faudrait voir ce qui se passe quand le mail s'affiche chez le destinataire.
Mais le principal est là : le code fonctionne pour ce qui est d'exporter un plage de cellules dans Outlook
VB:
Sub Create_Email(ByVal strTo As String, ByVal strSubject As String)
Dim rngToPicture As Range, outlookApp As Object, Outmail As Object, strBody$, strTempFilePath$, strTempFileName$
'Name it anything, doesn't matter
strTempFileName = "RangeAsPNG"
'rngToPicture is defined as NAMED RANGE in the workbook, do modify this name before use
Set rngToPicture = Range("rngToPicture")
Set outlookApp = CreateObject("Outlook.Application")
Set Outmail = outlookApp.CreateItem(0)
'Create an email
With Outmail
    .To = strTo
    .Subject = strSubject
    Call createPNG(rngToPicture, strTempFileName)
    'Embed the image in Outlook
    strTempFilePath = Environ$("temp") & "\" & strTempFileName & ".png"
    .Attachments.Add strTempFilePath, 1, 0
    strBody = "<html><body>Bonjour,<br><br>"
    strBody = strBody & "première ligne de texte du mail<br>"
    strBody = strBody & "seconde ligne de texte du mail<br>"
    strBody = strBody & "<img src='cid:RangeAsPNG.png' style='border:0'><br>"
    'strBody = strBody & "<img src='cid:RangeAsPNG.png' height=320 width=400 style='border:0'><br>" ' a tester
    strBody = strBody & "Cordialement,"
    strBody = strBody & "</body></html>"
    .HTMLBody = strBody
    .Display
End With
Set Outmail = Nothing
Set outlookApp = Nothing
Set rngToPicture = Nothing
End Sub
L'autre macro: createPNG n'a pas été modifiée.
 

spike29

XLDnaute Occasionnel
Re-Bonjour Staple,

J'ai testé ton code.

Question idiote, on est d'accord c'est bien dans un module qu'il doit être utilisé ?

Impossible de le déclencher chez moi... je l'ai bien testé dans un classeur vierge.

La macro semble ne pas être reconnue

Une explication ?

Merci d'avance

Bonne fin de journée
 

Staple1600

XLDnaute Barbatruc
Re

Une simple réponse à la question posée aurait suffi...
Donc je la repose
(Il se fait tard. Pas le temps de télécharger un énième fichier aujourd'hui)
Si tu suis scrupuleusement le mode opératoire du message#9
(Et donc sur un fichier vierge au départ), car c'est un code pour test
Cela doit fonctionner.
(J'ai fait deux fois le test)
A toi désormais, d'être attentif et de faire ce que j'ai décrit.
 

spike29

XLDnaute Occasionnel
Et bien la dernière que tu m'as envoyer :

Sub Create_Email


Car c'est bien là mon besoin. Envoyer un mail et un copie images d'une plage de cellule.

Exactement comme dans mon fichier initiale que j'ai envoyé et comme celui que j'ai reposté sur un autre sujet que tu suit en ce moment.

Tes deux autres macro fonctionnent ça oui, mais elle ne répondent pas dans l'absolu à mon besoin et ne semble pas de lier avec la macro Create Email , en tout cas pas chez moi.

Un fichier fonctionnel clef en main permettrait certainement de raccourcir l'échange mais je ne te relance pas sur ce sujet... 😅
 

Discussions similaires

Réponses
2
Affichages
98