Discussion :

[goninph]

Bonjour,

Sur une feuille excel, j'aimerai remplacer une image existante par une autre image de la galerie via VBA.

Je n'arrive pas à trouver le code qui reproduit la selection de la photo existante nommée par exemple => Image_Meteo, puis bouton droite de la souris => Changer d'image à partir du fichier.

Merci pour votre aide
Philippe

J'ai adapté ce code, mais il ne correpond pas du tout à ce que je veux.

Impossible de renommer l'image pour la supprimer lors de la mise à jour.
Positionnement et dimensionnement de l'image pouvant déborder de la cellule.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
Private Sub CommandButton2_Click()
    Dim ws As Worksheet
    Dim imagePath As String
    Dim imgLeft As Double
    Dim imgTop As Double
    Dim nom As String
    nom = Environ("USERPROFILE")
    ActiveSheet.Shapes.Range(Array("Image_Meteo")).Select
 
On Error GoTo Fichier_manquant
        Set ws = ActiveSheet
        Range("Cell_PV_Meteo").Select
        imagePath = nom & "\Pictures\Météo.png"
            imgTop = ActiveCell.Top + 2  'Position dans la cellule coin supérieur gauche
            imgLeft = ActiveCell.Left + 10 'Position dans la cellule coin supérieur gauche
                ws.Shapes.AddPicture _
                    Filename:=imagePath, _
                    LinkToFile:=msoFalse, _
                    SaveWithDocument:=msoTrue, _
                    Left:=imgLeft, _
                    Top:=imgTop, _
                    Width:=450, _
                    Height:=120
 
    Exit Sub
Fichier_manquant:
    MsgBox "L'image Météo.png n'existe dans le dossier : " & vbCrLf & "blalba", vbInformation, "! Oups ! Action interrompue"
End Sub

[ARTURO83]

Bonjour,

Fichier en exemple à adapter (mettez votre chemin à la ligne : Chemin = "mettre ici le chemin" & "\"), Cliquez (gauche) sur le graphique pour obtenir le changement d'image.
Pièce jointe 497315

le code:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
Sub Changement_Image()
    Dim ws As Worksheet
    Dim imagePath As String
    Dim imgLeft As Double
    Dim imgTop As Double
    Dim Chemin As String
    Chemin = "mettre ici le chemin" & "\"
    'Boucle pour supprimer l'ancienne image
    For Each ShapeObj In ActiveSheet.Shapes
        If ShapeObj.Name = "Image_old" Then ActiveSheet.Shapes("Image_old").Delete
    Next ShapeObj
 
    'Recherche d'une nouvelle image
    Image = Application.GetOpenFilename("All Files ,*.*", , "Sélectionnez une image")
    New_Image = Dir(Image)
 
    'Positionnement de la nouvelle image
    Set ws = ActiveSheet
    Range("Cell_PV_Meteo").Select
    imagePath = Chemin & New_Image
    imgTop = ActiveCell.Top + 2
    imgLeft = ActiveCell.Left + 10
    Feuil1.Shapes.AddPicture(imagePath, msoFalse, msoCTrue, imgLeft, imgTop, 450, 120).Select
 
    'renommage de l'image
    Selection.Name = "Image_old"
    'Lui affecter la macro
    Selection.OnAction = "Changement_Image"
    [A1].Select
End Sub

Cdlt

[goninph]

Merci, je ne peux pas tester de suite et j'ai une question : mon fichier contient plusieurs images et je veux remplacer l'image_meteo, car dans le même fichier avec une deuxième macro adaptée je devrais remplacer une autre image avancement du chantier.

Les premières images sont déjà dans le fichier avec des noms respectifs :

Image_meteo
Image_avancement

Dans un troisième temps je devrais également pouvoir insérer dans la cellule active une photo prise sur le chantier et stockée dans mon dossier image.

En résumé, j'ai 3 types de macro à concevoir :

Macro météo
Pour la météo remplacer image existante par une image stockée dans le presse papier vu que c'est une copie d'écran d'un site météo.

Macro avancement
Pour l'avancement du chantier remplacer image existante par une photo prise la journée stockée dans le dossier photos.

Macro situation
Pour signaler un détail ou une situation rencontrée sur le chantier, une photo doit pouvoir être insérée dans la cellule active à partir du dossier photos.

Merci d'avance pour votre aide
Philippe

[goninph]

Bonjour ARTURO83,

Un grand merci pour l'aide apportée et génial le clic sur image pour la remplacer.

J'ai 2 remarques sur le code adapté ci-dessous :

- Ne serait il pas possible de ne pas spécifier l'emplacement du fichier image pour que je puisse sélectionner une image dans n'importe quel dossier du PC ?

- Lorsque l'on clic sur annuler de la boite de dialogue de l'explorateur, l'image est supprimée et il y a une erreur que j'ai géré en indiquant qu'il faut aller dans le menu du PV pour pouvoir relancer la macro.

Meilleures salutations
Philippe

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
Option Explicit
Sub Remplacer_Image_avancement()
Dim ws As Worksheet
Dim imagePath As String
Dim imgLeft As Double
Dim imgTop As Double
Dim Chemin As String
Dim nom As String
Dim ShapeObj As Object
Dim Image As String
Dim New_Image As String
    nom = Environ("USERPROFILE")
    Chemin = nom & "\Pictures\"
 
On Error GoTo Clic_sur_Annuler
    'Boucle pour supprimer l'ancienne image
        For Each ShapeObj In ActiveSheet.Shapes
            If ShapeObj.Name = "Image_Avancement" Then ActiveSheet.Shapes("Image_Avancement").Delete
        Next ShapeObj
    'Recherche d'une nouvelle image
        Image = Application.GetOpenFilename("All Files ,*.*", , "Sélectionnez une image")
        New_Image = Dir(Image)
    'Positionnement de la nouvelle image
        Set ws = ActiveSheet
        Range("Cell_PV_Image_Avancement").Select
        imagePath = Chemin & New_Image
        imgTop = ActiveCell.Top + 20    'Position de l'image coin supérieur gauche de la cellule
        imgLeft = ActiveCell.Left + 8   'Position de l'image coin supérieur gauche de la cellule
        Feuil1.Shapes.AddPicture(imagePath, msoFalse, msoCTrue, imgLeft, imgTop, 480, 254).Select 'dimensions de l'image
    'renommage de l'image
        Selection.Name = "Image_Avancement"
    'Lui affecter la macro
        Selection.OnAction = "Remplacer_Image_avancement"
        [Cell_PV_Image_Avancement].Select
Exit Sub
Clic_sur_Annuler:
    MsgBox "Ouvrir le MENU et cliquer sur le bouton Maj avancement.", vbExclamation, "! Oups ! Action interrompue"
End Sub

[ARTURO83]

Voici avec les modifications demandées.

le code

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
Option Explicit
 
Sub Remplacer_Image_avancement()
    Dim ws As Worksheet
    Dim imgLeft As Double, imgTop As Double
    Dim Chemin As String, Image As String, New_Image As String, imagePath As String
    Dim ShapeObj As Object
    Dim Nb As Long, NbAs As Long, i As Long
 
    On Error GoTo Clic_sur_Annuler
    'Boucle pour supprimer l'ancienne image
    For Each ShapeObj In ActiveSheet.Shapes
        If ShapeObj.Name = "Image_Avancement" Then ActiveSheet.Shapes("Image_Avancement").Delete
    Next ShapeObj
 
    'Recherche d'une nouvelle image
Recherche_Image:
    Image = Application.GetOpenFilename("All Files ,*.*", , "Sélectionnez une image")
    If Image = "Faux" Then
        MsgBox "Vous devez choisir une image"
        GoTo Recherche_Image
    End If
    New_Image = Dir(Image)
 
    'Isoler le chemin complet
    NbAs = Len(Image) - Len(Replace(Image, "\", "")) 'Compter le nombre de "\" (Antislash)
    Chemin = ""
    Nb = 0
    For i = 1 To Len(Image)
        If Nb = NbAs Then Exit For
        If Mid(Image, i, 1) = "\" Then Nb = Nb + 1
        Chemin = Chemin & Mid(Image, i, 1)
    Next i
 
    'Positionnement de la nouvelle image
    Set ws = ActiveSheet
    Range("Cell_PV_Image_Avancement").Select
    imagePath = Chemin & New_Image
    imgTop = ActiveCell.Top + 20    'Position de l'image coin supérieur gauche de la cellule
    imgLeft = ActiveCell.Left + 8   'Position de l'image coin supérieur gauche de la cellule
    Feuil1.Shapes.AddPicture(imagePath, msoFalse, msoCTrue, imgLeft, imgTop, 480, 254).Select 'dimensions de l'image
    'renommage de l'image
    Selection.Name = "Image_Avancement"
    'Lui affecter la macro
    Selection.OnAction = "Remplacer_Image_avancement"
    [Cell_PV_Image_Avancement].Select
Exit Sub
 
Clic_sur_Annuler:
    MsgBox "Ouvrir le MENU et cliquer sur le bouton Maj avancement.", vbExclamation, "! Oups ! Action interrompue"
End Sub

Cdlt

[goninph]

Bonjour ARTURO83,

Ce code répond pleinement à mes attentes

Encore milles merci
Philippe

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
Option Explicit
Sub Remplacer_Image_avancement()
    Dim Emplacement As Range
    Dim Img As Object
    Dim ShapeObj As Shape
'Ouvrir l'explorateur de fichier
    If Application.Dialogs(xlDialogInsertPicture).Show Then
    Set Emplacement = Range("Cell_PV_Image_Avancement") 'Définit l'emplacement de l'image
    Set Img = ActiveSheet.DrawingObjects(ActiveSheet.Shapes.Count)
'Boucle pour supprimer l'ancienne image
    For Each ShapeObj In ActiveSheet.Shapes
        If ShapeObj.Name = "Image_Avancement" Then ActiveSheet.Shapes("Image_Avancement").Delete
    Next ShapeObj
    With Img.ShapeRange
        .Name = "Image_Avancement"          'Renommer l'image pour pouvoir la supprimer
        .LockAspectRatio = msoFalse
        .Top = Emplacement.Top + 20         'Si pas de chiffre = l'image sera aux mêmes dimensions que la cellule
        .Left = Emplacement.Left + 8        'Si pas de chiffre = l'image sera aux mêmes dimensions que la cellule
        .Width = Emplacement.Width + 210    'Si pas de chiffre = l'image sera aux mêmes dimensions que la cellule
        .Height = Emplacement.Height + 118  'Si pas de chiffre = l'image sera aux mêmes dimensions que la cellule
    End With
    'Affecter la macro à l'image
        Selection.OnAction = "Remplacer_Image_avancement"
        [Cell_PV_Image_Avancement].Select
    Else
        MsgBox _
            "L'image n'a pas été remplacée", vbInformation, "! Oups ! Action interrompue"
    End If
End Sub

Bonjour ARTURO83,

Un grand merci pour l'aide apportée et génial le clic sur image pour la remplacer.

J'ai 2 remarques sur le code adapté ci-dessous :

- Ne serait il pas possible de ne pas spécifier l'emplacement du fichier image pour que je puisse sélectionner une image dans n'importe quel dossier du PC ?

- Lorsque l'on clic sur annuler de la boite de dialogue de l'explorateur, l'image est supprimée et il y a une erreur que j'ai géré en indiquant qu'il faut aller dans le menu du PV pour pouvoir relancer la macro.

Meilleures salutations
Philippe

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
Option Explicit
Sub Remplacer_Image_avancement()
Dim ws As Worksheet
Dim imagePath As String
Dim imgLeft As Double
Dim imgTop As Double
Dim Chemin As String
Dim nom As String
Dim ShapeObj As Object
Dim Image As String
Dim New_Image As String
    nom = Environ("USERPROFILE")
    Chemin = nom & "\Pictures\"
 
On Error GoTo Clic_sur_Annuler
    'Boucle pour supprimer l'ancienne image
        For Each ShapeObj In ActiveSheet.Shapes
            If ShapeObj.Name = "Image_Avancement" Then ActiveSheet.Shapes("Image_Avancement").Delete
        Next ShapeObj
    'Recherche d'une nouvelle image
        Image = Application.GetOpenFilename("All Files ,*.*", , "Sélectionnez une image")
        New_Image = Dir(Image)
    'Positionnement de la nouvelle image
        Set ws = ActiveSheet
        Range("Cell_PV_Image_Avancement").Select
        imagePath = Chemin & New_Image
        imgTop = ActiveCell.Top + 20    'Position de l'image coin supérieur gauche de la cellule
        imgLeft = ActiveCell.Left + 8   'Position de l'image coin supérieur gauche de la cellule
        Feuil1.Shapes.AddPicture(imagePath, msoFalse, msoCTrue, imgLeft, imgTop, 480, 254).Select 'dimensions de l'image
    'renommage de l'image
        Selection.Name = "Image_Avancement"
    'Lui affecter la macro
        Selection.OnAction = "Remplacer_Image_avancement"
        [Cell_PV_Image_Avancement].Select
Exit Sub
Clic_sur_Annuler:
    MsgBox "Ouvrir le MENU et cliquer sur le bouton Maj avancement.", vbExclamation, "! Oups ! Action interrompue"
End Sub

[goninph]

Hello,

Grâce au forum je progresse, voici une nouvelle macro qui beug avec la commande " .Placement = xlMoveAndSize ".

Quelqu'un c'est pourquoi ?

Le but est de cacher les images lorsque les filtres sont activés.

Merci et meilleures salutations.
Philippe

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
Sub Inserer_photo_travaux()
    Dim Position As Range
    Dim Img As Object
    Dim ShapeObj As Shape
    Dim Image As Object
'Supprimer la photo existante
        For Each Image In ActiveSheet.Shapes
            If Not Intersect(Image.TopLeftCell, ActiveCell) Is Nothing Then Image.Delete
        Next Image
'Attacher la nouvelle photo
    If Application.Dialogs(xlDialogInsertPicture).Show Then     'Ouvrir l'explorateur de fichier
    Set Position = ActiveCell                                'Définit l'emplacement de l'image
    Set Img = ActiveSheet.DrawingObjects(ActiveSheet.Shapes.Count)
 
    With ActiveCell
        .RowHeight = 190
    End With
    With Img.ShapeRange
        .LockAspectRatio = msoTrue          'Conserver le ratio de la photo
        .Width = 252                        'Largeur de l'image
        .Top = Position.Top + 30         'Si pas de chiffre = l'image sera aux mêmes dimensions que la cellule
        .Left = Position.Left + 8        'Si pas de chiffre = l'image sera aux mêmes dimensions que la cellule
        .Placement = xlMoveAndSize          'Déplacer et dimensionner avec les cellules
    End With
        'IMPORTANT Ne pas sélectionner une autre cellule
    Else
        MsgBox _
            "L'image n'a pas été remplacée.", vbInformation, "! Oups ! Action interrompue"
    End If
End Sub

[ARTURO83]

Bonjour,

Coimme ceci

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
Sub Inserer_photo_travaux()
    Dim Position As Range
    Dim Img As Object
    Dim ShapeObj As Shape
    Dim Image As Object
    'Supprimer la photo existante
    For Each Image In ActiveSheet.Shapes
        If Not Intersect(Image.TopLeftCell, ActiveCell) Is Nothing Then Image.Delete
    Next Image
    'Attacher la nouvelle photo
    If Application.Dialogs(xlDialogInsertPicture).Show Then     'Ouvrir l'explorateur de fichier
        Set Position = ActiveCell                                'Définit l'emplacement de l'image
        Set Img = ActiveSheet.DrawingObjects(ActiveSheet.Shapes.Count)
        ActiveCell.RowHeight = 190
        With Img.ShapeRange
            .LockAspectRatio = msoTrue          'Conserver le ratio de la photo
            .Width = 252                        'Largeur de l'image
            .Top = Position.Top + 30         'Si pas de chiffre = l'image sera aux mêmes dimensions que la cellule
            .Left = Position.Left + 8        'Si pas de chiffre = l'image sera aux mêmes dimensions que la cellule
        End With
        Img.Placement = xlMoveAndSize          'Déplacer et dimensionner avec les cellules
        'IMPORTANT Ne pas sélectionner une autre cellule
        Else
        MsgBox "L'image n'a pas été remplacée.", vbInformation, "! Oups ! Action interrompue"
    End If
End Sub

Cdlt

[goninph]

Hello,

Excellent mille merci

Dans l'exemple ci-dessous je réduis la largeur de l'image à 252 pour qu'elle corresponde à la largeur de la cellule.

Est il possible de connaitre la hauteur de l'image une fois sa largeur réduite pour ensuite déterminer la hauteur de la cellule ?

Bonne journée
Philippe

[clementmarcotte]

Bonjour,

As-tu vraiment besoin de mettre toutes tes photos dans ta feuille calcul ? Avec tous les risques de devoir tout reprogrammer l'affichage des photos si tu modifies ta feuille de calcul.

Parce que tu pourrais regarder du côté d'un (ou à la limite, quelques uns) contrôle Image dans un UserForm ou même directement sur ta feuille. Et si tu mets un (des) contrôles Image dans ta feuille, tu peux le déplacer à volonté.

[goninph]

Oui, car c'est un pv de chantier pour le suivi d'une construction.

Question : comment réduire le poids des images au minimum

[patricktoulon]

Bonjour
ajuster une image a une range et reduire le poids

ce sujet a été abordé tres récemment

voici deux petit exemple qui place la même image dans trois plage de forme et dimension différente en réduisant le poids de l'image

voici le premier en profitant de LockAspectRatio donc en agissant directement sur une des deux démentions de l'image

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
 
Option Explicit
Sub test()
    Dim Pict As Picture, Fichier
    Fichier = Application.GetOpenFilename(FileFilter:=" Image File ( *.jpg;*.png;*gif;*.wmf;*.bmp), ( *.jpg*.png;*gif;*.wmf;*.bmp), images Files, *.*", FilterIndex:=1)
    If Fichier = False Then Exit Sub    'si on annule dans la boite de dialogue
    Fichier = imageminime(Fichier)
    Set Pict = Sheets(1).Pictures.Insert(Fichier)    'on insert l'image tel quel
    Pict.Name = "img1"    'je nome l'image (facultatif )mais ca peut servir pour (l'identifier/la retrouver) plus tard
    place_l_image_dans Range("B3:D6"), Pict, 5    'appel de la sub de placement et redimentionnement au niveau de la plage en 1er parametre
 
     Set Pict = Sheets(1).Pictures.Insert(Fichier)    'on insert l'image tel quel
    Pict.Name = "img2"    'je nome l'image (facultatif )mais ca peut servir pour (l'identifier/la retrouver) plus tard
    place_l_image_dans Range("f3:g14"), Pict, 5    'appel de la sub de placement et redimentionnement au niveau de la plage en 1er parametre
 
 
     Set Pict = Sheets(1).Pictures.Insert(Fichier)    'on insert l'image tel quel
    Pict.Name = "img3"    'je nome l'image (facultatif )mais ca peut servir pour (l'identifier/la retrouver) plus tard
    place_l_image_dans Range("C14:C15"), Pict, 5    'appel de la sub de placement et redimentionnement au niveau de la plage en 1er parametre
 
 
    Kill ThisWorkbook.Path & "\imgtemp.jpg"
End Sub
'sub de placement et centrage de l'image  dans la range en parametre tout en respectant son  ratio
Sub place_l_image_dans(Rng As Range, Shp As Picture, Optional space = 0)
    Dim ratio#, W#, H#
    With Shp
        .ShapeRange.LockAspectRatio = msoTrue    ' lock leratio indéformable
        ratio = .Width / .Height     ' calcul ratio
        W = Rng.Width       ' width  range
        H = Rng.Height      ' height range
        If (W / H < ratio) Then
            .Width = W - space    'en redimentionant le width le height se redimentionne automatiquement
        Else    'ou
            .Height = H - (space / ratio)    'en redimentionant le height le width se redimentionne automatiquement
        End If
        .Left = Rng.Left + ((Rng.Width - .Width) / 2)
        .Top = Rng.Top + ((Rng.Height - .Height) / 2)
        .Placement = 1
    End With
End Sub

le deuxieme exemple les dimention et position sont calculer sans toucher a l'image

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
Option Explicit
Sub test2()
    Dim Pict As Picture, Fichier As Variant, dp
    Fichier = Application.GetOpenFilename(FileFilter:=" Image File ( *.jpg;*.png;*gif;*.wmf;*.bmp), ( *.jpg;*.png;*gif;*.wmf;*.bmp), images Files, *.*", FilterIndex:=1)
    If Fichier = False Then Exit Sub    'si on annule dans la boite de dialogue
    Fichier = imageminime(Fichier)
    Set Pict = Sheets(2).Pictures.Insert(Fichier)    'on insert l'image tel quel
     dp = Dimention_position(Range("A3:D8"), Pict, 4)
    With Pict
        .Name = "img1"    'je nome l'image (facultatif )mais ca peut servir pour (l'identifier/la retrouver) plus tard
        .ShapeRange.LockAspectRatio = msoTrue    ' lock leratio indéformable
        .Top = dp(2): .Left = dp(3): .Width = dp(0): .Height = dp(1)
        '.Placement = 1
    End With
 
    Set Pict = Sheets(2).Pictures.Insert(Fichier)    'on insert l'image tel quel
     dp = Dimention_position(Range("F3:H28"), Pict, 4)
    With Pict
        .Name = "img1"    'je nome l'image (facultatif )mais ca peut servir pour (l'identifier/la retrouver) plus tard
        .ShapeRange.LockAspectRatio = msoTrue    ' lock leratio indéformable
        .Top = dp(2): .Left = dp(3): .Width = dp(0): .Height = dp(1)
        '.Placement = 1
    End With
 
 
    Set Pict = Sheets(2).Pictures.Insert(Fichier)    'on insert l'image tel quel
     dp = Dimention_position(Range("J8:K10"), Pict, 4)
    With Pict
        .Name = "img1"    'je nome l'image (facultatif )mais ca peut servir pour (l'identifier/la retrouver) plus tard
        .ShapeRange.LockAspectRatio = msoTrue    ' lock leratio indéformable
        .Top = dp(2): .Left = dp(3): .Width = dp(0): .Height = dp(1)
        '.Placement = 1
    End With
 
    'Kill fichier
End Sub
'
Function Dimention_position(Rng, Pict As Picture, Optional space As Double = 0)
    Dim Wr&, Hr&, W&, H&, L&, T&, Sp1&, Sp2&, ratio&
    With Pict
        ratio = .Width / .Height     ' calcul ratio
        Wr = Rng.Width: Hr = Rng.Height      ' width  range' height range
        If (Wr / Hr < ratio) Then
            '.Width = wr - space
            W = Wr - space: H = .Height / (.Width / (Wr - (space / ratio)))
        Else
            '.Height = Hr - (space / ratio)
            H = Hr - (space / ratio): W = .Width / ((.Height / (Hr - space)))
        End If
        L = Rng.Left + ((Wr - W) / 2): T = Rng.Top + ((Hr - H) / 2)
    End With
    Dimention_position = Array(W, H, T, L - Sp1)
End Function

et enfin la fonction de réduction (utilisation de la librairie Wiaut:WIA)

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
Function imageminime(chemin)
    Dim Img, Ip As Object, Ip2 As Object, W As Long
    Set Img = CreateObject("WIA.ImageFile")    'Création conteneur pour l'image à manipuler
    Set Ip = CreateObject("WIA.ImageProcess")
    Set Ip2 = CreateObject("WIA.ImageProcess")
    Img.LoadFile (chemin)
     W = Img.Width / 6 'exemple :1024/6 donne environ 171'modifier ici le 6 selon la tolérance que vous souhaitez 
    'redimensionne l'image
    Ip.Filters.Add (Ip.FilterInfos("Scale").FilterID)
    Ip.Filters(1).Properties("MaximumWidth") = W 'tu peux reduire ici
    Ip.Filters(1).Properties("MaximumHeight") = W 'tu peux reduire ici
    Set Img = Ip.Apply(Img)
 
    'reduit la qualité a 80%
    Ip2.Filters.Add (Ip.FilterInfos("Convert").FilterID)
    Ip2.Filters(1).Properties("FormatID").Value = "{B96B3CAE-0728-11D3-9D7B-0000F81EF32E}"
    Ip2.Filters(1).Properties("Quality").Value = 80 ' ce nombre represente le pourcentage de qualité donc ici 80% tu peux encore reduire  mais attention a la déperdition des couleurs
    Set Img = Ip2.Apply(Img)
    'Enregistre l'image redimensionnée
    If Dir(ThisWorkbook.Path & "\imgtemp.jpg") <> "" Then Kill ThisWorkbook.Path & "\imgtemp.jpg"
    Img.SaveFile ThisWorkbook.Path & "\imgtemp.jpg"
    imageminime = ThisWorkbook.Path & "\imgtemp.jpg"
End Function

testé sur 2007 et 2013 32 bits
j'arrive a avoir un poids par exemple avec une image de 300kilo a 30kilo

voila
je fournirais un fichier exemple si tu veux