XL 2019 [VBA] Modifier la position de l'image contenue dans la cellule active

[Fredox]

Bonjour,

Je cherche de l'aide concernant l'importation d'images (stockées sur une autre feuille) puis la centrée (vertical / horizontal).
Cette partie est maitrisée en fait, j'ai le problème si je réimporte la même image, puisque c'est le même nom.

Comment je peux faire pour que l'image traitée (dans la celulle active) plutôt que l'image nommée (qui peux exister 2, 3, 4... fois) ?
,

Sub Image()

    Application.ScreenUpdating = False

Set Sh_Index = Sheets("Index")
Set Sh_Active = ActiveSheet

colonne = ActiveCell.Column
ligne = ActiveCell.Row

If ligne < 9 Then Exit Sub

xIMAGEx = Sh_Active.Cells(1, "D").Value

Sh_Index.Shapes(xIMAGEx).Copy
ActiveSheet.Paste

With ActiveSheet.Shapes(xIMAGEx)
.Top = Cells(ligne, colonne).Top + (Cells(ligne, colonne).Height - .Height) / 2
.Left = Cells(ligne, colonne).Left + (Cells(ligne, colonne).Width - .Width) / 2
End With


ActiveCell = "img."


Fin:
    Sh_Active.Select
    Cells(ligne, colonne).Select

    Application.ScreenUpdating = True
End Sub

,


Merci

 

[sousou]

Bonjour
Sans fichier?
Il faut jouer je pense sur le nommage des images importées

 

[Fredox]

Bonjour sousou,

Merci d'avoir lu. Pas évident de partager mon fichier d'entreprise.
En fait le nommage de l'image importée me parait le plus simple a faire, je n'arrive pas à le faire.
Je me dis que nommée l'image collée par Colonne & Ligne serait le plus judicieux


Merci

 

[Fredox]

J'ajoute le fichier

Merci

 

[Fredox]

Bonjour à tous,

Personne pour une idée ???


Merci

 

[Staple1600]

Bonsoir

Des idées, il y en a eu.
Et depuis longtemps
Exemple

Changer une image à partir d'une liste de validation déroulante

Bonjour tous, et merci par avance de prendre le temps de répondre à mon petit problème. Voilà je cherche à produire un document dans lequel se trouve une liste déroulante (type validation de données, liste prise sur une autre feuille du même classeur), j'aimerai qu'en fonction du choix...

www.excel-downloads.com

(Et sans VBA)

PS: Cela me permet de rendre hommage à JB (en citant une de ses réponses)

 

[Fredox]

Bonsoir

Des idées, il y en a eu.
Et depuis longtemps
Exemple

Changer une image à partir d'une liste de validation déroulante

Bonjour tous, et merci par avance de prendre le temps de répondre à mon petit problème. Voilà je cherche à produire un document dans lequel se trouve une liste déroulante (type validation de données, liste prise sur une autre feuille du même classeur), j'aimerai qu'en fonction du choix...

www.excel-downloads.com

(Et sans VBA)

PS: Cela me permet de rendre hommage à JB (en citant une de ses réponses)

Super, Merci. Mon fichier fait déjà cela, ce n'est pas le sujet de mon post.
Bonne soirée

 

[Staple1600]

Bonsoir,

J'évoquais qu'on pouvait faire ce que tu souhaites sans passer par VBA
(ce qui facilite les choses)

J'ai ouvert ton fichier et me suis souvenu que ce genre de problématique se faisait simplement sans VBA
(=> changer une image avec une liste déroulante)

 

[Fredox]

Bonsoir,

J'évoquais qu'on pouvait faire ce que tu souhaites sans passer par VBA
(ce qui facilite les choses)

J'ai ouvert ton fichier et me suis souvenu que ce genre de problématique se faisait simplement sans VBA
(=> changer une image avec une liste déroulante

Pardon,
Effectivement je comprends le sens de ton message, mais j’ai besoin de le faire en VBA

Merci encore

 

[eriiic]

Bonjour,

et bien fait comme tu as dit, change le nom qu'ils soient uniques.
Avec par exemple

.Name = .Name & "_" & Cells(ligne, colonne).Address(0, 0)

eric

 

[patricktoulon]

Bonjour
j'ajouterais que pour redimensionner et centrer une image dans un range EN TOUTE CIRCONSTANCE
tout en gardant son ASPECT RATIO(sans déformation )
d'autres y ont pensé aussi

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

bonjour a tous voici deux méthode avec exemple pour centrer une image sur un range la méthode que j'appelle directe en effet j'agit directement sur l'image en bloquant l'apect ratio...

www.excel-downloads.com

 

[patricktoulon]

re
j'ajouterais aussi que
avez vous déjà entendu parler de "

Spoiler: surprise surprise

Application.CopyObjectsWithCells = True

 

[patricktoulon]

par contre je ne sais pas ce qui se passe avec le fichier donné en exemple
impossible de renommer les shapes en vba l’opération s'annule
et quand je le fait a la main dans le cadre en haut a gauche
ça bloque excel pendant un moment
ou
ça plante
ou
ça revient mais après un mitraillage de click dessus

 

[eriiic]

Bizarre, je n'ai pas ce dysfonctionnement (2019).
Fermer et relancer excel ?
eric

 

[patricktoulon]

re
nom c'est bon j'ai trouvé
en fait le shapes(.shapes.count me donne la liste de validation (dropdown) il faut faire -1j'avais zappé ce detail
donc voilà si on veux être précis
la shapes est renommée (son Nom + l'adress de la destination (voir debug en bas)
j'ai ajouté ma fonction magique qui place exactement au centre d'un range je réduis l'image a 80% pour le visuel vous pouvez mettre 100(ca prendra toute la cellule a condition qu'il y est le même ration sinon elle sera centrée

'*********************************************
'dans le module de la feuille
' on charge newcell en tant que range (activecell)
'Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'If Target.Row = 9 Then Set newcell = ActiveCell'uniquement si l'on est en ligne 9
'End Sub
'**********************************************
'et la macro attribuée  au bouton dans le module (A05_Photo)
Public newcell As Range
Sub Image()
    Dim tablo, X&, shap
    If Not newcell Is Nothing Then    ' si newcell est une cellule( celle qui est sensé etre selectionnée )
        Application.CopyObjectsWithCells = True    ' on parametre la copie de  cellule avec leur object
        tablo = Application.Transpose([Liste_chariots].Value)    'la liste
        X = Application.IfError(Application.Match(Feuil4.[d1].Value, tablo, 0), 0)    ' le find par match on gere l'erreur meme si on est sur car il se peut que D soit modifier au clavier
        Debug.Print "trouvé en A" & X + 1 & " donc l'image est en ""B" & X + 1 & """"    'console
        Feuil1.Cells(X + 1, 1).Offset(, 1).Copy newcell    ' un simple copy destination

        With ActiveSheet    'on renomme  + console pour controler
            Set shap = .Shapes(.Shapes.Count - 1)
            With shap
                Debug.Print "Nom avant :" & .Name
                .Name = .Name & newcell.Address(0, 0)    '& vbCrLf & .Shapes(.Shapes.Count).Name = [d1].Value
                Debug.Print "Nom apres :" & .Name
                'si on veut etre tres précis au cas ou dans index elle soit placé  a l'agachon  ou que les cellule n'est pas les memes tailles
                PlaceThePictureInCenterRange newcell, shap, 80   '80% la marge reduit forcement la taille  à vous de voir
            End With
        End With
    End If
    Set newcell = Nothing    'on decharge newcell
End Sub

Sub PlaceThePictureInCenterRange(rng As Range, Obj, Optional Percentsize As Long = 100)     'la marge exprime un pourcentage de 1 à x%
    Dim Ratio#, Wx#, Yx#
    Wx = rng.Cells(1).MergeArea.Width * (Percentsize / 100)
    Yx = rng.Cells(1).MergeArea.Height * (Percentsize / 100)
    Ratio = Application.Min(Wx / Obj.Width, Yx / Obj.Height)
    With Obj
        If TypeName(Obj) = "Shape" Then .LockAspectRatio = msoTrue Else .ShapeRange.LockAspectRatio = msoTrue
        .Width = .Width * Ratio
        .Top = rng.Top + ((rng.Cells(1).MergeArea.Height - .Height) / 2)
        .Left = rng.Left + ((rng.Cells(1).MergeArea.Width - .Width) / 2)
    End With
End Sub

démonstration

voilà