XL 2013 Insertion image dans tableau via userform

rapi1207

XLDnaute Nouveau
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.
 

Pièces jointes

  • Boutique BBLM.xlsm
    273.3 KB · Affichages: 13

herve62

XLDnaute Barbatruc
Supporter XLD
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

XLDnaute Accro
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 :
VB:
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
VB:
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
 

Pièces jointes

  • essai sur Import Progression par mois-1 .xlsm
    289.8 KB · Affichages: 12
Dernière édition:

patricktoulon

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

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"

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

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
demo7.gif


allez le code maintenant
VB:
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à
@+ ;)
 

Pièces jointes

  • Boutique BBLM Version Pat .xlsm
    278.5 KB · Affichages: 22

patricktoulon

XLDnaute Barbatruc
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
 

patricktoulon

XLDnaute Barbatruc
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

XLDnaute Accro
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

XLDnaute Barbatruc
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 !!! 🤣

1632229508086.png
 

Discussions similaires

Statistiques des forums

Discussions
311 725
Messages
2 081 949
Membres
101 851
dernier inscrit
vaiata