XL 2021 coller une image interne au classeur

[Jouxte]

Bonjour à toutes et tous,

J'utilise du code du regretté Jacques Boisgontier que j'ai modifié avec du code de patricktoulon pour l'insertion dans la cellule cible. Ce code se trouve dans la Worksheet.
Il me sert à coller en colonne F l'image correspondant à l'arrondissement de la colonne E.
J'ai nommé les images des arrondissement de la feuille" Ardt" : Paris 1, Paris 2, et ainsi de suite jusqu'à 20.
J'ai une erreur sur la ligne : ActiveSheet.Paste

Cette macro a fonctionné pour les 6 ou 7 premières lignes.

Par ailleurs, est-il possible de créer une fonction [=CollerImage(Nom de l'image)] qui irait chercher l'image correspondante du classeur pour la coller sur la cellule contenant la formule.

J'ai fait un fichier test avec seulement 4 arrondissements pour qu'il ne soit pas trop lourd.
Merci par avance.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim ratio#, W#, H#
If Target.Column = 5 And Target.Count = 1 Then
'-- suppression
For Each S In ActiveSheet.Shapes
If S.Type = 13 Then
If S.TopLeftCell.Address = Target.Offset(0, 1).Address Then
S.Delete
End If
End If
Next S
'--
If Target <> "" Then
Sheets("Ardt").Shapes(Target).Copy
Target.Offset(0, 1).Select
ActiveSheet.Paste

With Selection
.ShapeRange.LockAspectRatio = msoTrue ' lock leratio indéformable
ratio = .Width / .Height ' calcul ratio
W = ActiveCell.Width ' width range
H = ActiveCell.Height ' height range
If (W / H < ratio) Then
.Width = W - 2 'en redimentionant le width le height se redimentionne automatiquement
Else 'ou
.Height = H - (2 / ratio) 'en redimentionant le height le width se redimentionne automatiquement
End If
.Left = ActiveCell.Left + ((ActiveCell.Width - .Width) / 2) + 1
.Top = ActiveCell.Top + ((ActiveCell.Height - .Height) / 2)
.Placement = 1
End With

Target.Select

End If
End If
End Sub

 

[Jouxte]

c'est ce que je vais faire.

 

[Jouxte]

Bonsoir,

Ce soir le code ne fonctionne plus

J'ai fermé Excel, éteint l'ordi et ça ne fonctionne plus.

 

[patricktoulon]

re
bonsoir
tranquillement j'arrive quand on parle de moi
j'entends que l'on a bricolé mes méthodes avec celles d'un autre
malgré tout mon respect pour jacques qui fut un peu notre mentor à tous
il ne faut pas mélanger les genres
patricktoulon c'est patricktoulon

pour commencer quand on a une donnée formatée dans une cellule et que l'on se sert de cette donnée comme nom( voir autre)on utilise pas le .value(même implicitement) mais plutôt ".Text"
le ratio hoh! punaise c'est ma version préhistorique que tu a pris

allez tiens

'patricktoulon
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim s As Shape, cible As Range, Ratio
    If Target.Column = 5 And Target.Count = 1 Then
        Set cible = Target.Offset(, 1)
        '-- suppression
        If ActiveSheet.Shapes.Count > 0 Then
            For Each s In ActiveSheet.Shapes
                If s.TopLeftCell.Row = Target.Row Then s.Delete
            Next s
        End If
        '--
        If Target <> "" Then
            On Error Resume Next 'au cas ou un tape un chiffre qui ne correspond pas il n'y aura pas de shape donc erreur
            Sheets("Ardt").Shapes(Target.Text).CopyPicture

            If Err.Number > 0 Then
            Err.Clear 'donc en cas d'erreur bye bye
            MsgBox "y a pas de shapes (" & Target.Text & ")"
            Exit Sub
            end if
            With Target.Parent
                .Pictures.Paste
                Set Shap = .Shapes(Shapes.Count)
                Ratio = Application.Min(((cible.Width)) / Shap.Width, ((cible.Height)) / Shap.Height)
                With Shap
                    .LockAspectRatio = msoTrue
                    .Width = (.Width * Ratio)
                    .Top = cible.Top + (((cible.Cells(1).MergeArea.Height - 2) - .Height) / 2)
                    .Left = cible.Left + (((cible.Cells(1).MergeArea.Width - 2) - .Width) / 2)
                    .Placement = 1
                End With
            End With
        End If
    End If
End Sub

et que je t'y reprenne plus hein !!!

EDITT: j'ai fait un petit correctif

 

[Jouxte]

Re,
Merci ce code (et merci aussi pour vbcomponents manager -je sauvegarde les scripts- et les autres ressources)
J'ai une erreur

 

[patricktoulon]

re
que veux tu que je te dise
j'ai testé sur ton fichier ça fonctionne très bien

 

[Jouxte]

C'est très étrange !
Est-ce à cause de la version d'Excel ? (même après le correctif)
J'ai fait un test en mettant la ligne If s. .......Delete comme in commentaire et je n'ai pas mis de End If en comme un commentaire.
la carte s'est affichée sans prendre la dimension de la cellule. (c'est peut-être un code trop récent pour mon <Excel qui est comme son utilisateur un peu daté)

 

[patricktoulon]

ce code fonctionne de 2007 à 2021 sans problème
si tu enlève le end if c'est normal tu passe pas à l'etape de resize dans l'offset
il est nécessaire

 

[jurassic pork]

Par ailleurs, est-il possible de créer une fonction [=CollerImage(Nom de l'image)] qui irait chercher l'image correspondante du classeur pour la coller sur la cellule contenant la formule.

Hello,
il semblerait que cela ne soit pas possible d'utiliser le copier coller dans une fonction personnalisée.

Am/i calmant, J.P

 

[Jouxte]

Bonjour patricktoulon, jurassic pork, le forum,
@patricktoulon
Le fichier Paris test.xlsm fonctionne parfaitement ce matin. La macro dans mon gros fichier est toujours au refus.
Peut-être est-ce dû au fait que j'ai changé plusieurs fois le nom des images. Je vais recréer le gros fichier et réessayer.
@jurassic pork
Merci pour l'info.
Bonne journée à tous.

 

[patricktoulon]

Bonjour @Jouxte
je n'ai aucun doute quand au fait que c'est dans ton fichier et ailleurs que dans ma fonction que ça bug