Export image avec une certaine taille en pixels

farreneit Messages postés 282 Date d'inscription Statut Membre Dernière intervention -
cs_Le Pivert Messages postés 7904 Date d'inscription Statut Contributeur Dernière intervention - 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:

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
Money logiciel - Télécharger - Comptabilité & Facturation
Image iso - Guide
Logiciel - Guide

2 réponses

Réponse 1 / 2

cs_Le Pivert Messages postés 7904 Date d'inscription Statut Contributeur Dernière intervention 729

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 Statut Membre Dernière intervention 10

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 Statut Contributeur Dernière intervention 729

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

problème de pixel

PIX

probleme sommet

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

Dechiffrer une image caché

Votre réponse

Discussions similaires