Export image avec une certaine taille en pixels
Fermé
farreneit
Messages postés
282
Date d'inscription
jeudi 5 juillet 2012
Statut
Membre
Dernière intervention
13 janvier 2023
-
Modifié le 1 août 2022 à 17:51
cs_Le Pivert Messages postés 7904 Date d'inscription jeudi 13 septembre 2007 Statut Contributeur Dernière intervention 14 août 2024 - 2 août 2022 à 15:06
cs_Le Pivert Messages postés 7904 Date d'inscription jeudi 13 septembre 2007 Statut Contributeur Dernière intervention 14 août 2024 - 2 août 2022 à 15:06
A voir également:
- Export image avec une certaine taille en pixels
- Comment réduire la taille d'un fichier - Guide
- Reduire taille image - Guide
- Image iso - Guide
- Supprimez les composantes rouge et verte de cette image. quel mot apparaît ? - Forum Word
- Légender une image - Guide
2 réponses
cs_Le Pivert
Messages postés
7904
Date d'inscription
jeudi 13 septembre 2007
Statut
Contributeur
Dernière intervention
14 août 2024
729
1 août 2022 à 19:08
1 août 2022 à 19:08
Bonjour,
un exemple à adapter:
Sub redimensionner() Set oSheet = ThisWorkbook.Worksheets(1) Set oShape = oSheet.Shapes("Image 2") 'a adapter oShape.Width = "1000" oShape.Height = "1000" oShape.LockAspectRatio = msoFalse End Sub Sub dimension() MsgBox ActiveSheet.Shapes("Image 2").Width & "x" & ActiveSheet.Shapes("Image 2").Height End Sub
farreneit
Messages postés
282
Date d'inscription
jeudi 5 juillet 2012
Statut
Membre
Dernière intervention
13 janvier 2023
10
Modifié le 1 août 2022 à 19:45
Modifié le 1 août 2022 à 19:45
Bonjour,
Merci pour la réponse !
Cela redimensionne effectivement la photo, mais lorsque je fais ensuite clique droit, enregistrer l'image, le fichier enregistré fait plus que 1000x1000 (photo jointe).
cs_Le Pivert
Messages postés
7904
Date d'inscription
jeudi 13 septembre 2007
Statut
Contributeur
Dernière intervention
14 août 2024
729
2 août 2022 à 15:06
2 août 2022 à 15:06
Essaie ceci:
Sub save() Application.ScreenUpdating = False For i = 1 To 4 ExportImage ("Image " & i) Next i Application.ScreenUpdating = True retablir MsgBox "Terminer" End Sub Sub ExportImage(ByVal image As String) répertoire = ThisWorkbook.path Set f = ActiveSheet nomshape = image Set img = f.Shapes(nomshape) img.Width = "1850" img.Height = "1850" img.LockAspectRatio = msoFalse img.CopyPicture xlScreen, xlBitmap With img.Parent.ChartObjects.Add(0, 0, img.Width, img.Height).Chart While .Shapes.Count = 0 DoEvents .Paste Wend .Export nomshape & ".jpg", "jpg" .Parent.Delete End With End Sub Sub retablir() Dim sh As Shape For Each sh In ActiveSheet.Shapes sh.ScaleHeight 1, msoTrue sh.ScaleWidth 1, msoTrue Next sh End Sub
Voilà
@+Le Pivert