Export image avec une certaine taille en pixels
Bonjour,
Je viens faire appel à votre aide pour l'export d'images sur excel.
J'ai une macro qui me permet d'exporter des pictogrammes en JPG. Cela marche parfaitement, toutefois j'aimerais que la photo enregistrée soit un carré parfait de 1000 pixels par 1000 pixels.
J'ai beau modifier la taille, choisir une taille dans ma macro, la photo ne fait jamais 1000x1000 ...
Voici le code et le fichier (simplifié) :
Sub test()
Dim picto As Range, cell1 As Range, cell2 As Range
Dim cht As ChartObject
Dim ActiveShape As Shape
Dim Graph As Chart
Dim co As Byte, qty As Byte
Dim path As String
path = ThisWorkbook.path
co = 1
Set cell1 = Sheets("pictogrammes").[A1]
'Quantity of pictos:
qty = 4
Do While co <= qty
Set cell2 = cell1.Offset(1)
Set picto = Range(cell1.Address & ":" & cell2.Address)
picto.Copy
ActiveSheet.Pictures.Paste(link:=False).Select
Set ActiveShape = ActiveSheet.Shapes(ActiveWindow.Selection.Name)
'Create a temporary chart object (same size as shape)
Set cht = ActiveSheet.ChartObjects.Add( _
Left:=ActiveCell.Left, _
Width:=ActiveShape.Width, _
Top:=ActiveCell.Top, _
Height:=ActiveShape.Height)
'2398.08153
'Format temporary chart to have a transparent background
ActiveWindow.DisplayGridlines = False
cht.Chart.ChartArea.Format.Line.Visible = msoFalse
'Copy/Paste Shape inside temporary chart
ActiveShape.Copy
cht.Activate
ActiveChart.Paste
'Save chart to User's Desktop as PNG File
cht.Chart.Export path & "\picto n°" & co & ".jpg"
'Delete temporary Chart
cht.Delete
ActiveShape.Delete
co = co + 1
Set cell1 = cell1.Offset(, 1)
Loop
End Sub
Et voici le fichier : https://wetransfer.com/downloads/967ac32001621516c374c4c0e68e91ff20220801154847/414b7e
Merci d'avance et bonne journée !
2 réponses
-
Contributeur
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
-
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).
-
Contributeur
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 SubVoilà
@+Le Pivert
-
