XL 2019 Export image nommée

[bambi]

Bonjour à tous

Dans le fichier joint, je cherche à exporter sous forme d'image le range("C1:Y34") de la feuille
Mais j'ai une contrainte, je voudrais que cette image soit nommée par "un préfixe + la date du jour"
Pour aujourd'hui cela donnerait par exemple ABC_29_janvier_2021.png

J'ai tenté de modifier ma demande initiale (>> ici) mais sans succès
Donc je préfère vous redonner un fichier vierge

Merci d'avance

 

[patricktoulon]

Bonjour
déjà d'une part on ne peut obtenir un png avec une capture et l'export avec un graph donc c'est Jpg" ou "Gif"
ensuite avec version 2013 et 2016 et + la mémoire est très sollicité par d'autres fonctions et donc il faut attendre que le clipboard ai digéré la capture

teste ceci comme tel dans un module

Option Explicit
#If VBA7 Then
    Private Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Integer) As Long
#Else
    Private Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Integer) As Long
#End If

Sub test()
    Dim chemin$
    chemin = Environ("userprofile") & "\Desktop\mon image.jpg"
    ExportRangeInImage [C1:Y34], chemin
End Sub

Sub ExportRangeInImage(plage As Range, chemin As String)
    Dim chart1 As Object, hPicAvail As Long
    Set chart1 = plage.Parent.ChartObjects.Add(0, 0, 1, 1).Chart
    With CreateObject("htmlfile").parentwindow.clipboardData.clearData("Text"): End With    'on vide le clipboard entre chaque copie pour tester vraiment le available
    With chart1
        With .Parent
            .Width = plage.Width: .Height = plage.Height: .Left = plage.Width + 20:
            plage.CopyPicture
            Do: DoEvents: hPicAvail = IsClipboardFormatAvailable(14): Loop While hPicAvail = 0    'Or (Timer - T) > 1000
            .Select
              .Chart.Paste
            Do: DoEvents: Loop While .Chart.Pictures.Count = 0
            .Chart.Export chemin, "jpg"
            .Chart.Pictures(1).Delete    'on delete a chaque fois l'image collée (important si les plages capturées sont differentes en terme de dimension)
        End With
    End With
    chart1.Parent.Delete
End Sub

 

[patricktoulon]

re
et la même avec utilisation de l'api "IsClipboardFormatAvailable" sans déclaration(compatible All version Excel)

Option Explicit

Sub test()
    Dim chemin$
    chemin = Environ("userprofile") & "\Desktop\mon image.jpg"
    ExportRangeInImage [C1:Y34], chemin
End Sub

Sub ExportRangeInImage(plage As Range, chemin As String)
    Dim chart1 As Object, hPicAvail As Long
    Set chart1 = plage.Parent.ChartObjects.Add(0, 0, 1, 1).Chart
    With CreateObject("htmlfile").parentwindow.clipboardData.clearData("Text"): End With    'on vide le clipboard entre chaque copie pour tester vraiment le available
    With chart1
        With .Parent
            .Width = plage.Width: .Height = plage.Height: .Left = plage.Width + 20:
            plage.CopyPicture
            Do: DoEvents
                hPicAvail = ExecuteExcel4Macro("CALL(""user32"",""IsClipboardFormatAvailable"",""JJC""," & 14 & ")")    '2 pour bitmap,14 pour wmf
            Loop While hPicAvail = 0
            .Select
            .Chart.Paste
            Do: DoEvents: Loop While .Chart.Pictures.Count = 0
            .Chart.Export chemin, "jpg"
            .Chart.Pictures(1).Delete    'on delete a chaque fois l'image collée
        End With
    End With
    chart1.Parent.Delete
End Sub

testé sur 2016

 

[Usine à gaz]

Bonjour Patrick, Bambi, le Forum,

Très intéressant ton code Patrick ... mais donne une image avec du blanc.
Voir fichier joint et photo résultat obtenu.


Bonne journée,
lionel

 

[bambi]

Bonjour Patrick
Tout d'abord, merci pour ta réponse

Je suis étonnée pour le format png puisque dans le lien que je donne dans mon message intitial, mapomme m'a donné une solution avec ce format
>> https://www.excel-downloads.com/thr...e-en-une-image-nommee.20040347/#post-20288516

Mais peu importe, ce n'est pas très important; jpeg ou gif me vont très bien aussi

Par contre, ma demande était pour un format spécifique de sortie

Mais j'ai une contrainte, je voudrais que cette image soit nommée par "un préfixe + la date du jour"

Pour aujourd'hui cela donnerait par exemple ABC_29_janvier_2021.png

En fait, dans la réponse de mapomme (lien ci-dessus) , un dossier est créé avec la date du jour
et l'image est enregistrée dans ce dossier
Mais je n'ai pas réussi à modifier sa macro pour obtenir le résultat voulu

Sub export_images()
Const Chemin = "D:\Mon Dossier"     '<--- ici le chemin du dossier où sauvegarder
Dim gr1 As Object, Source1 As Range, nom As Date, fichier$
   Application.ScreenUpdating = False
   fichier = Chemin & IIf(Right(Chemin, 1) = "\", "", "\")
   fichier = fichier & Format(Now(), "ddmmyy_hhmm") & ".png"
   Set Source1 = Range("A1:R17")
   Source1.CopyPicture xlScreen, xlPicture
   With Sheets(1).ChartObjects.Add(0, 0, Source1.Width, Source1.Height)
      .Activate:: .Chart.Paste: .Chart.Export fichier: .Delete
   End With
End Sub

 

[bambi]

J'avance dans ma recherche
Cette macro fonctionne presque

Sub export_images()
Const chemin = "D:\Mon Dossier"     '<--- ici le chemin du dossier où sauvegarder
Dim gr1 As Object, Source1 As Range, nom As Date, fichier$
   Application.ScreenUpdating = False
   fichier = chemin & IIf(Right(chemin, 1) = "\", "", "\")
   fichier = fichier & Format(Now(), "dd mmmm yyyy") & ".png"
   Set Source1 = Range("C1:Y34")
   Source1.CopyPicture xlScreen, xlPicture
   With Sheets(1).ChartObjects.Add(0, 0, Source1.Width, Source1.Height)
      .Activate:: .Chart.Paste: .Chart.Export fichier: .Delete
   End With
End Sub

Mais le fichier sort sous la forme 29 janvier 2021
Il manque le préfixe ABC pour obtenir une image nommée "ABC 29 janvier 2021.png"
Et je n'arrive pas à ajouter ce préfixe ABC sans tout déregler dans le fonctionnement
Merci de votre aide

 

[patricktoulon]

re
fichier ="ABC" & fichier & Format(Now(), "ddmmmmyyyy") & ".jpg"

 

[patricktoulon]

re
écoute voila ma version
elle fonctionne
elle te crée le dossier si il n'existe pas et te sauve l'image comme tu veux avec le nom que tu veux
et elle gére les problèmes de vélocité de mémoire dans 2016 et + (bien connu de tous)

la sub "ExportRangeInImage" peut être utilisée x fois

il faut juste changer les données dans la sub test
sans changer quoi que ce soit dans la sub "ExportRangeInImage"

Option Explicit
Sub test ()
    Dim fichier$, dossier$
    dossier = "D:\Mon Dossier"     '<--- ici le chemin du dossier où sauvegarder
    If Dir(dossier, vbDirectory) = "" Then MkDir (dossier)
    fichier = "ABC" & Format(Date, " dd mmmm yyyy") & ".jpg"
    ExportRangeInImage [Feuil1!C1:Y34], dossier & "\" & fichier
End Sub

Sub ExportRangeInImage(plage As Range, CheminX As String)
    Dim chart1 As Object, hPicAvail As Long
    Set chart1 = plage.Parent.ChartObjects.Add(0, 0, 1, 1).Chart
    With CreateObject("htmlfile").parentwindow.clipboardData.clearData("Text"): End With    'on vide le clipboard entre chaque copie pour tester vraiment le available
    With chart1
        With .Parent
            .Width = plage.Width: .Height = plage.Height: .Left = plage.Width + 20:
            plage.CopyPicture
            Do: DoEvents
                hPicAvail = ExecuteExcel4Macro("CALL(""user32"",""IsClipboardFormatAvailable"",""JJC""," & 14 & ")")    '2 pour bitmap,14 pour wmf
            Loop While hPicAvail = 0
            .Select
            .Chart.Paste
            Do: DoEvents: Loop While .Chart.Pictures.Count = 0
            .Chart.Export CheminX, "jpg"
            .Chart.Pictures(1).Delete    'on delete a chaque fois l'image collée (important si les plages capturées sont differentes en terme de dimension)
        End With
    End With
    chart1.Parent.Delete
End Sub

voila maintenant tu en fait ce que tu veux

 

[fanch55]

Bonjour Patrick, Bambi, le Forum,

Très intéressant ton code Patrick ... mais donne une image avec du blanc.
Voir fichier joint et photo résultat obtenu.
Regarde la pièce jointe 1093411

Bonne journée,
lionel

Salut à Tous,
La soluce de @patricktoulon fonctionne correctement,
il suffit de déplacer le copypicture avant le With chart1

 

[patricktoulon]

re
bonjour @fanch55
en fait effectivement je n'ai pas ce soucis avec 2013 mais avec 2016 oui

donc mettons les choses en ordre

1. on vide le clipborad(méthode perso)
2. on copypicture( donc en wmf) moins lourd en mémoire qu'avec xlscreen,xlbitmap
3. on créé le graph et on le dimensionne
4. on place le graph à droite de la plage(pour pas le capturer avec)
5. on attend que le gros fainéant de clipboard 2016 ai tout avalé
6. on colle dans le graph
7. on attend que le graph.pictures.count=1(propre au problème 2016[image complète blanche))
8. on exporte le graph
9. on supprime le graph

Option Explicit
Sub export_images()
    Dim fichier$, dossier$
    dossier = "D:\Mon Dossier"     '<--- ici le chemin du dossier où sauvegarder
    If Dir(dossier, vbDirectory) = "" Then MkDir (dossier)
    fichier = "ABC" & Format(Date, " dd mmmm yyyy") & ".jpg"
    ExportRangeInImage [Feuil1!C1:Y34], dossier & "\" & fichier
End Sub

Sub ExportRangeInImage(plage As Range, CheminX As String)
    Dim chart1 As Object, hPicAvail As Long
    With CreateObject("htmlfile").parentwindow.clipboardData.clearData("Text"): End With    'on vide le clipboard
    plage.CopyPicture
    Set chart1 = plage.Parent.ChartObjects.Add(0, 0, 0, 0).Chart
    With chart1
        With .Parent
            .Width = plage.Width: .Height = plage.Height: .Left = plage.Width + plage.cells(1).left)+10:
            Do: DoEvents
                hPicAvail = ExecuteExcel4Macro("CALL(""user32"",""IsClipboardFormatAvailable"",""JJC""," & 14 & ")")    '2 pour bitmap,14 pour wmf ' on test un handle image dans le clipboard en boucle
            Loop While hPicAvail = 0
            .Select
            .Chart.Paste
            Do: DoEvents: Loop While .Chart.Pictures.Count = 0
            .Chart.Export CheminX, "jpg"
         End With
    End With
    chart1.Parent.Delete
End Sub

avec ça il n'y aura jamais de soucis de latence
et l'api fonctionne sans déclaration sur toute version Excel pour Windows

 

[bambi]

Merci beaucoup @patricktoulon
Tu t'es donné beaucoup de mal pour me trouver une solution
Mais il n'y a rien à faire, malgré tous mes efforts, elle ne fonctionne pas chez moi

Avec tes indications, j'ai opté par une adaptation de la macro de @mapomme
Et cela fonctionne comme je le souhaite
Je vais donc passer ma demande en résolue
Merci encore pour ton aide

Sub export_images()
 Application.ScreenUpdating = False
 
Const Chemin = "D:\MonDossier"     '<--- ici le chemin du dossier où sauvegarder
Dim gr1 As Object, Source1 As Range, nom As Date, fichier$
   Application.ScreenUpdating = False
   fichier = Chemin & IIf(Right(Chemin, 1) = "\", "", "\")
   fichier = fichier & "ABC " & Format(Now(), "dd mmmm yyyy") & ".png"
   Set Source1 = Range("C1:Y34")
   Source1.CopyPicture xlScreen, xlPicture
   With Sheets(1).ChartObjects.Add(0, 0, Source1.Width, Source1.Height)
      .Activate:: .Chart.Paste: .Chart.Export fichier: .Delete
   End With
 
Application.ScreenUpdating = True
End Sub

 

[Usine à gaz]

Bonjour à toutes et à tous,

Chez moi, le code de Patrick fonctionne parfaitement (merci à toi (même s'il ne m'était pas destiné lol) ).
Le code de Mapomme fonctionne aussi (merci à toi ).

Ce qu'il me reste à faire et que je n'arrive pas à modifier :
Je souhaite que la plage pour la photo concerne les cellules actives de la feuille, ce qui me permettrait de ne pas avoir, à chaque changement, de modifier la plage dans le code.
Dans le code de Mapomme :
Set Source1 = Range("e7:h17")
Dans le code de Patrick :
ExportRangeInImage [Feuil1!e7:h17], dossier & "\" & fichier

Avec mes remerciements,
lionel,

 

[Staple1600]

Bonjour le fil

[Juste pour infos]

l'export avec un graph donc c'est Jpg" ou "Gif"

On peut exporter en PNG, non?

Sub PeNeGe_JePeux() 'ceci est juste illustratif
'nécessite d'être compléter pour par exemple
'exporter une plage de cellules en *.png
Dim strExportPath$, strFileName$
strExportPath = ThisWorkbook.Path &"\"
strFileName = "test.png"
ActiveChart.Export Filename:=strExportPath  & strFileName, FilterName:="PNG"
End Sub

 

[patricktoulon]

non Staple1600
les datas du fichier résultant sont bitmap converti en jpg avec l'export par grapf
alors oui ca marche avec .png mais si tu l'ouvre avec gimp par exemple tu constatera qu'il n'y a pas les deux calque si tant est qu'il arrive a l'ouvrir en tant que png

alors oui ,tu l'ouvre avec paint par exemple par ce que paint le reconnais comme un jpg
mais en aucun cas le fichier est un vrai png

 

[Staple1600]

Re

=>patricktoulon
Merci pour la précision
Donc le filtre d'export en PNG d'Office est tout pourri alors?