centrer une image dans un range en toute circonstances quel que soit le ratio (range/image) 1.0

'*****************************************************************
'*centrer une image dans un range en gardant les proportions
'fonction en déplaçant et redimensionnant l'image directement
'auteur patricktoulon
'version 1.0
'date :17/06/2016
'******************************************************************
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

'*****************************************************************
'*centrer une image dans un range en gardant les proportions
'fonction en calculant avant d'y toucher en respectant les proportions
'auteur patricktoulon
'version 1.0
'date :17/06/2016
'******************************************************************
'new!!!
'fonction pour alleger le poids de limage
'date:22/06/2016
'auteur patricktoulon
'******************************************************************



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
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
    '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 10%
    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