XL 2019 Syntaxe .Pictures.Insert

[PoloTaz67]

Bonsoir,
De guerre lasse je me tourne vers vous pour résoudre une énigme sur laquelle je butte depuis 3 heures
J'ai recopié et adapté un code pour mes besoins pour afficher une image dans un pseudo formulaire
Je m'explique
Le "formulaire" n'en est pas un juste une adaptation graphique
Dans le grand carré "Image", je veux par rapport à un code (art-00002) afficher l'image qui correspond et dont le lien apparait en A1
Le pb c'est que la syntaxe "With .Pictures.Insert("ImageLien") obtenu par " ImageLien = Range("A1") " n'est pas correcte et me donne l'erreur suivante.
"Erreur d'exécution '1004' Impossible de lire la propriété Insert dans la classe Picture"

J'ai essayé avec une recherche plus simple sur une autre feuille et en fermant le fichier contenant "Formulaire", cela fonctionne..... A n'y rien comprendre
Pouvez vous m'aider
Merci

 

[Staple1600]

Bonsoir

PoloTaz67
Les images sont destinées aux albums de Tatie Paulette.
Nous, on veut du "couillu"
Du fichier Excel, avec du code VBA dedans!
Donc hop, supprime tes jolies photos et fais péter l'*xlsm, palsambleu!

 

[PoloTaz67]

Hop voila en direct live de Papy Pol le Xlsm

 

[PoloTaz67]

oups manque des trucs, je modifie

 

[PoloTaz67]

Voila avec tous les onglets

 

[Staple1600]

Re,

Et le code VBA, il est où?

 

[PoloTaz67]

Sorry, trop pressé d'envoyer

 

[Staple1600]

Re

Trop pressé d'écrire du VBA aussi, peut-être, non ?
With .Pictures.Insert(ImaheLien)
Ce serait plutôt ceci qu'on devrait lire, non ?
With .Pictures.Insert(ImageLien)

 

[PoloTaz67]

Trop pressé peut être de le recopier, surement aussi.
Mais cela ne change rien au pb le debogeur donne la même erreur que sur l'image de Tatie Paulette (ref PictureInsert) 1° envoi

 

[PoloTaz67]

 

[Staple1600]

Re

Chez moi, cela fonctionne
Mais sans doute parce que j'ai supprimé le End Sub (qui est en doublon)
En tout cas, c'est le cas dans le dernier fichier exemple.

Donc une fois, ces corrections effectuées, test OK chez moi

 

[PoloTaz67]

J'ai trouvé...
Dans le dernier paquet, ce n'était pas
Range("F4").Left
Range("F4").Top
mais G4
Merci quand même
Bonne soirée

 

[Staple1600]

Re

Moi, cela fonctionne aussi comme ceci
(Mais chez moi, en A1, le chemin pointe vers une image qui existe sur mon disque dur)
Est-ce le cas chez toi ?
Ci-dessous ton code modifié à ma sauce (et qui fonctionne pour ce qui concerne l'insertion de l'image)

Sub AffiheImage()
Dim Imagelien As String, P As Range, f As Worksheet
Set f = Sheets("Formulaire")
With f
Set P = .Range("G4:I18")
    On Error Resume Next
        .Shapes("MonImage").Delete
    On Error GoTo 0
    Imagelien = .Range("A1")
    If Imagelien = Empty Then
        Exit Sub
    End If
    With .Pictures.Insert(Imagelien)
      With .ShapeRange
      .LockAspectRatio = msoTrue: .Height = P.Height - 1: .Name = "MonImage"
      End With
    End With
    With .Shapes("MonImage")
      .Left = f.[G4].Left: .Top = f.[G4].Top
      .IncrementLeft (P.Width - .Width) / 2: .IncrementLeft (P.Height - .Height) / 2
    End With
End With
End Sub

NB: Je n'ai fait qu'un toilettage qui réduit un peu ton code
(en utilisant deux variables supplémentaires: f as Worksheet et P as Range
Je n'ai pas touché au reste de ton code
(sauf G4 à la place de F4)

 

[patricktoulon]

re
bonsoir
le code du demandeur ne prend pas en compte la différence de ratio(range de réception/image)
il es donc erroné même après la correction syntaxique et esthétique par Staple1600
avant de donner ma solution je tiens à dire que le forum est équipé d'un moteur de recherche
la solution qui suit a été donné par moi même moult fois très récemment
il serait pratique de s'en servir
donc
j’extériorise la chose en dehors de la sub dans une autre sub (macro recyclable )
le test empty sur A1 n'est pas suffisant en cas de lien erroné en A1
un test dir fait office de Contrôle général de validité du lien
le nom du sheets parent de la plage est implicite dans la sub opérante
en effet dans la sub appelant "afficheimage" on est dans un blok with/end with et le "." devant " range" indique que la feuille est l'object du block
si la sub opérante devait être utilisée sans blok et sans parent alors "rng.parent"dans celle ci serait la feuille active

donc voici la solution complète que je propose

Option Explicit
Sub AffiheImage()
    With Sheets("Formulaire")
        On Error Resume Next
        .Shapes("MonImage").Delete
        On Error GoTo 0
        If Dir(.Range("A1").text) <> "" Then place_l_image_dans .Range("G4:I18"), .Range("A1").Text
    End With
End Sub
'
'
Sub place_l_image_dans(rng As Range, chemin As String,Optional nom As String = "Monimage")
    Dim Ratio#, W#, H#
    With rng.Parent.Pictures.Insert(chemin)
        .Name =nom
        .ShapeRange.LockAspectRatio = msoTrue    ' lock leratio indéformable
        Ratio = .Width / .Height     ' calcul ratio de l' image
        W = rng.Width       ' width  range
        H = rng.Height      ' height range
        '--------------------------------------------------------------------------------------------
        '((((((on a bloqué l'aspect ratio on ne redimensionnera qu'un axe  le width ou le height!!!))))
        '--------------------------------------------------------------------------------------------
        If (W / H < Ratio) Then    'si ratio (rng) < que ratio image alors
            .Width = W - 2    'width image=width rng
        Else'sinon
            .Height = H - (2 / Ratio)    ' height image =height rng
        End If
        .Left = rng.Left + ((rng.Width - .Width) / 2)    'on centre horizontalement
        .Top = rng.Top + ((rng.Height - .Height) / 2)    ' on centre verticalement
        .Placement = 1
    End With
End Sub

testé et approuvé par moult membres

 

[patricktoulon]

re
voila ça c'est fait je l'ai mis dans les ressources

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

en attente d'approbation de la modération