Macro qui ne fonctionne plus...

Le
EricC
Bonjour à tous,
J'espère 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éer un fichier jpg à parti=
r d'une zone définie en vue de l'exporter ensuite vers un site interne=
t.

Voici le code qui pose problème

Sub Jpg_internet()
Application.ScreenUpdating = 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 = 0
End With
With .ChartObjects(1)
.Top = 0
.Left = 0
.Chart.Export "D:Docs Ericclassement.jpg", "JPG"
End With
End With
End With
Application.DisplayAlerts = False
ActiveSheet.Delete
ActiveWorkbook.Close
Application.DisplayAlerts = True
Sheets("BILLARD").Activate

End Sub

Le message d'erreur apparaît à la ligne
.Chart.Export "D:Docs Ericclassement.jpg", "JPG"

Avez-vous une idée ?

Merci de votre aide
Eric
Vos réponses Page 1 / 2
Trier par : date / pertinence
Brat'ac
Le #26545260
Il se trouve que EricC a formulé :
[HS]
Billard !!!! Quel club ?
MichD
Le #26545277
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
MichD
Le #26545276
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
EricC
Le #26545311
Bonjour,
Merci MichD pour ta réponse rapide.
Cela fonctionne très bien.
Bon week end et au plaisir
Eric
MichD
Le #26545339
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
EricC
Le #26545381
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
MichD
Le #26545404
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
MichD
Le #26545410
Les 2 fichiers .jpg créés par l'exécution de la macro.
https://www.cjoint.com/c/JEekZiJ06uj
MichD
EricC
Le #26545416
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
MichD
Le #26545421
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
Publicité
Poster une réponse
Anonyme