Logo GNT
Actualités Tests & Guides Bons Plans
Twitter iPhone pliant OnePlus 11 PS5 Disney+ Orange Livebox Windows 11
Entraide Applications Microsoft Office Excel Macro qui ne fonctionne plus...

Macro qui ne fonctionne plus...

13 réponses
Avatar
EricC
Bonjour =C3=A0 tous,
J'esp=C3=A8re que vous vous portez bien !

Mon soucis est que depuis le passage de Excel 2002-SP2 et Win 7 vers Office=
365 sous Win 10, ma macro ne fonctionne plus.

C'est une macro qui me permettait de cr=C3=A9er un fichier jpg =C3=A0 parti=
r d'une zone d=C3=A9finie en vue de l'exporter ensuite vers un site interne=
t.

Voici le code qui pose probl=C3=A8me

Sub Jpg_internet()
Application.ScreenUpdating =3D False

With Sheets("BILLARD") 'exportation classement.jpg
.Activate
Workbooks.Add
.Range("d48:s62").CopyPicture
With ActiveSheet
.Paste
With .ChartObjects.Add(0, 0, _
Selection.Width, Selection.Height).Chart
.Paste
.ChartArea.Border.LineStyle =3D 0
End With
With .ChartObjects(1)
.Top =3D 0
.Left =3D 0
.Chart.Export "D:\Docs Eric\classement.jpg", "JPG"
End With
End With
End With
Application.DisplayAlerts =3D False
ActiveSheet.Delete
ActiveWorkbook.Close
Application.DisplayAlerts =3D True
Sheets("BILLARD").Activate

End Sub

Le message d'erreur appara=C3=AEt =C3=A0 la ligne
.Chart.Export "D:\Docs Eric\classement.jpg", "JPG"

Avez-vous une id=C3=A9e ?

Merci de votre aide
Eric
Signaler un problème avec ce contenu

10 réponses

Supprimer
Cette action est irreversible, confirmez la suppression du commentaire ?
Signaler le commentaire

Veuillez sélectionner un problème

Nudité
Violence
Harcèlement
Fraude
Vente illégale
Discours haineux
Terrorisme
Autre
1 2
Avatar
Brat'ac
Il se trouve que EricC a formulé :
[HS]
Billard !!!! Quel club ?
Avatar
MichD
Bonjour,
Essaie ceci :
'------------------------------------------------
Sub Image_Range_Vers_Un_Fichier()
Dim objChart As Chart, Sh As Worksheet
Dim Fichier As String
'chemin du répertoire et nom du fichier image
Fichier = "D:Docs Ericclassement.jpg"
With Worksheets("BILLARD")
.Range("d48:s62").CopyPicture xlScreen, xlPicture
End With
Set Sh = Worksheets.Add
With Sh
.Shapes.AddChart
.Activate
.Shapes.Item(1).Select
Set objChart = ActiveChart
With objChart
.Paste
.Export Fichier
End With
Application.DisplayAlerts = False
.Delete
Application.DisplayAlerts = False
End With
End Sub
'------------------------------------------------
MichD
Avatar
MichD
Le 02/05/20 à 15:14, Brat'ac a écrit :
Il se trouve que EricC a formulé :
[HS]
Billard !!!! Quel club ?

C'est l'information qui te manquait pour lui suggérer une solution?
;-))
MichD
Avatar
EricC
Bonjour,
Merci MichD pour ta réponse rapide.
Cela fonctionne très bien.
Bon week end et au plaisir
Eric
Avatar
MichD
Le 03/05/20 à 10:17, EricC a écrit :
Re Bonjour MichD,
J'ai été un peu vite pour dire que c'était ok...
Le code fonctionne très bien, mais j'obtiens des images jpg qui sont toutes de la même taille, cad 1201 x 721, même si les zones sélectionnées sont différentes.
N'y a-t-il pas moyen de garder les proportions hauteur x largeur de la zone copiée ?
Merci
Eric

Tu as fait un double-clic sur l'image du fichier créé?
Au besoin, voici la macro modifiée.
'------------------------------------------------
Sub Image_Range_Vers_Un_Fichier()
Dim objChart As Chart, Sh As Worksheet
Dim Fichier As String, Rg As Range
'chemin du répertoire et nom du fichier image
Fichier = "D:Docs Ericclassement.jpg"
With Worksheets("BILLARD")
Set Rg = .Range("d48:s62")
Rg.CopyPicture xlScreen, xlPicture
End With
Set Sh = Worksheets.Add
With Sh
.Shapes.AddChart
.Activate
With .Shapes.Item(1)
.Left = Sh.Range("A1").Left
.Top = Sh.Range("A1").Top
.Width = Rg.Width
.Height = Rg.Height
.Select
End With
Set objChart = ActiveChart
With objChart
.Paste
.Export Fichier
End With
Application.DisplayAlerts = False
.Delete
Application.DisplayAlerts = False
End With
End Sub
'------------------------------------------------
MichD
Avatar
EricC
J'ai fait un double clic sur l'image, mais rien n'y fait, ca n'a rien chang é, toutes les images sont à 1201 x 721.
J'ai ensuite adapté la macro comme tu l'as suggéré et mainte nant les images sont toutes avec une hauteur de 722, mais leur largeur chan ge d'une image à l'autre.
J'ai 1843x722, 1619x722, 3130x722, 588x722, etc...
On a progressé !
Mais le rapport LxH n'est pas conservé, c'est toujours illisible.
Merci de me suivre
Eric
Avatar
MichD
Bonjour,
Je joins un fichier compressé .zip contenant le fichier Excel utilisé et
2 images (à l'aide de l'outil "Capture d'écran") de 2 plages de cellules
ayant un nombre différent de lignes. Le résultat est concluant, je ne
sais pas ce que je pourrais faire pour l'améliorer!
https://www.cjoint.com/c/JEekKJMd5Mj
MichD
Avatar
MichD
Les 2 fichiers .jpg créés par l'exécution de la macro.
https://www.cjoint.com/c/JEekZiJ06uj
MichD
Avatar
EricC
Bonjour MichD,
Voici ce que ça donne chez moi, j'ai extrait une autre zone de la feui lle excel, l'image originale fait H 1225 x L 619
Voici le lien
https://www.cjoint.com/c/JEepJqhW3gB
Après exécution de la macro, j'obtiens une image jpg de H 722 x L 1370
Voici le lien
https://www.cjoint.com/c/JEepKnnoVTB
Ce sont les proportions qui ne sont pas gardées.
Bonne soirée
Eric
Avatar
MichD
Bonjour,
Je travaille avec Windows et Excel 2016. Les fichiers .jpg sont ouverts
sur mon ordinateur avec l'application "Photo" de Microsoft. Utilises-tu
le même type d'environnement?
J'ai apporté 2 petites modifications à la procédure. Il est difficile
d'effectuer un test pour corriger un défaut que la macro ne génère pas
lors de son exécution dans mon environnement.
Je suis à court de suggestions!
'------------------------------------------------
Sub Image_Range_Vers_Un_Fichier()
Dim objChart As Chart, Sh As Worksheet
Dim Fichier As String, Rg As Range
'chemin du répertoire et nom du fichier image
Fichier = "D:Docs Ericclassement.jpg"
With Worksheets("BILLARD")
Set Rg = .Range("d48:s62")
Rg.CopyPicture xlScreen, xlBitmap 'Modifier
End With
Set Sh = Worksheets.Add
With Sh
.Shapes.AddChart
.Activate
With .Shapes.Item(1)
.Left = Sh.Range("A1").Left
.Top = Sh.Range("A1").Top
.Width = Rg.Width
.Height = Rg.Height
.LockAspectRatio = False 'Or msoTrue , Teste!
.Select
End With
Set objChart = ActiveChart
With objChart
.Paste
.Export Fichier
End With
Application.DisplayAlerts = False
.Delete
Application.DisplayAlerts = False
End With
End Sub
'------------------------------------------------
MichD
1 2