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 7903 Date d'inscription jeudi 13 septembre 2007 Statut Contributeur Dernière intervention 11 mars 2024 - 2 août 2022 à 15:06

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 !

A voir également:

Export image avec une certaine taille en pixels
Comment réduire la taille d'un fichier - Guide
Image iso - Guide
Comment reduire la taille d'une image - Guide
Comment agrandir une image - Guide
Roissy piac export - Forum Consommation & Internet

2 réponses

Réponse 1 / 2

cs_Le Pivert Messages postés 7903 Date d'inscription jeudi 13 septembre 2007 Statut Contributeur Dernière intervention 11 mars 2024 728
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

Réponse 2 / 2

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

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 7903 Date d'inscription jeudi 13 septembre 2007 Statut Contributeur Dernière intervention 11 mars 2024 728
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

Discussions similaires

Retrouver l'image originale après avoir fait des modifications ?

À quoi correspond 32x32 US en taille française pour un jean ?

Résolution d'une image 500 pixels largeur

W32 L32: correspondance entre taille US et taille française

problème de pixel

Discussions similaires

Newsletters