Icône de la ressource

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

bonjour a tous
voici deux méthode avec exemple pour centrer une image sur un range

la méthode que j'appelle directe
en effet j'agit directement sur l'image en bloquant l'apect ratio


VB:
'*****************************************************************
'*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

et la méthode indirecte
qui fait exactement la même chose sauf que je n'agit pas sur l'image directement
les calculs se font par vba
en effet selon le besoins on peut avoir a calculer le résultat final avant d'appliquer
j'ajoute a celle ci la réduction du poids du bitmap (utilisation de la librairie wiault"WIA"
je précise que j'utilise la librairie en late binding(déclaration tardive)
il n'y a donc pas de références a activer (normalement wia est dispo nativement sur les pc depuis W7

VB:
'*****************************************************************
'*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
Auteur
patricktoulon
Version
1.0

Dernières mises à jour

  1. autre methode de calul ration

    une autre facon pour la methode direct sur image la ligne de calcul RATIO est de @Dudu2 Private...
  2. autre ecriture pour la méthode directe

    voici une autre écriture pour la methode directe Sub place_l_image_dans(Rng As Range, Shp As...

Derniers avis

Super ! ça fait des jours que je galère sur une problématique du même style. Ta macro m'a bien aidé merci ! :)