Compression d'images en boucle

Bonjour a tous

j'ai actuellement mis au point un code qui devrait diminuer la taille de mes fichiers en compressant au minimum les images, sauvegarde du fichier et on passe au fichier suivant dans un répertoire.

Problème : la macro se lance et effectue bien la commande qui devrait réduire les images mais à la fin le fichier ne diminue pas de taille. De plus en suivant le Pas à Pas détaillé, ce n'est pas la même fenêtre de réduction d'image que si je le fait manuellement. En opposition la réduction manuel marche, image par image et réduit bien la taille finale du fichier.

Et bizarrement lorsque je fais l’enregistreur de macro pendant la procédure manuel (Mise en forme ==> compresser les images) , celui ci reste vide.

De plus par définition je ne peux pas joindre de fichier test, trop gros.

Sub ouvrir_tous_compression()
Dim dossier As Object, fichier As Object
Set dossier = CreateObject("Scripting.FileSystemObject").GetFolder(ThisWorkbook.Path)
For Each fichier In dossier.Files
    If fichier.Name <> ThisWorkbook.Name Then
        Workbooks.Open (fichier)
        'etc

        ActiveSheet.Pictures.Select
        Set octl = Application.CommandBars.FindControl(ID:=6382)
        Application.SendKeys "%(oe){TAB}{UP}"
        Application.CommandBars.ExecuteMso "PicturesCompress"
        octl.Execute

        For Each w In Application.Workbooks
            w.Save
        Next w
        Application.Quit
    End If
Next fichier

End Sub

Mes suppositions sont les suivantes :

• la commandbars 6382 n'est pas la bonne
• excel fait un dinstingo entre les différents type d'image dans excel ce qui empêche la bonne marche de la macro

Evolution du problème, rectification du code et j'avance !

Maintenant le code demande a l'utilisateur de sélectionner un répertoire qui contient des xls, les ouvres les uns après les autres, sélectionne toutes les images et les compresses.

Sub Chaine_compr_img_XLS2010_2016()
Dim repertoire As FileDialog
Dim fichier As Object
Dim dossier As Object
Dim xDirect$, xFname$
Dim wbk As New Workbook

With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = Application.DefaultFilePath & "\"
        .Title = "Choisissez un repertoire contenant les fichiers xls avec des images a réduire"
        .Show

       If .SelectedItems.Count <> 0 Then
            xDirect$ = .SelectedItems(1) & "\"
            xFname$ = Dir(xDirect$, 7)
            Do While xFname$ <> ""

                Application.DisplayAlerts = False
                Set wbk = Workbooks.Open(Filename:=xDirect$ & xFname$)
                ActiveSheet.Pictures.Select
                Application.SendKeys "%jc{TAB}{TAB}{DOWN}~"
                Application.CommandBars.ExecuteMso "PicturesCompress"
                wbk.Save
                wbk.Close

                Application.DisplayAlerts = True
                xFname$ = Dir
            Loop
        End If

    End With
MsgBox ("Fichiers compressés.")

End Sub

Problème:

le code ne sélectionne pas les images, ni de l'onglet actif ni des autres onglets.

Du coup, je joins le fichier qui contient le code et qui pèse beaucoup moins lourd.

Bon j'ai trouvé tout seul.

La solution était que lorsque la version d'excel change, les raccourcis changent également.

Du coup 2 versions, une pour excel 2010 et une pour 2016, avec en plus une réduction du zoom mais ça c'est une demande.

Donc les codes suivants permettent de sélectionner un répertoire, d'ouvrir chaque fichier excel qu'il y a dedans et de réduire au minimum le poids des images qu'il contient Encore un ou deux fichiers dans le tas reste très lourd sans raisons (pour l'instant) mais c'est déjà un énorme.

Sub Chaine_compr_img_XLS2010()
Dim repertoire As FileDialog
Dim fichier As Object
Dim dossier As Object
Dim xDirect$, xFname$
Dim wbk As New Workbook

With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = Application.DefaultFilePath & "\"
        .Title = "Choisissez un repertoire contenant les fichiers xls avec des images a réduire"
        .Show

       If .SelectedItems.Count <> 0 Then
            xDirect$ = .SelectedItems(1) & "\"
            xFname$ = Dir(xDirect$, 7)
            Do While xFname$ <> ""

                Application.DisplayAlerts = False
                Set wbk = Workbooks.Open(Filename:=xDirect$ & xFname$)
                ActiveWindow.Zoom = 70
                ActiveSheet.Shapes.SelectAll
                Application.SendKeys "%jym{TAB}{TAB}{UP}~"
                Application.CommandBars.ExecuteMso "PicturesCompress"
                wbk.Save
                wbk.Close

                Application.DisplayAlerts = True
                xFname$ = Dir
            Loop
        End If

    End With
MsgBox ("Fichiers compressés.")

End Sub

Sub Chaine_compr_img_XLS2016()
Dim repertoire As FileDialog
Dim fichier As Object
Dim dossier As Object
Dim xDirect$, xFname$
Dim wbk As New Workbook

With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = Application.DefaultFilePath & "\"
        .Title = "Choisissez un repertoire contenant les fichiers xls avec des images a réduire"
        .Show

       If .SelectedItems.Count <> 0 Then
            xDirect$ = .SelectedItems(1) & "\"
            xFname$ = Dir(xDirect$, 7)
            Do While xFname$ <> ""

                Application.DisplayAlerts = False
                Set wbk = Workbooks.Open(Filename:=xDirect$ & xFname$)
                ActiveWindow.Zoom = 70
                ActiveSheet.Shapes.SelectAll
                Application.SendKeys "%jyc{TAB}{TAB}{DOWN}~"
                Application.CommandBars.ExecuteMso "PicturesCompress"
                wbk.Save
                wbk.Close

                Application.DisplayAlerts = True
                xFname$ = Dir
            Loop
        End If

    End With
MsgBox ("Fichiers compressés.")

End Sub

Merci à moi-même pour l'aide que je me suis apporté