Macro compression images

Bonjour,

je cherche une macro permettant de compresser l'intégralité des images de mon fichier Excel.

Voici ce que j'ai pu trouver :

Sub CompressPictures()

Dim wsh As Worksheet

Set wsh = Worksheets("Project")
wsh.Activate
wsh.Shapes(1).Select

SendKeys "%w", True
SendKeys "~", True
Application.CommandBars.ExecuteMso "PicturesCompress"
End Sub

Après plusieurs essais je n'arrive pas à la faire fonctionner, pourtant lorsque je lance la macro une fenêtre s'ouvre je sélectionne les propriétés que je souhaite, je clique sur OK, mais aucune images n'est compressés :

Avez-vous des idées ?

Cordialement

re

Bonjour

ben déjà ce que tu peux faire

c'est si tes images en vrai sont plus grandes en réalité dans le fichier

faire un copypicture /suppression de l'image original/ paste

Bonsoir Azerty41,

Pour cela créé un dossier (nommé par exemple Resize) ou tu pourras envoyer toutes les images de ton fichier Excel.

Télécharge PowerToys version 0.75 ou plus, qui regroupe un ensemble d'utilitaires dont notamment Image Resizer. Totalement intégré à Windows et à son menu fichier.

Ce dernier offre plusieurs formats de compression dont un personnalisé qui permet de compresser n'importe quelle image ou groupe d'images d'un seul clic.

Soit un gain de réduction jusqu'à 4 fois le "poids" de l'image. Il réalise un double compressé de tes images. Donc tu peux garder l'image original.

Bonjour à tous merci pour vos réponses,

concernant la taille de mes images elles font la même taille en réalité et dans le fichier.

X Cellus, Mon fichier est un fichier collaboratif que beaucoup de personnes vont utiliser, je ne souhaite pas ajouter d'outils supplémentaires.

Avez-vous d'autres idées ou solutions à mon problème ?

Bonsoir Azerty41,

Il suffit qu'une seule personne possède cet Add-on. Soit la personne qui a pour but de réduire les images. C'est bien ce qu' indique le mon dans ta phrase.

compresser l'intégralité des images de mon fichier Excel

Une fois celles-ci réduites et intégrées au fichier elles le restent sur ce fichier Excel tant qu'on ne supprime pas celle-ci.

Maintenant tu as coché Impression, essaie de cocher Site Web/Ecran.

bonjour ou bonsoir comme tu veux

quand tu excecute un mso control d'une fentre elle prend le focus et elle est modal

donc tout ce qui suit l'ouverture de la fenêtre ne peux être exécuté avant le fermeture de celle ci

tout tes sendkeys tu peux attendre l'an 10000 avant que ca se fasse

donc il va te falloir astucer et executer ce code en addressof

donc api oblige

si tu me dis que tu peux utiliser les api windows classiques je peux faire un essai, sinon je ne me casse pas la tête

un petit essai

je passe directe par la compression pas pas le menu

lance GO

regarde la fenêtre

je l'ai rallenti avec des sleep pour que tu vois

ensuite va dans vba et debloque les sendkeys de finalisation

Option Explicit
#If VBA7 Then
    Private Declare PtrSafe Function SetTimer Lib "user32.dll" (ByVal hwnd As LongPtr, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As Long
    Private Declare PtrSafe Function KillTimer Lib "user32.dll" (ByVal hwnd As LongPtr, ByVal nIDEvent As Long) As Long
    Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#Else
    Private Declare Function SetTimer Lib "user32.dll" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As Long
    Private Declare Function KillTimer Lib "user32.dll" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
    Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If
Dim TimerID&
Sub Go()
    TimerID = SetTimer(0, 0, 100, AddressOf CompressImages)
End Sub

Sub CompressImages()
    Static x As Long
    Dim C As CommandBarControl
    If x = 0 Then
        x = 1
        For Each C In Application.CommandBars("Picture").Controls
            If C.ID = 6382 Then C.Execute
        Next         ' Application.SendKeys "{DOWN}{TAB}{UP}{ENTER}{ENTER}", True
    Else
           x = 0: KillTimer 0, TimerID
       With CreateObject("wscript.shell")
            .SendKeys "{TAB}"
            Sleep 10
            .SendKeys "{UP}"
            Sleep 500
           .SendKeys "{TAB}"
            Sleep 500
           .SendKeys "{TAB}"
            Sleep 500
            .SendKeys "{TAB}"

            'finalisation
            '.SendKeys "{ENTER}"
          ' Sleep 1000
           ' .SendKeys "{ENTER}"

            End With
          End If

    End Sub

voila maintenant quand a savoir si c'est efficace ma fois

en tout cas ca marche les sendkeys sont bien executé fenêtre affichée

@+

patricktoulon