Macro qui ne fonctionne plus...

[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 à partir d'une zone définie en vue de l'exporter ensuite vers un site internet.

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 Eric\classement.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 Eric\classement.jpg", "JPG"

Avez-vous une idée ?

Merci de votre aide
Eric

[Brat'ac]

Il se trouve que EricC a formulé :
[HS]
Billard !!!! Quel club ?

[MichD]

Post by Brat'ac
[HS]
Billard !!!! Quel club ?

C'est l'information qui te manquait pour lui suggérer une solution?
;-))

MichD

[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 Eric\classement.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

[EricC]

Bonjour,

Merci MichD pour ta réponse rapide.
Cela fonctionne très bien.

Bon week end et au plaisir

Eric

[EricC]

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

[MichD]

Post by EricC
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 Eric\classement.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]

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 maintenant les images sont toutes avec une hauteur de 722, mais leur largeur change 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]

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]

Les 2 fichiers .jpg créés par l'exécution de la macro.
https://www.cjoint.com/c/JEekZiJ06uj

MichD

[EricC]

Bonjour MichD,

Voici ce que ça donne chez moi, j'ai extrait une autre zone de la feuille 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]

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 Eric\classement.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

[MichD]

Windows 10

Post by MichD
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 Eric\classement.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

[EricC]

Bonsoir,

Je travaille aussi avec Windows 10 et Office 365.
J'ouvre les fichiers jpg avec XnView, mais j'ai essayé avec Photo, pas de différence.
J'ai testé les modifications que tu m'as fait parvenir, avec LockAspectRatio = False et puis = msoTrue, rien n'y fait, pas de changement.

Dommage..., mais pour m'en sortir, je peux éditer les fichiers jpg et les redimensionner manuellement dans XnView pour que ce soit lisible.

Je me rends compte que tu m'as bien aidé et je te remercie d'avoir passé du temps à cela.

Si tu as encore une idée, n'hésite pas, je reste dispo :-)

Encore merci

A plus
Eric

[MichD]

Post by EricC
Bonsoir,
Je travaille aussi avec Windows 10 et Office 365.
J'ouvre les fichiers jpg avec XnView, mais j'ai essayé avec Photo, pas de différence.
J'ai testé les modifications que tu m'as fait parvenir, avec LockAspectRatio = False et puis = msoTrue, rien n'y fait, pas de changement.
Dommage..., mais pour m'en sortir, je peux éditer les fichiers jpg et les redimensionner manuellement dans XnView pour que ce soit lisible.
Je me rends compte que tu m'as bien aidé et je te remercie d'avoir passé du temps à cela.
Si tu as encore une idée, n'hésite pas, je reste dispo :-)
Encore merci
A plus
Eric

Juste pour curiosité, quel est le programme par défaut pour l'extension
.jpg sur ton ordinateur? Dans le rectangle près du bouton démarrer, type
"application par défaut pour chaque type de fichier". Moi, c'est photo.
Aucune idée si cela peut faire une différence...

MichD