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
Si on repartait de mon code d'origine en se focalisant sur le besoin et uniquement sans repartir forcément d'une feuille blanche cela faciliterait l'échange.

Car repartir systématiquement d"un code inconnu et non pas du tout maitrisé par l'interlocuteur ne peux qu'engendrer des débats à rallonge ;)

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
 

Staple1600

XLDnaute Barbatruc
Re

[avis personnel]
Tu viens sur le forum demander de l'aide.
OK pas de souci.
C'est ce que j'essaie de faire.
Mais tu restes sur ton idée.
Tu ne suis pas les conseils et ou mode opératoire (qui sont chronophage à faire pour le répondeur...)
Bref, le code que je propose fonctionne.
Il est simple et facile à maintenir.
Le "tien" ne fonctionne pas.
Libre à toi de faire comme bon te semble
Libre à moi de rester sur mon code fonctionnel
[/avis personnel]

NB: La rallonge c'est toi qui l'a dans la main.
Fais le test du message#9 tel que décrit.
Ni plus, ni moins.
Et après on débranche.
:rolleyes:
 

Staple1600

XLDnaute Barbatruc
Re

Par acquis de conscience, j'ai ouvert TEST5.xlsm
Et ce que j'y ai vu confirme ce que je disais
Tu n'as pas daigné prendre la peine de faire le test tel qu'expliqué
Alors que moi, j'ai consacré du temps
1) a rédigé le mode opératoire
2) à faire plusieurs fois le test.

Donc je laisse tomber pour ce soir

Quand tu seras décidé à simplement faire ce qu'on lit dans le message#9, tu viendras me dire :
"Ah, oui en fait , le code de ton test fonctionne"

Et seulement alors, on commencera à l'adapter à ton projet

NB: Pour info, dans ton PJ
La macro createPNG est présente deux fois !!
(Dans un module, et dans le code de la feuille 1)
Il manque la macro qui créé les données de test.

Bref, c'est donc logique que cela ne fonctionne pas, puisque tu n'as respecté les directives.
 

spike29

XLDnaute Occasionnel
Si si je lis bien et je l'ai fais ton test mais honnêtement ta macro "Create_Email" est impossible à lancer.

ça doit certainement être super con je m'en excuse déja mais chez moi ça ne marche pas...

Encore une fois je poste on fichier mais simplifier l'échange.

Tes codes sont certainement hyper bien pensés et fonctionnent tel une horloge Suisse.

Mais en désarçonnant l'interlocuteur avec des codes à des années lumières de son niveau à mon sens ça complexifie le tout...

Un apprenti mécano aussi curieux qu'il puisse être ne démarre pas par faire une synchro carbu dans son apprentissage s'il ne maitrise pas encore le fonctionnement complet de cet organe.
En VBA on m'a toujours dit fait un code qui marche et après tu optimises sinon c'est cassage de dent assurer.

Là tu m'envoies du caviar alors que je ne sais même pas le goût qu'on les oeufs de lump (métaphore presque d'actualité avec 3 semaines de retards....😅)

Mon code marche, il envoi un mail, une copie image dans le corps de mail.

Je cherche simplement et uniquement à avoir d'office une copie image la plus grande possible.

Après, l'optimisation de mon code j'en fais mon affaire. Lorsque l'ensemble de mes besoins seront solutionnés.

Je sais que tu veux bien faire mais honnêtement repartir systématiquement de 0, qui plus est lorsque c'est sur des bout de codes sans fichier en face, ça devient assez compliqué 😅

Et je perds malheureusement le fil.
 

Pièces jointes

  • TEST5.xlsm
    27.3 KB · Affichages: 1

Staple1600

XLDnaute Barbatruc
Re

Ah bah Voila
Je n'avais pas lu ceci précédemment dans la discussion, non ? ;)
(sauf erreur de ma part)
Mon code marche, il envoi un mail, une copie image dans le corps de mail.
Pour le reste, tu ignores comment est réglé l'Outlook de tes destinataires, ni leur résolution d'écran.

Mon test copie la plage dans le mail, et c'est tout à fait lisible, non ?
 

spike29

XLDnaute Occasionnel
Dans le premier fichier TEST5 j'avais uniquement testé la partie create mail.

C'est cette partie là qui m'intéresse.

Et ensuite lorsque je t'ai répondu que ça ne marchait pas j'ai bien entendu testé le mod op #9...

le voici dans mon précédent post #20.

Il se fait tard.

Merci quand même et bonne soirée

Je regarderais tout cela à tête reposé ou me relancerai dans mes recherches.
 

Staple1600

XLDnaute Barbatruc
Re

La macro CreateMail est macro dite macro paramétrée
La macro createPNG est également une macro paramétrée
Private Sub createPNG(ByRef rngToPicture As Range, nameFile As String)
Et le Private devant fait que tu ne peux la lancer comme les autres macros

Elle doit être appelée par une autre macro
Exemple
VB:
Sub test()
createPNG ActiveSheet.Range("A1:D5"), "nomimageTemp"
End Sub
Qui comme expliqué dans les commentaires exportera la plage indiquée (ici A1:D5) dans le répertoire Temp de Windows
C'est cette image temporaire qui est ensuite insérée dans le corps du mail par la macro Create_Email.
 

spike29

XLDnaute Occasionnel
J'aimerai répondre à ta question du post #21 mais ton code je n'arrive absolument pas à le faire fonctionner chez moi...
Pourtant c'est pas le premier code d'envoi par mail que je manipule.
Je te laisse regarde ma dernière PJ envoyé et me dire ce qui cloche peut-être.

Je ne connais pas la config de mes destinataire mais ce que je sais c'est qu'aujourd'hui si je veux que l'image soit nette il faut qu'avant d'envoyer le mail je l’agrandisse en scrollant au maximum.

Certain utilisateurs oubli de le faire et résultat image flou... destinataires pas contents...

je souhaite uniquement que l'image copié par défaut soit de la plus grande taille possible.

Simplement ^^
 

spike29

XLDnaute Occasionnel
OK.... ça marche très certainement mais ça fais une belle usine je trouve.

Avis personnel bien entendu.

Mon code avec toute les maladresses et autres qu'il doit comporter je n'en doute pas, se contente de faire ce qu'on lui dit.

Copie en tant qu'image telle plage et colle là moi dans mon mail, basta ^^

la copie image dans un répertoire je suis pas du tout fan, travaillant sur sharepoint en plus...bref je ne te fais pas un dessin, je veux rester le plus minimaliste possible.

Je connais les private sub , N'ayant pas vu de Private dans le code du mail je ne voyait pas pourquoi il restait indisponible.

Du coup comment est censé se lancer ta macro ? qui déclenche qui ?
 

Staple1600

XLDnaute Barbatruc
Re

Dans ta dernière PJ, aucune trace d'un code qui produit le mail
:rolleyes:
Un truc de genre
VB:
Sub Envoyer_Mail()
Create_Email "staple1600@domain.fr", "Objet: test"
End Sub
Donc si un classeur dans un module standard , tu as ces 3 trois macros
createPNG ' (*)sert pour la copie de la plage
Create_Email ' (*) construit le le mail
Envoyer_Mail
(*) Ces deux macros, c'est ce que j'appelle des macros outils
Elle sont fonctionnelles, on n'y touche plus

La seule qu'on peut modifier à loisir, c'est Envoyer_Mail

NB: Tout cela était expliqué en long et en large dans les divers modes opératoires que j'ai posté dans ce fil.

Tu as tout ce qu'il faut.

NB: Dans la version que tu utilises, dans ta dernière PJ
C'est explicite: la plage à exporter est une plage nommée
VB:
'rngToPicture is defined as NAMED RANGE in the workbook, do modify this name before use
Set rngToPicture = Range("rngToPicture")
 

Discussions similaires

Réponses
11
Affichages
299
Haut Bas