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

Fredox

XLDnaute Occasionnel
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) ?
,

VB:
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
 

Fredox

XLDnaute Occasionnel
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
 

Staple1600

XLDnaute Barbatruc
Bonsoir

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

(Et sans VBA)

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

Fredox

XLDnaute Occasionnel
Bonsoir

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

(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

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

XLDnaute Occasionnel
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
 

patricktoulon

XLDnaute Barbatruc
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 ;)
 

patricktoulon

XLDnaute Barbatruc
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
:oops:🤔
 

patricktoulon

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

VB:
'*********************************************
'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
demo3.gif


voilà ;)
 

Discussions similaires

Réponses
8
Affichages
139

Statistiques des forums

Discussions
299 706
Messages
1 978 624
Membres
206 312
dernier inscrit
dameli70