Autres Agrandir puis réduire des images

nigoexcel

XLDnaute Nouveau
Bonjour je recherche une fonction ou macro pour agrandir ou réduire des photos sur fichier Excel.

Petite précision, ce fichier me sert de rapport lors de visites. Donc j'ai plusieurs feuilles et des images que j'inclus régulièrement.

Merci d'avance
 

job75

XLDnaute Barbatruc
Bonjour nigo excel, patricktoulon, soan,

1) Nommer les images Image1 Image2... sans espace dans le nom.

2) Exécuter la macro Memoriser :
VB:
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
3) Affecter à chaque image la même macro Agrandir :
VB:
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
4) Cliquer sur l'image pour l'agrandir 10 fois ou la réduire.

Le fichier sur cjoint : https://cjoint.com/c/JJjjUdrkz8u

A+
 

patricktoulon

XLDnaute Barbatruc
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"

 

job75

XLDnaute Barbatruc
Suite de mon post #16.

On peut évidemment regrouper les opérations 1) 2) 3) en une seule en exécutant la macro :
VB:
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
Puisque patricktoulon compte les temps ça m'a pris 1 minute :rolleyes:

Fichier : https://cjoint.com/c/JJjnBpAcKxu
 

patricktoulon

XLDnaute Barbatruc
bonjour @job75 je fait sans name
pas besoin
dans le sens ou si tu reduis au dimension de la cellule(ratio cellule /image) en gardant le lockaspect ratio de l'image
(voir fonction indirecte) et que chaque nom de pictures porte l'adresse de leur cellule de base

le simple click switch (cellule de base / tableau visible range

quand l'image est réduite elle est au centre de sa cellule de base(au max possible dans sa cellule)
quand on l'agrandit elle est au centre du visible range (DU TABLEAU!!)au max possible dans le tableau
ainsi on a pas a scroller pour voir l'image complète agrandi

et pour finir
en gros je ne mémorise rien ;)

ps: j'oubliais
t
u fait une erreur des le départ avec
For Each p In ActiveSheet.Pictures
qui liste les commandbuttons et compagnie
 
Dernière édition:

nigoexcel

XLDnaute Nouveau
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"


Merci c'est top :)

Par contre si j'ai d'autres feuilles dans mon fichier. Je dois changer uniquement le nom (en gras) de la ligne "For Each shap In Sheets("HAUTES BORNES").Shapes'

J'espère que OUI sinon je gros nul ;)
 

patricktoulon

XLDnaute Barbatruc
re
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
 

nigoexcel

XLDnaute Nouveau
re
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
ok
par contre si j'ai bien compris je dois créer un bouton sur chaque en y installant cette macro ? Désolé pour la question bête :)
 

soan

XLDnaute Barbatruc
Inactif
Bonjour nigoexcel,

Tu as écrit : « Désolé pour la question bête » ; ne t'inquiètes pas pour ça :

Image.JPG


soan
 

Discussions similaires