XL 2013 Insertion image dans tableau via userform

[rapi1207]

Bonsoir,

Tout d'abord, je vous remercie tous de l'aide que vous voudrez bien m'apporter.

Dans l'onglet Articles, j'ai un bouton de commande Ajouter. Quand je clique dessus, cela m'ouvre un Userform me permettant de renseigner tout un tat de chose. En cliquant sur Ajouter image, je peux mettre une image provenant de mon disque.

Jusque là, tout va bien.

Voilà maintenant ce que je n'arrive pas à faire : j'aimerai que cette image aille automatiquement dans la cellule correspondante à sa ligne et à sa colonne (Image) dans l'onglet Articles comme toutes les autres informations renseignées. J'aimerai pouvoir faire cela sans que l'utilisation du chemin d'accès de l'image car ce fichier est amené à ne pas travailler sur le même ordinateur. De plus, il faudrait que l'image soit bien attaché à la cellule pour me permettre de faire des tris et que les images suivent à chaque fois.

J'espère avoir été assez clair et d'avance merci de votre aide.

 

[herve62]

Bonsoir
Bien Bruno !! surtout que lorsque l'on "post" ici les chances de réponses rapides et concrètes sont à 99% meilleures que sur les autres forums ... sans parti pris ( ou presque ) car testé et approuvé après 22 ANS ici ( avec l'ancien forum explosé !!)
Sinon j'ai exactement la solution suite à un développement d'une appli ..pour un membre que j'ai terminé en "particulier" : compléter des infos via un USF , choisir une image qui s'affiche dans l'USF > valider > TOUT se transfert dans la feuille excel ( avec calcul des proportions image / Cellule )
j'ai lancé ton fichier et mon usf est identique restera à adapter
Je suis actuellement encore affairé sur une finition d'appli
Sinon si intéressé me contacter en mp car cette appli est Privée et trop de temps à passer pour supprimer

 

[GALOUGALOU]

bonjour le fil, bonjour rapi1207


Une petite précision. Je ne vous impose pas ma solution, juste une petite pierre (si elle vous convient) pour vous aider à développer votre projet.
j'ai modifié légèrement votre formulaire par l'ajout de deux textbox non visibles
Le principe, l'image est affichée en récupérant le chemin, redimensionnée a la taille de la cellule.
Si vous effectuez un tri, il faudra effacer les images pour les réafficher. Pour cela deux boutons dans la feuille "Articles". Vous pouvez introduire le principe dans une macro de tri.

une fonction :

Function NomShapeCellule(adr)
  For Each s In ActiveSheet.Shapes
    If s.TopLeftCell.Address = adr.Address Then
       NomShapeCellule = s.Name
    End If
  Next s
End Function

ex de macro du module 2

Sub Affiche_Image() 'cible adresse dans cellule
Dim Ws As Worksheet                   ' Sert à manipuler plus facilement l'objet feuille
Dim Image As String                   ' Contiendra le nom de l'image
Dim Lg As Long                        ' Numéro de la dernière ligne colonne B

  Set Ws = Sheets("Articles")                                           ' Nom de la feuille

  Application.ScreenUpdating = False                                  ' Interdit le raffraîchissement d'écran
    Call Efface_Images

  With Ws
 
    For Lg = 1 To .Range("M65536").End(xlUp).Row                      ' Parcourt de toute la colonne M
  
      
    Image = .Cells(Lg, "M") ' récupère le chemin pour afficher la photo
  
       On Error Resume Next                                            ' On s'affranchit des erreurs
      With .Pictures.Insert(Image).ShapeRange                         ' On insère l'image dont le nom est en colonne B
        .LockAspectRatio = msoFalse                                  ' On peut la redimmensionner comme on veut true on garde les proportions
        .Left = Ws.Cells(Lg, "G").Left                                ' Position gauche
        .Top = Ws.Cells(Lg, "G").Top                                  ' Position Haut
        .Width = Ws.Cells(Lg, "G").Width                              ' Largeur
        .Height = Ws.Cells(Lg, "G").Height                            ' hauteur
      End With
                     'If Err.Number > 0 Then                                          ' Si une erreur (image non présente)
                    'MsgBox .Cells(Lg, "L") & vbCr & "Image inexistante"           ' On le signale
                    'End If
    Next Lg
  End With
 
  Call IdentifierImage
End Sub
Sub Efface_Images()
Dim Ws As Worksheet                   ' Sert à manipuler plus facilement l'objet feuille
Dim sh As Shape                       ' Sert à manipuler les formes (images) déjà affichées

  Set Ws = Sheets("Articles")                                           ' Nom de la feuille

  With Ws
 
    For Each sh In .Shapes                                            ' Parcourt de toute la collection formes (images)
      If Not Intersect(.Columns(7), sh.TopLeftCell) Is Nothing Then   ' si elle est dans la colonne 7
        sh.Delete                                                     ' On l'efface
      End If
    Next sh
  End With
 

End Sub
Sub IdentifierImage()
Dim DerLigne As Long
DerLigne = Sheets("Articles").Cells(65536, 3).End(xlUp).Row
    ScreenUpdating = False

 With Range("L5:L1000")
Sheets("Articles").Range("L6:L" & DerLigne).FormulaR1C1 = "=NomShapeCellule([@IMAGE])" 'poser la formule"
 
'.Value = .Value ' remplacer la formule par sa valeur
End With


  ScreenUpdating = True
End Sub

l'ajout de ligne dimensionne celle ci, si une image est sélectionnée.
cdt
galougalou

 

[patricktoulon]

Bonjour
je ne sais par quoi commencer
1° vous travaillez avec un listobject ou un range faudrait savoir!!!!!!!!!

2° et là c'est le must le nom du sheets est le meme que le nom du listobject dans "Articles"
y a pas mieux pour en perdre les pedales
PS: je bien entendu changé le nom du tableau en "TArticles"

3° et des end(xlup) et patata patati à gogo pour remplir 3 combo surtout avec des Tableaux structurés
Là je dis LOL !!!

4° ajouter une ligne sans regarder si la première est pleine c'est MOYEN

et j'en passe et des meilleur dans moins de 30 lignes de code

c'est pourtant si simple de travailler avec des TS ça simplifie tellement la vie

Pardonnez mon franc Parler

leçon du jour
un tableau structuré possède un nom unique
cette partie de la feuille et même du classeur est donc unique
on accède a cet object soit par la collection listobjectS soit par son nom en tant que range
l’accès en tant que range de part le fait que cette plage est unique ne nécessite pas de déterminer le parent ou que l'on soit dans le classeur

bref j'ai vidé le module de ton userform de tout son code
je l'ai entièrement recorder je pense que l'on y vois un peu plus clair
j'ai ajouté ma fonction perso de placement de l'image dans une range au prorata sans la déformer
le dimensionnement (rowheight) est automatique

voyons voir

allez le code maintenant

Option Explicit
'code Patricktoulon
Private Sub Add_ima_Click()
    Dim fichier As Variant
    fichier = Application.GetOpenFilename("Tous les fichiers (*.jpg),*.jpg")
    If fichier = False Then Exit Sub
    With Image_art
        .Picture = LoadPicture(fichier)
        .Tag = fichier
    End With
End Sub



Private Sub Userform_initialize()

    Combogam.List = Range("Gamme_Article").Value    ' affectation de la liste gamme d'article

    Comboimp.List = Range("Tableau3").Value    'Affectation impression à la liste impression

    Combostock.List = Range("Lumiere9").Value    'Affectation stock à la liste stock

End Sub
Private Sub Add_art_Click()
'Définition des variables
    Dim SurComm, LL As Object, Pic As Shape, R As Range

    If Me.Combogam <> "" And Me.Text_art <> "" And Me.Text_ref <> "" And Me.Combostock <> "" Then

        If Range("Tarticles").Cells(1) = "" Then    'si la premiere ligne est vide alors c'est la ligne
            Set R = Range("Tarticles").Rows(1)
        Else    'sinon on ajoute une ligne
            Set LL = Range("Tarticles").ListObject.ListRows.Add
            Set R = LL.Range
        End If
        R.EntireRow.RowHeight = 90

        SurComm = IIf(Me.Combostock = "Sur commande", Me.Combostock, Val(Me.Combostock))

        R.Value = Array(Me.Combogam, Me.Text_art, Me.Text_ref, Me.Comboimp, Me.Text_coul, "", _
                        Me.Text_taille, Me.Text_description, SurComm, "", "", Image_art.Tag)

        If Image_art.Tag = "" Then
            Sheets("Articles").Pictures.Insert (Image_art.Tag)
            With Sheets("Articles"): Set Pic = .Shapes(.Shapes.Count): End With
            PlaceThePictureInCenterRange R.Cells(6), Pic, 90    'la marge c'est de 0 a 100
        Else
            MsgBox "vous avez oublié de choisir une image": Exit Sub
        End If
        ThisWorkbook.Save
        Unload New_article
    End If
End Sub


Sub PlaceThePictureInCenterRange(rng As Range, Obj As Variant, Optional PercentMarge As Long = 100)     'la marge exprime un pourcentage de 1 à x%
'fonction perso patricktoulon
    Dim Ratio#, Wx#, Yx#
    Wx = rng.Cells(1).MergeArea.Width * (PercentMarge / 100)
    Yx = rng.Cells(1).MergeArea.Height * (PercentMarge / 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

bon je vais boire un café moi j'suis un peu fatigué là
@+

 

[patricktoulon]

Bonjour @BrunoM45
Ps: j'oubliais j'ai figé a la ligne 5 histoire d'avoir toujours le menu page d'en haut (à dispo )
c'est 3 fois rien mais ça aide

 

[patricktoulon]

re
bon je le dis car je suis un impatient là je trépigne dans mes chaussures
j'ai bien entendu comme a mon habitude laissé une coquille (grosse comme une maison la coquille)
histoire de tester si le demandeur va trouver tout seul
2 caractères a changer dans le code(juste une histoire de logique)
allez c'est à vous

 

[Phil69970]

Bonjour à tous

@patricktoulon j'ai trouvé.......

@Phil69970

 

[patricktoulon]

Bonjour @Phil69970


le test est plutôt sur le raisonnement

il faut bien commencer par quelque chose hein!!


et Bruno l'a t il trouvé ?

 

[Phil69970]

@patricktoulon

Tu veux que j'efface une partie de ma réponse. ?

 

[patricktoulon]

a ben oui ça serait bien avant qu'il soit lu par les autres
tu peux laisser le fait que tu a trouvé ça me gène absolument pas
merci pour être mon complice

 

[Phil69970]

Ok c'est fait

 

[patricktoulon]

re
toute à l'heure en refaisant le projet de ce userform je ne me suis pas attarder sur le combostock bien que ça me titillait
un simple textbox aurait suffit puisqu'un seul item dans ce combo
lors du click sur bouton ; si vide alors "sur commande" sinon la valeur

 

[GALOUGALOU]

re patrick toulon
je pense avoir trouvé pendant la sieste, en tout cas l'image est maintenant dans le classeur, et pour le plaisir, j'ai rajouté le dimensionnement dans" Image_art", histoire que ce qui est visible dans le formulaire soit identique à l'image insérée dans le classeur. Mais bon ton esprit est tortueux pour moi, il y a peut-être quelque chose qui m'a échappé !!
cdt

 

[patricktoulon]

Bonjour @GALOUGALOU
c'est bien mais j'aurais préféré que tu ne parle pas d'image et laisser les autres trouver par eux mêmes

quand au dimensionnement je pige pas tel que je l'ai donné le respect de l'aspect ratio(original) est conservé dans le controls image_Art et dans la cellule donc je ne sais pas ce que tu a fait mais si c’était pas le cas tu devais avoir un autre soucis
pour la simple et bonne raison que le controls est en mode picturesizeClip et dans la cellule avec ma fonction perso elle est conservé
d'ailleurs tu le vois bien dans ma démo animée dans le post #8

des fois je me demande a quoi ça sert que ducros se décarcasse hein !!!

 

[GALOUGALOU]

re patrick
j'ai supprimé la réponse pour laisser deviner les membres de xld
et pour ton interrogation

donc je ne sais pas ce que tu a fait

j'ai envie de dire devine, chacun son tour après tout
Mais là je quitte le forum je te donnerais la réponse ce soir !!!!!
cdt