Autres Agrandir puis réduire des images

[nigoexcel]

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]

Bonjour nigo excel, patricktoulon, soan,

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

2) Exécuter la macro Memoriser :

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 :

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]

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

 

[job75]

Suite de mon post #16.

On peut évidemment regrouper les opérations 1) 2) 3) en une seule en exécutant la macro :

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 🙄

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

 

[patricktoulon]

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
tu fait une erreur des le départ avec
For Each p In ActiveSheet.Pictures
qui liste les commandbuttons et compagnie

 

[nigoexcel]

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

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]

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:

'*****************************************************************
'*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]

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:

'*****************************************************************
'*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]

Bonjour nigoexcel,

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

soan

 

[patricktoulon]

bonsoir
non tu dois pas installer de bouton ou quoi que ce soit
tu lance la sub init a l'open du classeur c'est tout
après simplement en cliquant sur l'image tu la réduit ou agrandi
c'est tout

 

[nigoexcel]

#patricktoulon c'est au top merci

Ce lien n'existe plus à changer les coef d'agrandir et réduire

Champagne (virtuel 🙂 )