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

 

[Fredox]

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

Bonjour Eriiic,
Votre solution est exactement ce que je souhaitais, un grand MERCI.

 

[Fredox]

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
Regarde la pièce jointe 1131370

voilà

Merci Patrick,
Compliqué pour moi, je créé une nouvelle feuille à chaque fois, je ne sais comment ajouter le code dans chaque nouvelles feuilles.

Mais je vais prendre le temps de regarder le code qui contient de belles choses.

Merci beaucoup