En VBA, capturer le contenu d'1 cellule pour l'exporter en fichier JPEG
Bonsoir,
Est-il possible d'exporter le contenu d'une cellule pour qu'il soit enregistré en fichier image (c-à-d que cette image serait comme une sorte de capture d'écran de la cellule) dans un dossier dont j'aurais le choix du chemin. Et bien sûr j'aurais le choix de nommer le nom de chaque fichier JPEG mais directement dans l'éditeur VBA.
Exemple :
Quand je clique sur le bouton "Enregistrer en Images", la cellule D6 et la cellule D7 sont exportées en 2 JPEG distincts. Et on me donne le choix d'emplacement pour enregistrer les 2 fichiers. Et bien sûr j'aurais le choix de nommer le nom de chaque fichier JPEG mais directement dans l'éditeur VBA.
C'est faisable ?
Alors ça peut être du JPEG ou au autre format, si y'a mieux
Merci.
Bonne soirée
Bonsoir vodoraix
Un essai VBA dans le classeur joint.
- sélectionner une plage contigüe ou non
- puis cliquer sur le bouton
Avant de lancer la macro, deux constantes sont à définir dans le code:
- Const MonDossier qui est le nom complet du dossier de sauvegarde (yc lettre de lecteur)
- Const FacteurZoom qui est le facteur de zoom appliqué juste pour la sauvegarde
Le code (un tout petit peu commenté) est dans Module1:
Sub PlageVersFichierImage()
Const MonDossier = "C:\toto\AAAAA\Bidon" ' nom complet du dossier de sauvegarde (yc lettre de lecteur)
Const FacteurZoom = 200 ' Zoom juste pour la sauvegarde
Dim chemin, oldzoom, x As Range, gr As ChartObject, Fichier
chemin = MonDossier: chemin = chemin & IIf(Right(chemin, 1) = "\", "", "\") ' dossier de sauvegarde
oldzoom = ActiveWindow.Zoom ' sauvegarde du Zoom actuel
ActiveWindow.Zoom = FacteurZoom ' Zoom pour la sauvegarde
For Each x In Selection.Cells ' pour chaque cellule de la sélection
x.CopyPicture Appearance:=xlScreen, Format:=xlPicture ' on copie la cellule x en tant qu'image
Set gr = Selection.Parent.ChartObjects.Add(Left:=x.Left, Top:=x.Top, _
Width:=x.Width, Height:=x.Height) ' création d'un ChartObject à la dimension de la cellule
gr.Activate: ActiveChart.Paste ' activation du ChartObject, on y colle l'image
ChDrive Left(chemin, 1): ChDir chemin: Fichier = False ' on se met sur le bon lecteur et le bon dossier
' on demande le nom du fichier où sauvegarder
Fichier = Application.GetSaveAsFilename(InitialFileName:=Left(x.Text, 50), FileFilter:="Image file (*.jpg), *.jpg")
If Fichier <> False Then gr.Chart.Export Fichier: gr.Delete ' on sauvegarde l'image
Next x
ActiveWindow.Zoom = oldzoom ' on rétablit le zoom initial
End SubBonjour mafraise et merci beaucoup
Tu as compris à 100% le sujet et mes explications !!!! Et même au-delà, avec les cellules contiguës puisque c'est exactement ce dont j'avais besoin !!!!!!!!!!!!!!!
Ton Zoom est une super idée aussi
Et même, j'ai testé et ça marche ==> en appuyant sur "Ctrl", je peux enregistrer des cellules non mitoyennes
Trop fort !
Cette feuille de cellules à capturer en images est protégée par un mdp, donc pour pouvoir sélectionner mes cellules, il faudrait "unprotect" en début de procédure et "protect" en fin mais je ne suis pas certain de les mettre aux bon endroits...
Juste, je ne sais pas comment créer un dossier enregistré automatiquement sur le bureau.
Ca serait nécessaire car plusieurs PC et/ou utilisateurs différents vont utiliser ce classeur.
Ainsi, tout le monde aurait ce fichier "Résultats_Perfs_JP2025" créé sur son bureau et contenant l'ensemble des images
Un exemple ci-dessous d'une procédure créée par BsAlv et qui marchait parfaitement. Bon, j'ai supprimé une grosse partie du code que je n'utilisais jamais.
Tu saurais intégrer qqes lignes du code ci-dessous au tien ?
Encore merci mafraise
à +
Function Dossier()
'***********************************
'demander le dossier pour sauvegarder les images
'***********************************
Dim sAnswer, arr, s As String, bAutre As Boolean
s = "Résultats_Perfs_JP2025" 'nom sous-dossier dans "bureau"
s = Range("MonDossier").Value2
If s <> "" Then
If Dir(s, vbDirectory) = "" Then 'vérifier si dossier existe
If Not bOpen Then 'ne pas parcourir cette partie en ouvrant le fichier avec thisworkbook.open !!!!
If StrComp(Range("mondossier").Offset(-1).Value2, arr(1, 1), 1) = 0 Then 'c'est pour le bureau
If Dir(CreateObject("WScript.Shell").SpecialFolders("Desktop"), vbDirectory) <> "" Then
MkDir s 'ce dossier existe, alors créer sous-dossier
MsgBox "Un nouveau dossier Résultats_Perfs_JP2025 vient d'être créé sur votre bureau", vbInformation, s
End If
End If
If Dir(s, vbDirectory) = "" Then 'sous-dossier existe ?
MsgBox "Erreur, " & s & ",ce dossier n'existe pas", , Range("Mondossier").Offset(-1).Value2
s = ""
End If
End If
End If
End If
Dossier = s
bOpen = False
End FunctionBonjour @vodoraix
Modifications apportées:
- la constante DossierBureau doit indiquer le nom du dossier de sauvegardé situé sur le bureau du PC. S'il n'existe pas alors il sera créé. Indiquer juste le nom sans "\" à la fin
- les cellules "vides" ne sont pas sauvegardées
- la macro sait maintenant traiter les cellules fusionnées (le cas échéant)
Le code modifié:
Sub PlageVersFichierImage()
Const DossierBureau = "Résultats_Perfs_JP2025" ' juste le nom du dossier sur le Bureau à utiliser
Const FacteurZoom = 200 ' Zoom juste pour la sauvegarde
Dim chemin, oldzoom, x As Range, gr As ChartObject, Fichier, i&
chemin = Environ("userprofile") & "\DeskTop" ' le chemin du bureau de Windows
ChDrive Left(chemin, 1) ' on se place sur le bon lecteur
chemin = chemin & IIf(chemin Like "\*", "", "\") & DossierBureau ' le dossier de sauvegarde
If Dir(chemin & "\nul") = "" Then MkDir chemin ' si le dossier n'existe pas alors on le crée
Do: DoEvents: Loop Until Dir(chemin) = "" ' Attente pendant l'éventuel création du dossier
ChDir chemin ' on se place dans le bon dossier
oldzoom = ActiveWindow.Zoom ' sauvegarde du Zoom actuel
ActiveWindow.Zoom = FacteurZoom ' Zoom pour la sauvegarde
For Each x In Selection.Cells ' pour chaque cellule de la sélection
If Trim(x) <> "" Then ' la cellule n'est pas vide
Set x = x.MergeArea ' x est la zone fusionnée de x (égale à x si x n'est pas fusionnée)
x.CopyPicture Appearance:=xlScreen, Format:=xlPicture ' on copie la cellule x en tant qu'image
Set gr = Selection.Parent.ChartObjects.Add(Left:=x.Left, Top:=x.Top, Width:=x.Width, _
Height:=x.Height) ' création d'un ChartObject à la dimension de la cellule
gr.Activate: ActiveChart.Paste ' activation du ChartObject, on y colle l'image
' on demande le nom du fichier où sauvegarder
Fichier = False
Fichier = Application.GetSaveAsFilename(InitialFileName:=Left(x(1, 1).Text, 50), FileFilter:="Image file (*.jpg), *.jpg")
If Fichier <> False Then gr.Chart.Export Fichier: gr.Delete ' nom du fichier saisi => on sauvegarde l'image
End If
Next x
ActiveWindow.Zoom = oldzoom ' on rétablit le zoom initial
ChDir ".." ' on se place par défaut sur le bureau
End SubMerci beaucoup mafraise
Parfait pour les cellules fusionnées, j'y avais pas pensé. Dans mon cas présent, j'en ai pas mais ça pourra arriver, un jour
J'ai parfois une erreur (là j'avais sélectionné 4 cellules) :
Là j'ai compris pourquoi, c'est que ces 4 cellules se sont transformées en image dans la feuille et il n'y a plus les formules, elles ont disparu.
Donc la manip a joué sur leur format... Et l'erreur vient que ces cellules ne sont plus reconnues comme cellules mais comme des images dans une cellule
j'ai refait sur d'autres cellules et ça marche...
Et aussi, ça serait possible que le dossier "Résultats_Perfs_JP2025" reste ouvert quand les enregistrements en JPEG sont finis ?
Encore merci mafraise
Re,
vodoraix a dit:
J'ai parfois une erreur (là j'avais sélectionné 4 cellules) :
Là j'ai compris pourquoi, c'est que ces 4 cellules se sont transformées en image dans la feuille et il n'y a plus les formules, elles ont disparu.
Donc la manip a joué sur leur format... Et l'erreur vient que ces cellules ne sont plus reconnues comme cellules mais comme des images dans une cellule
Ceci se produit si la macro ne se termine pas correctement comme par exemple une erreur en cours d'exécution. Alors une image reste au-dessus de la cellule. Il suffit de supprimer l'image (clique-droit sur un carré de l'image pour la sélectionner puis la touche Suppr).
Je vais fournir une version v3 qui évite ce genre de problème.
vui, c'est exactement ce qu'il s'est passé
Une erreur en cours d'exécution...
J'ai supprimé comme tu m'as conseillé de faire
Dernière chose, c'est possible que le nom du fichier image soit ".jpg" et rien d'autre. Ainsi je mets devant le nom qui m'intéresse...
Merci
Bon appétit...
à +
Re,
Voici la v3.
Elle s'assure de supprimer toutes les images temporaires précédemment créées par la macro sur la feuille active.
Comment voulez-vous donner un nom pertinent à un fichier si vous ne savez pas à quelle cellule ce fichier doit correspondre ? C'est pour cette raison que je proposais les 50 caractères du texte de la cellule. Il suffit alors de taper directement le vrai nom désiré (ça efface le nom proposé) puis d'appuyer sur la touche Entrée pour sauvegarder le fichier. Est-ce que je me fourvoie ?
Nan, aucun fourvoiement, tu as 100% raison, je ne réfléchis pas assez bien
Tu m'as fait un travail au millimètre !!!! Parfait !
J'ai fait plein de tests !!!!!!!!!!!!
Juste si je px abuser un tt petit peu, ça serait possible que le dossier "Résultats_Perfs_JP2025" reste ouvert quand les enregistrements en JPEG sont finis ?
Encore milles mercis pour ton temps et ton travail de pro !!!!
Re,
Merci d'avoir bien testé. L'auteur d'un code est toujours assez mal placé pour tester son propre code (du moins c'est ce que crois).
vodoraix a écrit:
Juste si je px abuser un tt petit peu, ça serait possible que le dossier "Résultats_Perfs_JP2025" reste ouvert quand les enregistrements en JPEG sont finis ?
Je ne comprends pas bien ce que signifie "le dossier "Résultats_Perfs_JP2025" reste ouvert quand les enregistrements en JPEG sont finis".
Si le dossier était ouvert dans l'explorateur, il le reste (du moins sur ma bécane). S'il n'est pas ouvert, l'utilisateur doit lancer l'explorateur et aller jusqu'au dossier.
Faut-il, à tout hasard, ouvrir automatiquement l'explorateur sur ce dossier quand la macro est terminée ? Si oui, voici la v4 qui le fait.
Franchement, merci beaucoup !!!!!! Tu as entièrement comblé toutes mes espérances... Bravo !!!!!!!!
Je n'étais même pas sûr au tout début que tout ça était possible.
Le dossier contenant les images reste maintenant ouvert (ça n'était pas le cas avant cette version 4) !!!!!!!!!!! C'est parfait, tu as fait un super job !!!!
Voilà à quoi vont me servir ces images, c'est pour la remise des médailles de mes 89 sportifs sur grand écran avec projection d'un powerpoint grâce à cette option :
J'ai caché l'identité de mes sportifs
Passe un bon w.e.
à bientôt
Re,
Ravi d'avoir pu t'aider. Bons jeux.
Merci...
C'était la semaine dernière mais je prépare ceux de l'an prochain
bonjour vodoraix, salut mafraise,
un tout point d'amélioration, je pense que cette macro fonctionne sans erreurs dans 99%(estimat) des cas, mais pour certains raisons (de mémoire ou vitesse du CPU ou ...), on a une erreur et si on freine la macro un peu, cela passe. Donc avec ces "DoEvents", on atteindra 99.9% sans erreur ....
DoEvents: DoEvents: DoEvents: DoEvents: DoEvents 'ralentir Excel
r.CopyPicture Appearance:=xlScreen, Format:=xlPicture ' on copie la cellule x en tant qu'image
DoEvents: DoEvents: DoEvents: DoEvents: DoEvents 'ralentir Excel
Set gr = Selection.Parent.ChartObjects.Add(Left:=r.Left, Top:=r.Top, Width:=r.Width, _
Height:=r.Height) ' création d'un ChartObject à la dimension de la cellule
DoEvents: DoEvents: DoEvents: DoEvents: DoEvents 'ralentir Excel
gr.Name = "aux-bid-tmp"
gr.Activate: ActiveChart.Paste ' activation du ChartObject, on y colle l'image
DoEvents: DoEvents: DoEvents: DoEvents: DoEvents 'ralentir ExcelBonjour BsAlv
BsAlv a écrit :
un tout point d'amélioration, je pense que cette macro fonctionne sans erreurs dans 99%(estimat) des cas, mais pour certains raisons (de mémoire ou vitesse du CPU ou ...), on a une erreur et si on freine la macro un peu, cela passe. Donc avec ces "DoEvents", on atteindra 99.9% sans erreur ....
Je suis heureux que tu l'aies constaté. J'avais une ou deux fois sauvegardé des images et constaté que quelques images étaient juste des images de cellules 'vides'.
Mais comme par la suite, cela ne s'est plus reproduit, j'ai pensé que c'était l'interface entre ma chaise et mon clavier qui avait merdé. Hé bien ce n'était pas le cas, puisque tu viens de décrire la même anomalie.
Merci pour ton intervention pertinente.
Bon dimanche.
nota : c'est bien une des très rares fois où je suis plus rapide que le PC, moi, qui ordinairement me 'hâte avec lenteur'.
Bonjour Bart' et mafraise
Très drôle, "l'interface entre le clavier et la chaise"....
Vous me conseiller donc une version 5 pour améliorer la stabilité et rapidité de la macro ?
Ces lignes seraient à placer à quels endroits, plizz ==>
___
___
___
Sub PlageVersFichierImage()
Const DossierBureau = "Résultats_Perfs_JP2025" ' juste le nom du dossier sur le Bureau à utiliser
Const FacteurZoom = 90 ' Zoom juste pour la sauvegarde
Dim z, chemin, oldzoom, x As Range, gr As ChartObject, y As ChartObject, Fichier, i&, r As Range
Nettoyage
Set z = Selection ' affectation à z de la selection en cours
If TypeName(z) <> "Range" Then Exit Sub ' si z n'est pas une plage alors on ne fait rien
chemin = Environ("userprofile") & "\DeskTop" ' le chemin du bureau de Windows
ChDrive Left(chemin, 1) ' on se place sur le bon lecteur
chemin = chemin & IIf(chemin Like "\*", "", "\") & DossierBureau ' le dossier de sauvegarde
If Dir(chemin & "\nul") = "" Then MkDir chemin ' si le dossier n'existe pas alors on le crée
Do: DoEvents: Loop Until Dir(chemin) = "" ' Attente pendant l'éventuel création du dossier
ChDir chemin ' on se place dans le bon dossier
oldzoom = ActiveWindow.Zoom ' sauvegarde du Zoom actuel
ActiveWindow.Zoom = FacteurZoom ' Zoom pour la sauvegarde
For Each x In z ' pour chaque cellule de la sélection
If Trim(x) <> "" Then ' la cellule n'est pas vide
Nettoyage ' supprimer les précédentes images sur la feuille
Set r = x.MergeArea ' y est la zone fusionnée de x (égale à x si x n'est pas fusionnée)
r.Select ' sinon il y a quelques bizarreries
r.CopyPicture Appearance:=xlScreen, Format:=xlPicture ' on copie la cellule x en tant qu'image
Set gr = Selection.Parent.ChartObjects.Add(Left:=r.Left, Top:=r.Top, Width:=r.Width, _
Height:=r.Height) ' création d'un ChartObject à la dimension de la cellule
gr.Name = "aux-bid-tmp"
gr.Activate: ActiveChart.Paste ' activation du ChartObject, on y colle l'image
' on demande le nom du fichier où sauvegarder et on sauvegarde
Fichier = False
Fichier = Application.GetSaveAsFilename(InitialFileName:=Left(x(1, 1).Text, 50), FileFilter:="Image file (*.jpg), *.jpg")
If Fichier <> False Then gr.Chart.Export Fichier ' nom du fichier saisi => on sauvegarde l'image
Nettoyage ' supprimer les précédentes images sur la feuille
End If
Next x
ActiveWindow.Zoom = oldzoom ' on rétablit le zoom initial
Nettoyage ' supprimer les précédentes images sur la feuille
CreateObject("WScript.Shell").Run chemin ' afficher le dossier
End Sub
Sub Nettoyage() ' supprimer les précédentes images sur la feuille
Dim y
On Error Resume Next ' en cas d'erreur on passe
For Each y In ActiveSheet.ChartObjects ' pour chaque ChartObject, si son nom commence
If LCase(y.Name) Like "aux-bid-tmp*" Then y.Delete ' par "aux-bid-tmp", on le supprime
Next y
On Error GoTo 0 ' on reprend en compte les erreurs
End SubBon dimanche à vous 2
Hello,
A noter que si les cellules à sauvegarder sont constituées de texte ou de valeurs (pas photos ) on a plutôt intérêt à sauvegarder en format png . il n'y a que cela à faire dans le code :
Fichier = Application.GetSaveAsFilename(InitialFileName:=Left(x(1, 1).Text, 50), FileFilter:="Image file (*.png), *.png")Si les cellules contiennent que du texte , la compression est supérieure au jpeg et il n'y a pas de dégradation ( elle est légère avec le jpeg).
Voici une comparaison pour la taille des fichiers générés :
et une comparaison visuelle pour les fichiers Cellules fusionnées (grossissement 400%) :
Jpg :
Png :
Le png ne dégrade jamais une image. Mais pour des photos ou des graphiques avec beaucoup de détails , les fichiers peuvent être beaucoup plus gros que les fichiers jpeg.
Ami calmant, J.P
Bonjour J.P. et merci beaucoup
C'est incroyable ta démonstration ==> 4 fois plus léger pour un résultat supérieur !!!
Ca me servira pour le site que j'ai créé !!!
Et je vais l'adapter à mon VBA
Merci beaucoup et vive le PNG
Je viens de tester :
JPG =
PNG =
Exact : Le fond est un peu moins pixellisé et la couleur mieux respectée et le "C" de "CLT" est un peu plus net !!!!
Et la taille c'est 5 fois moins !
