Sub Memoriser()
Dim s As Shape
For Each s In ActiveSheet.Shapes
If s.Name Like "Image#*" Then ThisWorkbook.Names.Add "X" & s.Name, s.Width
Next
End Sub
Sub Agrandir()
Dim coef, s, x#
coef = 10 'à adapter
Set s = ActiveSheet.Shapes(Application.Caller)
s.LockAspectRatio = msoTrue 'sécurité
x = Evaluate("X" & s.Name)
s.Width = IIf(s.Width > x, x, x * coef) 'agrandit ou réduit l'image
End Sub
Sub Memoriser()
Dim p As Object, n%
For Each p In ActiveSheet.Pictures
n = n + 1
p.Name = "Image" & n
ThisWorkbook.Names.Add "X" & p.Name, p.Width
p.OnAction = "Agrandir"
Next
End Sub
re
tiens j'ai pris 5 minutes
avec une adaptation de ma fonction dimension indirecte ratio range/shape
a l'ouverture toutes les shapes sont renomées "_" et leur topleftcell.address(0,0)
et je leur affecte la même macro showx
le reste c'est simple tu clique dessus
si leur topleftcell ne correspond pas a leurs noms on les remet a leur place(l'addresse est prise dans leur nom (garde les proportion)
si elle sont a leur place agrandissement max sur le visible range mais seulement du tableau (garde ces proportions)
a chaque ajout d'une image lance la sub init et c'est tout
veille a ce que le coin haut gauche soit bien dans une cellule qui n'a pas déjà une image
quoi que je pourrais ajouter ce détail en plus dans init pour t’éviter 2 image dans la même cellule en colonne "G"
JJjfGylK2Qr-Fichier-agrandir-puis-reduire-photos-version-patricktoulon-.xlsm
Le service des pièces jointes, CJoint.com est un service de partage de fichier gratuit pour partager vos documents dans vos courriels, sur les forums ou dans vos petites annonces.www.cjoint.com
'*****************************************************************
'*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
okre
bonjour
oui tu a juste a changer ce nom dans init
cela dit si tes images ne servent pas de bouton ou autre on peu rendre la chose générique et tu n'aurais plus de soucis avec le nom de la feuille
ce qui donnerait ceci pour toutes les feuille du classeur:
VB:'***************************************************************** '*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