XL 2016 Image Useform

Maathis

XLDnaute Nouveau
Bonjour à tous,

Alors j'ai un petit problème avec un userform de saisie de données.
Le but de mon userform est de rentrer des infos sur un produit avec son image et ensuite de ranger ses valeurs dans un tableau.
Le problème c'est que ce document va être utilisé par plusieurs personnes différents sur leurs ordinateurs donc si elle insère une photo depuis leur photos par exemple, il faut que les autres utilisateurs puissent voire l'image ensuite.
J'avais réussi à obtenir ce que je voulais mais depuis le userform (grâce à votre aide sur ce forum), l'image était insérée en fichier temporaire et donc sur un autre poste, il y avait ce message:
Capture.PNG


J'ai donc eu l'idée de:
Au moment ou on va enregistrer les informations dans la base de données, l'image soit copié, renommé et envoyé vers un dossier accessible par toute les personnes du réseau et ensuite Excel prend ce fichier la pour l'insérer dans la base de données, ainsi tout le monde peut y avoir accès.
Mais est-ce la meilleure des solutions dans mon cas ?

Actuellement avec cette solution je bloque au moment ou Excel doit prendre l'image dupliquée dans le dossier accessible par tous le monde et l'insérer dans la bonne case du tableau.
Tous d'abord je vous met mon code pour insérer une image dans le useform:
VB:
Private Sub import_photo_Click()

 On Error GoTo Pasimage
    strFileName = Application.GetOpenFilename(filefilter:="JPEG Files (*.jpg;*.jpeg;*.jfif;*.jpe),*.jpg;*.jpeg;*.jfif;*.jpe,Bitmap Files(*.bmp),*.bmp", MultiSelect:=False)

    Me.boxphoto.Picture = LoadPicture(strFileName)
    Me.boxphoto.PictureSizeMode = fmPictureSizeModeStretch
    
    Me.Repaint
        
    End If

Exit Sub
Pasimage: MsgBox "Aucune image"

End Sub

Puis Quand je clique sur le bouton enregistré voici ce qu'il se passe:

Code:
pic = strFileName
        nom = Me.txtL
        
        Name pic As "C:\Users\" & nom & ".jpg"
        
                Sheets("Base").Unprotect ""
                
                
                Me.ID = "" & ID
                
                Sheets("Base").Activate
                Range("B100000").End(xlUp).Offset(1, 0).Select
                ActiveCell = Me.ID
                ActiveCell.Offset(0, 1) = Me.txtL
                ActiveCell.Offset(0, 2) = Me.txtC
                ActiveCell.Offset(0, 3) = Me.cbA
                ActiveCell.Offset(0, 4) = Me.cbM
            
    
                
                SavePicture boxphoto.Picture, pic
                
                ActiveCell.Offset(0, 5).Select
                
                 With Selection.Parents.Picture.Insert(pic)
                
                
                         .Placement = xlFreeFloating
                        
                        .PrintObject = msoFalse
                        .ShapeRange.LockAspectRatio = msoFalse
                        .Height = boxphoto.Height - 5
                        .Width = boxphoto.Width - 5
              
                        Selection.RowHeight = boxphoto.Height
                        If Selection.Width > boxphoto.Width _
                        Then Selection.Columns.ColumnWidth = 1
                      
                         Do While Selection.Width < boxphoto.Width
                             Selection.Columns.ColumnWidth = _
                             Selection.Columns.ColumnWidth + 1
                         Loop
                    .Placement = xlMoveAndSize
                End With
                
                Sheets("Base").Protect ""
                ActiveSheet.EnableAutoFilter = True
                
                Unload Me
                Sheets("Accueil").Activate
                MsgBox "Ajouté dans la base de données"
    End If

Une erreur se produit à cette ligne :
Code:
 With Selection.Parents.Picture.Insert(strFileName)
Le message d'erreur est que la proprieté insert n'est non géré.

Merci d'avance pour vos solutions.
Mathis
 

fanch55

XLDnaute Barbatruc
Exactement, il y a en effet un espace commun dont je peux me servir et oui peut importe d'où il prélèvent la photo, elle sera dupliqué vers l'espace commun et inséré sous forme d'image ou de lien hypertexte.
Un lien hypertexte est moins lourd qu'une image certes, donc un classeur moins volumineux.
Cependant il utilise le moteur internet en tache de fond:
Quand on clique sur le lien, il se connecte au serveur ( ou disque réseau ) et lance l'application dédié aux images, donc plus on clique et plus on ouvre de fenêtres qu'il faut fermer ...
C'est un effet collatéral ...
Mais il existe un palliatif pour l'hyperlien :

Si tu veux que je t'aide, dis-moi quelle est la solution que tu retiens .
 

Maathis

XLDnaute Nouveau
Un lien hypertexte est moins lourd qu'une image certes, donc un classeur moins volumineux.
Cependant il utilise le moteur internet en tache de fond:
Quand on clique sur le lien, il se connecte au serveur ( ou disque réseau ) et lance l'application dédié aux images, donc plus on clique et plus on ouvre de fenêtres qu'il faut fermer ...
C'est un effet collatéral ...
Mais il existe un palliatif pour l'hyperlien :

Si tu veux que je t'aide, dis-moi quelle est la solution que tu retiens .
Je pense que la solution du lien reste quand même la solution la plus adapté car dans ma base la photo est secondaire donc quand on lis la ligne correspondante, on a déjà pas mal d'informations.
La meilleure des solutions serait de dupliquer l'image dans un dossier réseau (en gardant la qualité d'image d'origine si possible) et ensuite d'avoir le lien hypertexte. Mais bien sur si l'affichage de l'image au survol du lien est possible en plus, je suis preneur.

Merci pour ton aide
 

fanch55

XLDnaute Barbatruc
A tester .
On a donné le nom "Photo" à la cellule A1 .
Pour les tests :
Il faut sélectionner une cellule (vide de préférence) et cliquer sur
1607012275875.png


Le code de l'userform doit être modifié pour indiquer le chemin du disque réseau :
1607012495358.png


Par la suite, on peut préciser quelle cellule doit recevoir l'hyperlien :

1607012704681.png

Du code a été mis dans la feuille, il faudra le recopier dans la feuille finale pour que les liens fonctionnent comme prévu .

🤗 😎
 

Pièces jointes

  • Maathis-Hyperliens.xlsm
    29.2 KB · Affichages: 12

Maathis

XLDnaute Nouveau
Alors j'ai pu copier-coller le code avec certaines modifications et ça fonctionne bien 🤗🤗🤗
, mais il y a plusieurs truc que je n'arrive à modifier et pourtant ça me parait simple.

Tout d'abord la cellule qui reçoit le Me.txtL prend le nom de l'image et j'aurais aimé que ce soit l'inverse mais je ne trouve pas le code correspondant 🧐

Et avec l'image renommé, je suppose que si une image existe déjà dans ce dossier avec le même nom, Excel va donc détecter un doublon ? Dans ce cas je pourrais mettre une gestion d'erreur pour éviter les doublons.

Mais merci beaucoup pour votre aide :)
 

Maathis

XLDnaute Nouveau
Victoire j'ai réussi le programme fait exactement ce que je voulais je poste ce que j'ai fait ( avec votre aide) :
Déclaration des variables:
VB:
Option Explicit
Dim strFileName As Variant
Const CheminReso = "C:\Users\" ' Dossier Image commun du réseau

Pour insèrer la photo dans l'userform:
Code:
        On Error GoTo Pasimage
        strFileName = Application.GetOpenFilename(filefilter:="JPEG Files (*.jpg;*.jpeg;*.jfif;*.jpe),*.jpg;*.jpeg;*.jfif;*.jpe,Bitmap Files(*.bmp),*.bmp", MultiSelect:=False)
    
        If strFileName <> False Then
            ' Visualiser l'image au bonne dimension
            Me.boxphoto.Picture = LoadPicture(strFileName)
            Me.boxphoto.PictureSizeMode = fmPictureSizeModeStretch
            Me.Repaint ' rafraichir l'userform
            
        End If

Exit Sub
Pasimage: MsgBox "Aucune image sélectionnée"

Pour enregistrer l'image dans le dossier commun et la renommer:
Code:
Dim strFileReso As Variant
            strFileReso = CheminReso & Me.txtL & ".jpg"
            FileCopy strFileName, strFileReso

Pour insèrer cette image dans la cellule correspondante:
Code:
ActiveCell.Offset(0, 5).Select
        
         With Selection.Parent.Pictures.Insert(strFileReso)
        
            .Placement = xlFreeFloating
            .PrintObject = msoFalse
            .ShapeRange.LockAspectRatio = msoFalse
            .Height = boxphoto.Height - 5
            .Width = boxphoto.Width - 5
              
            Selection.RowHeight = boxphoto.Height
            If Selection.Width > boxphoto.Width _
            Then Selection.Columns.ColumnWidth = 1
                      
            Do While Selection.Width < boxphoto.Width
                Selection.Columns.ColumnWidth = _
                Selection.Columns.ColumnWidth 1
            Loop
            .Placement = xlMoveAndSize
        End With

Je suis d'accord que le code n'est pas parfait il doit y avoir beaucoup d'améliorations possibles mais il fonctionne, merci pour votre aide encore une fois. 🤗
Mathis
 

fanch55

XLDnaute Barbatruc
Corrigez ce code qui me laisse perplexe :

If Selection.Width > boxphoto.Width + 5 _​
Then Selection.Columns.ColumnWidth = 1​
Do While Selection.Width < boxphoto.Width​
Selection.Columns.ColumnWidth = _​
Selection.Columns.ColumnWidth + 1​
Loop​

Sinon, le nom du fichier sauvegardé est défini par Me.txtL, valeur entrée par l'utilisateur,
Le FileCopy fait le boulot bestialement, que le fichier existe ou pas .
Donc, vous allez devoir vérifier que le nom n'existe pas quand me.txtL est saisi.

Je pense pour ma part que ce n'est pas très sioux de demander de saisir un nom, vous risquez d'écraser des images existantes dans des cellules précédentes .

Il faut également prévoir de détruire l'image de la cellule,
car l'insert ne fait qu'accumuler les images, exemple ci-dessous
il y a 3 images dans la même cellule
1607087991348.png

Analysez le code ci-joint qui garantit des noms de photo unique et une seule photo par cellule .
 

Pièces jointes

  • Maathis-Insert.xlsm
    28.5 KB · Affichages: 7

Maathis

XLDnaute Nouveau
J'ai créer une petite boucle qui permet de voir si le fichier existe déjà pour ne pas l'écraser :
VB:
strFileReso = CheminReso & Me.txtL & ".jpg"

        Dim Nom_img As String
        
        Nom_img = Dir(strFileReso)
        
        Do Until Nom_img = ""
        
            nom = InputBox("Veuillez changer le nom (ou précisez):", "Déja présent")
            Me.txtL = nom
            strFileReso = CheminReso & Me.txtL & ".jpg"
            Nom_img = Dir(strFileReso)
            Do While Len(nom) = 0
                MsgBox "Le nom est obligatoire", vbExclamation, "Erreur Système"
                nom = InputBox("Veuillez changer le libellé du défaut (ou précisez):", "Défaut déja présent")
                Me.txtL = nom
                strFileReso = CheminReso & Me.txtL & ".jpg"
                Nom_img = Dir(strFileReso)
            Loop
            
        Loop
      
        FileCopy strFileName, strFileReso
        
        ActiveCell.Offset(0, 5).Select
        
         With Selection.Parent.Pictures.Insert(strFileReso)
        
            .Placement = xlFreeFloating
            .PrintObject = msoFalse
            .ShapeRange.LockAspectRatio = msoFalse
            .Height = boxphoto.Height - 5
            .Width = boxphoto.Width - 5
              
            Selection.RowHeight = boxphoto.Height
            If Selection.Width > boxphoto.Width _
            Then Selection.Columns.ColumnWidth = 1
                      
            Do While Selection.Width < boxphoto.Width
                Selection.Columns.ColumnWidth = Selection.Columns.ColumnWidth + 1
            Loop
            .Placement = xlMoveAndSize
        End With

Et dans mon cas je pense que c'est impossible qu'il y ait une image déjà présente dans la cellule. :oops:
 

fanch55

XLDnaute Barbatruc
J'ai créer une petite boucle qui permet de voir si le fichier existe déjà pour ne pas l'écraser :
Et dans mon cas je pense que c'est impossible qu'il y ait une image déjà présente dans la cellule. :oops:
1) l'utilisateur ne peut faire que des ajouts et pas de mise à jour. 🤗
2) l'utilisateur peut faire une mise à jour mais en changeant le nom de la photo :
pollution du disque réseau, plusieurs photos pour la même cellule ( à moins que la ligne complète soit recréée ... ) 🥳

Il va falloir étudier un nettoyage du dossier réseau ... 🤫

Le dernier fichier proposé imposait un nom modèle : Photo_[addresse de cellule] :
Pas de doublon possible .
 

Maathis

XLDnaute Nouveau
1) l'utilisateur ne peut faire que des ajouts et pas de mise à jour. 🤗
2) l'utilisateur peut faire une mise à jour mais en changeant le nom de la photo :
pollution du disque réseau, plusieurs photos pour la même cellule ( à moins que la ligne complète soit recréée ... ) 🥳

Il va falloir étudier un nettoyage du dossier réseau ... 🤫

Le dernier fichier proposé imposait un nom modèle : Photo_[addresse de cellule] :
Pas de doublon possible .
L'utilisateur peux faire des mise a jours, mais il ne peux pas modifier ni le nom(associé à la photo), ni la photo, dans mon cas s'il veux modifier la photo c'est qu'il n'y a plus de rapport avec l'information donc autant supprimer la ligne et retaper une nouvelle information.

Au niveau des fichiers doublon et de la pollution du réseau, j'ai essayé de faire en sorte à ne jamais avoir plusieurs photos portant le même nom et j'ai rajouté une option qui supprime la photo dans le dossier réseau au moment où l'utilisateur supprime une information dans la base de données.

Et j'ai pensé à mettre une gestion d'erreur dans le cas ou l'utilisateur met un nom avec des caractères spéciaux, ce qui va poser problème au moment d'enregistrer l'image au format jpg.

Je pense qu'il y a encore des soucis à régler, je les verrais à l'utilisation du fichier.

Merci encore pour ton aide pour la création du fichier. 🎉