Sauvegarde d'une image modifiée en VB [Résolu]

Signaler
Messages postés
4
Date d'inscription
vendredi 30 avril 2010
Statut
Membre
Dernière intervention
14 avril 2011
-
Messages postés
4
Date d'inscription
vendredi 30 avril 2010
Statut
Membre
Dernière intervention
14 avril 2011
-
Bonjour à tous,

Ce post pour vous demander si vous connaissez un moyen en VBA pour sauvegarder une image.

J'ai chargé une image que j'ai retaillée pour mes besoins perso, mais je ne trouve pas le moyen de l'enregistrer automatiquement.

ActiveSheet.Pictures.Insert _( "D:\TrtPNG\MonImage.png").Select
Selection.ShapeRange.PictureFormat.CropLeft = 0
Selection.ShapeRange.PictureFormat.CropRight = 50.25

?????? 'que faut il faire pour la sauvegarder ?

Merci d'avance pour votre aide.

Kedubon
"les bugs c'est comme les murs, ça ne se pousse pas, ça se contourne)

4 réponses

Messages postés
4
Date d'inscription
vendredi 30 avril 2010
Statut
Membre
Dernière intervention
14 avril 2011

Super Le Pivert, ça marche très bien

Je vais pouvoir continuer mes activités nocturnes :-)

A charge de revanche (si je peux te rendre service)

Bonne soirée à toi

Kedubon

"Etre en vacances c'est n'avoir rien à faire et avoir toute la journée pour le faire" :-)
Messages postés
6790
Date d'inscription
jeudi 13 septembre 2007
Statut
Contributeur
Dernière intervention
3 juin 2020
107
Bonjour,
Tu peux te servir du presse-papier.
A mettre dans un module:

'http://excel.developpez.com/faq/?page=PressePapier
Option Explicit
Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" _
    (ByVal hwnd As Long, ByVal lpOperation As String, _
    ByVal lpFile As String, ByVal lpParameters As String, _
    ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Sub Image_ClipBoard()
Dim x As Byte
Dim Sh As Shape
Dim monImage As String

'Compte le nombre d'objet initial dans la feuille
x = ActiveSheet.Shapes.Count

Application.ScreenUpdating = False
ActiveSheet.Range("A1").Select
'Colle le contenu du presse papier dans la feuille de calcul
ActiveSheet.Paste
'vérifie si le collage effectué correspond à une image
If x = ActiveSheet.Shapes.Count Then
    Application.ScreenUpdating = True
    MsgBox "Opération annulée"
    Exit Sub
    
    Else
    
    'Récupère la dernière forme de la feuille
    Set Sh = ActiveSheet.Shapes(ActiveSheet.Shapes.Count)
    'Définit le nom et le lieu de stockage de l'image
    monImage = ActiveWorkbook.Path & "\monimage" & ".jpg"
     MsgBox "L'image est sauvegardée dans le dossier ClipBoard_VBA."
    'Colle l'image dans un graphique
    With ActiveSheet.ChartObjects.Add(0, 0, Sh.Width, Sh.Height).Chart
        .Paste
        'Sauvegarde l'image du graphique au format jpg
        .Export monImage, "JPG"
    End With
    
    'Supprime le graphique et la forme.
    With ActiveSheet
        .ChartObjects(ActiveSheet.ChartObjects.Count).Delete
        .Shapes(ActiveSheet.Shapes.Count).Delete
    End With
    
    Application.ScreenUpdating = True
    
    
    '-------------------------------------------------------------
    'Option pour les utilisateurs de Windows XP :
    'visualisation de l'image créée, avec l'apercu images_telecopies Windows
    'testé avec Excel2002 et WinXP
    
    ShellExecute 0, "open", "rundll32.exe", _
        "C:\WINDOWS\System32\shimgvw.dll,ImageView_Fullscreen " & monImage, 0, 1
End If
End Sub


et pour appeler:

ActiveSheet.Pictures.Insert("D:\TrtPNG\MonImage.png").Select
Selection.ShapeRange.PictureFormat.CropLeft = 0
Selection.ShapeRange.PictureFormat.CropRight = 50.25
  Image_ClipBoard


J'ai essayé, cela fonctionne
@+ Le Pivert
Messages postés
6790
Date d'inscription
jeudi 13 septembre 2007
Statut
Contributeur
Dernière intervention
3 juin 2020
107
J'ai oublié de copier l'image
Pour appeler:

ActiveSheet.Pictures.Insert("D:\TrtPNG\MonImage.png").Select
Selection.ShapeRange.PictureFormat.CropLeft = 0
Selection.ShapeRange.PictureFormat.CropRight = 50.25
   Selection.Copy
  Image_ClipBoard
Messages postés
4
Date d'inscription
vendredi 30 avril 2010
Statut
Membre
Dernière intervention
14 avril 2011

Merci beaucoup Le Pivert

Je vais tester ce code dès ce soir...

"La véritable noblesse consiste non pas à être supérieur à un autre homme, mais à ce qu'on était auparavant"

^^