[Pro] Export image sur disque d'une sélection variable de range d'un tableau

Version imprimable

Bonjour,
Premier post pour moi autodidacte...

Voilà un bout de "code":
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 Valeur = Range("H2").Value Dim S As Range Set S = Sheets("Classement Championnat").Range("A1", "G" & Valeur) S.CopyPicture Appearance:=xlScreen, Format:=xlBitmap Application.ScreenUpdating = True Workbooks.Add With ActiveSheet.ChartObjects.Add(0, 0, S.Width, S.Height).Chart .Paste .Export "C:\***.png", "PNG" End With ActiveWorkbook.Close False
Alors voilà, je sèche totalement car voyez-vous en pas à pas dans le débogueur pas de soucis j'ai mon image enregistré sur le disque ...
Mais lors de l'exécution du bouton affecté à cette macro l'export copie une image vide (toujours enregistré sur le disque)

Pourquoi dieu cela fonctionne-t-il en pas à pas et pas après Grrr!
Help please.
Merci par avance !

04/04/2019, 14h02
patricktoulon

re

bonjour
je parie a 10 contre 1 que tu tourne sur 2013 ou 2016 ou plus
inspire toi de cela
https://www.developpez.net/forums/d1...-excel-2016-a/
04/04/2019, 14h09
Menhir

Juste avant ton Set S =, mets un MsgBox(ActiveWorkbook.Name) pour vérifier que c'est au bon classeur que la Sheet qui suit est liée.

Alors merci pour ces infos, utiles dans le sens où elles m'ont conforté dans le fait qu'il s’agissait bien d'un soucis de "Timing" (désolé je parle avec mes mots)
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 ... Valeur = Range("H2").Value 'Range("A1", "G" & Valeur).Select 'Selection.CopyPicture Appearance:=xlScreen, Format:=xlBitmap Dim S As Range 'MsgBox (ActiveSheet.Name) Set S = Sheets("Classement Championnat").Range("A1", "G" & Valeur) S.CopyPicture Appearance:=xlScreen, Format:=xlBitmap Application.ScreenUpdating = False Workbooks.Add With ActiveSheet.ChartObjects.Add(0, 0, S.Width, S.Height).Chart DoEvents DoEvents DoEvents DoEvents DoEvents .Paste .Export "C:\Users\Papa\Desktop\ExtractionClassementChampionnat.png", "PNG" End With ActiveWorkbook.Close False ...
le do: Until: ... ne fonctionne pas chez moi
3 constatations:
1) c'est avant le Paste qu'il y avait soucis
2) j'ai besoin de 4/5 DoEvents pour que cela passe
=> merci de me dire si possible comment simplifier ça sans rien modifier du reste du code, j'entends par là ne pas toucher à mon With ActiveSheet.ChartObjects.Add(0, 0, S.Width, S.Height).Chart.
3) si le Application.ScreenUpdating est sur False (permet d'accélérer la macro) et bien c'est KO également donc bien mettre = True.

04/04/2019, 18h33
Pasfortiche

Ceci étant quasi résolu, mon second objectif serait de récupérer (tjrs en VBA depuis le même simple bouton sur page Excel)
ce même fichier tout fraîchement exporté sur mon disque pour utiliser un hébergeur d'images tel que sur goopics.net qui n'accepte que le glisser/coller ou la recherche de l'emplacement disque et de lui demander de me créer un URL de cette image.

Le troisième objectif sera d'aller récupérer cet URL et juste me le mettre dans le presse papier (mais ça je dois et devrais y parvenir)...

Si il y a plus simple du style Excel qui créerait des URL pour stocker une image jsuis preneur mais jpense pas hein ;)

Si qq'un à un lien d'études déjà faites pour la récup d'un fichier sur "emplacement disque et glisser coller sur zone web" bah je veux bien hihi

Merci encore !!!

re
résolu c'est vite dit
tes doevents sont suffisant aujourd'hui mais demain si ton pc fait des taches en arrière plan ou sur un autre pc moins puissant pourrait même provoquer un white-screen
et ben la tu sera chocolat

je t'ai adapté une petite fonction par rapport a ma contribution

le principe comme je le dit c'est d'interroger le clipboard dans un do loop pour savoir si les data corresponde au format xlpicture
l'attente est juste ce qui faut puisqu'on sort du do:loop quand le clipboard est prêt

tu peux copier une plage ou une shapes tu a les deux

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
 
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
 
Function Copy_All_To_Fichier(obj As Variant, desti As String)
    Dim hPicAvail&, i&
    With CreateObject("htmlfile").parentwindow.clipboardData.clearData("Text"): End With    'on vide le clipboard entre chaque copie pour tester vraiment le available
    Application.ScreenUpdating = False
    obj.CopyPicture    'Appearance:=xlScreen, Format:=xlBitmap
    Do: i = i + 1: DoEvents: hPicAvail = IsClipboardFormatAvailable(14): Loop While hPicAvail = 0 Or i = 5000
   If hPicAvail = 0 Then MsgBox "le clipboard n'a pas d'image": ActiveWorkbook.Close False
        Workbooks.Add
    With ActiveSheet.ChartObjects.Add(0, 0, obj.Width, obj.Height).Chart
        .Paste:
        Do: DoEvents: Loop While .Pictures.Count = 0
         .Export desti, UCase(Mid(desti, InStrRev(desti, ".") + 1))
    End With
    ActiveWorkbook.Close False
End Function

deux subs pour la tester

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
 
Sub test_copie_Range()
    Dim valeur, s As Range, chemin$
    valeur = 10    'Range("H2").Value
    chemin = "C:\Users\polux\Desktop\ExtractionClassementChampionnat.png"
    Set s = Sheets(1).Range("A1", "G" & valeur)
    Copy_All_To_Fichier s, chemin
End Sub
'
Sub test_copie_shape()
    Dim valeur, s As Variant, chemin$
    chemin = "C:\Users\polux\Desktop\mashape.png"
    Set s = Sheets(1).Shapes("Ellipse 1")
    Copy_All_To_Fichier s, chemin
End Sub