'*****************************************************************
'*centrer une image dans un range en gardant les proportions
'fonctionne en calculant avant d'y toucher en respectant les proportions
'auteur patricktoulon
'version 1.3
'date :17/06/2016
'******************************************************************
'******************************************************************
Option Explicit
'
Function Dimention_position(rng, Pict As Shape, 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 / 2): H = .Height / (.Width / (Wr - (space / ratio)))
Else
'.Height = Hr - (space / ratio)
H = Hr - (space / ratio): W = .Width / ((.Height / (Hr - (space / 2))))
End If
L = rng.Left + ((Wr - W) / 2): T = rng.Top + ((Hr - H) / 2)
End With
Dimention_position = Array(W, H, T, L)
End Function
Sub init()
Dim shap, f As Worksheet
For Each f In Worksheets
For Each shap In f.Shapes
If shap.Type = 13 Then
shap.Name = "_" & shap.TopLeftCell.Address(0, 0)
shap.OnAction = "shoWX"
End If
Next
Next
End Sub
Sub showx()
Dim N$, rng As Range, T
With ActiveSheet
N = Application.Caller
Set rng = .Range(Replace(N, "_", ""))
If .Shapes(N).TopLeftCell.Address(0, 0) <> rng.Address(0, 0) Then
T = Dimention_position(rng, .Shapes(N), 2)
Else
With ActiveWindow: Set rng = .VisibleRange.Resize(.VisibleRange.Rows.Count, 7): End With
T = Dimention_position(rng, .Shapes(N), 20)
End If
With .Shapes(N)
.Width = T(0)
.Height = T(1)
.Top = T(2)
.Left = T(3)
End With
End With
End Sub