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

eriiic à dit:

Bonjour,

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

VB:

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

eric

Cliquez pour agrandir...

patricktoulon à dit:

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

voilà

Cliquez pour agrandir...