Export image avec une certaine taille en pixels
cs_Le Pivert Messages postés 8437 Statut Contributeur -
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 !
- Visualisez cette image avec un logiciel d'édition d'images. combien y a-t-il de pixels noirs sur le camion ? votre réponse nombre de pixels noirs :
- Combien y a-t-il de bateaux dans la zone de 475 pixels de large et 1000 pixels de haut à partir du coin supérieur gauche de cette image ? - Guide
- Logiciel de sauvegarde gratuit - Guide
- Frédéric cherche à faire le buzz sur les réseaux sociaux. il a ajouté une image de manchots sur une image de plage. retrouvez l'image originale de la plage. que cachent les manchots ? - Forum Graphisme
- Logiciel - Guide
- Money logiciel - Télécharger - Comptabilité & Facturation
2 réponses
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).
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
