Export en jpeg d'un groupe de Shape via VBA

[lolostaps]

Bonjour à tous,

j'ai créé un fichier avec macro me permettant d'exporter un groupe de shapes de ma feuille excel en jpeg vers un dossier particulier.
Celui-ci fonctionnait sans pb avec les versions d'excel précédente mais j'ai besoin de réutiliser celui-ci et la j'ai un bug
Ma macro fonctionne bien sauf au lieu de me reproduire une image correspondant à mon groupement de shapes, cela me renvoie un carré blanc!
Pour info je suis sur Office 365.

Voici mon Code et Merci par avance :

Sub CréationPoinçon()
'
ActiveSheet.Unprotect "Vincent"

' Définition des variables de la feuille Créationpoinçons pour cette macro:
Dim Lieu$, Balise&, Répertoire$, Répertoire2$, Balise2$, Onglet$, s As Shape, x
Dim Col&, Lig&, Fichier$, ImageExiste As Boolean

Onglet = ActiveWorkbook.ActiveSheet.Name

Sheets(Onglet).Select
Lieu = [G7]
Balise = [G8]
Balise2 = [H8]
Répertoire = ThisWorkbook.Path & "\" & Lieu & "\"
Répertoire2 = Répertoire & "Balises" & "\"


'Vérification si les répertoires existent sinon on les créés
test_repertoire (Répertoire)
test_repertoire (Répertoire2)


'Détermination du nom du fichier
Fichier = "Balise N°" & Balise & ".jpg"

'Détermination du chemin du fichier avec son nom
ChemFichier = Répertoire2 & Fichier

' Verfication que l'image n'existe pas
If Dir(ChemFichier) <> "" Then
ImageExiste = "1"
Else
ImageExiste = "0"
End If



'**** Partie permettant de créer l'image en JPG dans le répertoire ****

' Demande de validation de copie
Sup = MsgBox("Veuillez confirmer 'OUI' => Enregistre le poinçon, pensez à vérifier son numéro et le lieu de pratique", vbCritical + vbYesNo + 256, "Attention")
If Sup = vbNo Then
Exit Sub
ElseIf Sup = vbYes Then
End If

' Cas du poinçon deja existant
If ImageExiste = "1" Then
Sup = MsgBox("Le poinçon est déjà existant Veuillez confirmer 'OUI' => Enregistre ce nouveau poinçon", vbCritical + vbYesNo + 256, "Attention")
If Sup = vbNo Then
Exit Sub
ElseIf Sup = vbYes Then
End If
End If

' I) Gestion des Shapes


ActiveSheet.Unprotect "Vincent"
'Attribution de l'objet à s
Set s = ActiveSheet.Shapes("Groupe Poinçon")

'Copie l'image
s.CopyPicture

'Colle l'objet avec les dimensions d'origine (voir plus bas pour suppression de cette image)
ActiveSheet.ChartObjects.Add(0, 0, s.Width, s.Height).Chart.Paste
'Exporte l'image avec le chemin et le nom
ActiveSheet.ChartObjects(1).Chart.Export Filename:=ChemFichier
'Supprime l'objet créé plus haut, en testant tous les objets, avec 2007 qq problèmes d'image
For Each x In ActiveSheet.Shapes
If x.Type = 3 And (Left(x.Name, 5) = "Chart" Or Left(x.Name, 5) = "Graph") Then x.Delete
Next x

' Liberation de la mémoire de la plage
Set s = Nothing

' II) Confirmation de l'enregistrement de l'image

' Message de confirmation de la réalisation de la copie
Msg = "La Balise N°" & Balise & " a bien été créée"
Title = "Création de la Balise affectée à " & Lieu
Style = vbOKOnly + vbInformation
Reponse = MsgBox(Msg, Style, Title)

'
ActiveSheet.Protect "Vincent"


End Sub

 

[Lionel2]

Bonjour, vous avez trouvez une Solution, car j 'ai le meme probleme

 

[patricktoulon]

Bonsoir
probleme bien connu avec les version superieures à 2007
il s'agit simplement de latence de memoire
il est donc important de gérer la latence de memoire
plusieurs astuce tu trouvera dans les discusions similaire
la plus simple accessible niveau débutant c'est un do loop avec un paste dans le chart tant que le chart .picture.count <1
apres il y a les apis qui sont plus precise donc plus rapide mais c'est plus compliqué a gérer