Icône de la ressource

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

une autre facon pour la methode direct sur image
la ligne de calcul RATIO est de @Dudu2
VB:
Private Sub CommandButton1_Click()
    'PlaceTheShapeInCenterRange [c4:d8], Shapes("toto"), 5    '5%
    PlaceTheShapeInCenterRange [c4], Shapes("toto"), 5    '5%
End Sub

Private Sub CommandButton2_Click()
    'PlaceTheShapeInCenterRange [c11:d24], Shapes("toto"), 5    '5%
    PlaceTheShapeInCenterRange [c11], Shapes("toto"), 5    '5%
End Sub

Sub PlaceTheShapeInCenterRange(rng As Range, shap, Optional marge As Long = 0)     'la marge exprime un pourcentage de 1 à x%
    Dim Ratio#
    Ratio = Application.Min(rng.Cells(1).MergeArea.Width / shap.Width, rng.Cells(1).MergeArea.Height / shap.Height)
    With shap
        .Width = .Width * (Ratio - ((Ratio / 100) * marge))
        .Height = .Height * (Ratio - ((Ratio / 100) * marge))
        .Top = rng.Top + ((rng.Cells(1).MergeArea.Height - .Height) / 2)
        .Left = rng.Left + ((rng.Cells(1).MergeArea.Width - .Width) / 2)
    End With
End Sub

Pièces jointes

  • demo6.gif
    demo6.gif
    208.9 KB · Affichages: 76
  • J'aime
Réactions: JohDan
voici une autre écriture pour la methode directe
VB:
Sub place_l_image_dans(Rng As Range, Shp As Picture)
    Dim x&
    With Shp
        .ShapeRange.LockAspectRatio = msoTrue    ' met  l'aspect Ratio a true
        x = (Rng.Width / Rng.Height) < (.Width / .Height)'comparaison des ratios
        'en fonction de x et en redimensionnant le width ou le height l'autre se redimensionne automatiquement
        If x Then .Width = Rng.Width Else .Height = Rng.Height
        .Left = Rng.Left    '+ ((Rng.Width - .Width) / 2)'débloquer si l'image doit etre au centre horizontalement
        .Top = Rng.Top    '+ ((Rng.Height - .Height) / 2)'débloquer si l'image doit etre au centre verticalement
        .Placement = 1
    End With
End Sub
  • J'aime
Réactions: JohDan