XL 2016 AIDE Useform Image

Maathis

Maathis

XLDnaute Nouveau
Bonjour à tous,

Je reviens vers vous, toujours avec le formulaire de saisie mais maintenant sous la forme d'un useform.
J'aimerais que avant d'enregistrer les infos dans la base, tous les champs soit complété et l'image inséré.

VB: 
If Len(Me.txtL) = 0 Then
        Me.message = "Veuillez saisir ***"
        Me.txtL.SetFocus
    ElseIf Len(Me.txtC) = 0 Then
        Me.message = "Veuillez saisir ***"
        Me.txtC.SetFocus
    ElseIf Len(Me.cbA) = 0 Then
        Me.message = "Veuillez saisir ***"
        Me.cbA.SetFocus
    ElseIf Len(Me.cbM) = 0 Then
        Me.message = "Veuillez saisir ***"
        Me.cbM.SetFocus

    End If

J'ai déjà réussi à tester si les champs était vide ou non mais je bloque sur la présence de l'image ou pas.

Pouvez vous m'aidez à trouver le code pour savoir si une image est présente dans la zone image activeX ou non ?

Ci-joint mon userform:
aide.PNG


Merci d'avance :)
 
Solution
fanch55
VB: 
                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
             
                ' Sauvegarde de l'image de l'Usf sur un ficher temporaire
                Set Fso = CreateObject("Scripting.FileSystemObject")
                    TempFileName = Environ("Temp") & "\" & Fso.GetTempName()
                    SavePicture boxphoto.Picture, TempFileName
                Set Fso = Nothing
   
                ' Injection du fichier temporaire dans une form Image de la feuille
                 ActiveCell.Offset(0, 4).Select
                 With...
Trier par date Trier par votes
R

Rhysand

XLDnaute Junior
Bonjour à tous

Je ne sais pas quel code vous utilisez pour rechercher une image, mais cela devrait ressembler à l'exemple suivant

ajoutez simplement une textbox (dans mon exemple: "TextBox1") ou une Label, pour conserver le lien d'image sélectionné

puis ajoutez simplement
ElseIf If Me.TextBox1.value = "" Then Then
Me.message = "Veuillez saisir ***"


VB: 
Private Sub CommandButton1_Click()

Dim strFileName As String

On Error Resume Next
strFileName = Application.GetOpenFilename(filefilter:="Tiff Files(*.tif;*.tiff),*.tif;*.tiff,JPEG Files (*.jpg;*.jpeg;*.jfif;*.jpe),*.jpg;*.jpeg;*.jfif;*.jpe,Bitmap Files(*.bmp),*.bmp", FilterIndex:=2, Title:="Select a File", MultiSelect:=False)

Me.TextBox1.Text = strFileName '  URL/LINK from selected picture

If strFileName = "False" Then
    MsgBox "Accès refusé: "& vbCrLf & vbCrLf &" • Aucune image n'a été sélectionnée! ", VbCritical," Une erreur s'est produite! "
    Else
        Me.Image1.Picture = LoadPicture(strFileName)
        Me.Image1.PictureSizeMode = fmPictureSizeModeClip
        Me.Repaint
End If

End Sub


J'espère aider
 
Vote positif 0 Vote négatif
Maathis

Maathis

XLDnaute Nouveau
Merci beaucoup pour vos solutions, ca fonctionne niquel.

Et j'aurais une autre petite question toujours concernant l'image.
Comment je pourrais faire, au moment d'enregistrer les infos dans la base, pour copier l'image dans une cellule mais que toutes les images aient la même taille soit celle de zone image ActiveX.

Et si possible qu'elle aussi l'option "Déplacer et dimensionner avec les cellules"

Si ce n'est pas possible j'envisage une autre option qui sera une sorte de lien qui affiche quand on clique dessus l'image dans une zone spéciale à coté de la base de données.

Mais est-ce vraiment possible ?

Merci d'avance pour votre aide. :)

Je vous met le code que j'utilise pour insérer une image.
VB: 
Private Sub import_photo_Click()

Dim strFileName As String

'importer la photo
strFileName = Application.GetOpenFilename(filefilter:="Tiff Files(*.tif;*.tiff),*.tif;*.tiff,JPEG Files (*.jpg;*.jpeg;*.jfif;*.jpe),*.jpg;*.jpeg;*.jfif;*.jpe,Bitmap Files(*.bmp),*.bmp", FilterIndex:=2, Title:="Select a File", MultiSelect:=False)

If strFileName = "False" Then
    MsgBox "Aucune image sélectionnée"
    Else
    
    'Charger l'image au bonne dimension
    Me.boxphoto.Picture = LoadPicture(strFileName)
    Me.boxphoto.PictureSizeMode = fmPictureSizeModeStretch
    
    
    'rafraichir l'useform pour afficher l'image
    Me.Repaint
    
End If

End Sub
 
Vote positif 0 Vote négatif
R

Rhysand

XLDnaute Junior
Bonjour

Je vous laisse ici un exemple

copiez simplement le code qui se trouve dans l'événement "CommandButton1", et ajoutez au reste du code dont vous avez besoin pour enregistrer les données, changez simplement la valeur de la ligne et de la colonne où vous souhaitez enregistrer, avec la même référence que la ligne de vos autres données

VB: 
Private Sub CommandButton1_Click()

deImageAFeuille Me.Image1, ActiveSheet, "6", "13"
' changer le nombre (6), qui fait référence à la ligne et le nombre (13) qui fait référence à la colonne, par des données quand il doit être stocké dans la feuille de calcul
End Sub

Private Sub deImageAFeuille(monImage, sht As Worksheet, r As Integer, c As Integer)

Dim pic As String, L As Double, T As Double, H As Double, W As Double
Dim Sh As Shape

pic = ThisWorkbook.Path & "\" & Format(Now, "yymmdd hhmmss") & "bmp"

SavePicture monImage.Picture, pic

For Each Sh In sht.Cells(r, c).Parent.Shapes
    If Sh.Name = pic _
    Or (Sh.Top = sht.Cells(r, c).Top And Sh.Left = sht.Cells(r, c).Left) Then Sh.Delete
Next Sh

L = sht.Cells(r, c).Left: T = sht.Cells(r, c).Top
H = sht.Cells(r, c).Height: W = sht.Cells(r, c).Width

With sht.Shapes.AddPicture(FileName:=pic, linktofile:=msoFalse, savewithdocument:=msoCTrue, Left:=L, Top:=T, Width:=W, Height:=H)
    .Placement = xlMove
    .OLEFormat.Object.PrintObject = msoTrue
    .OLEFormat.Object.Locked = msoTrue
End With

Kill pic

J'espère aider
 
Dernière édition:
Vote positif 0 Vote négatif
Maathis

Maathis

XLDnaute Nouveau
Merci de votre réponse :)

Mais je n'ai pas vraiment compris l'utilisation de ce code. j'ai oublié de précisé un argument important c'est que ça ne sera jamais la même cellule.

En effet, les données s'ajoute à la suite, ci joint mon code pour insérer le texte dans la BD.
VB: 
Sheets("").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

Merci d'avance
 
Vote positif 0 Vote négatif
R

Rhysand

XLDnaute Junior
Bonjour

Je vous laisse ici un exemple

Je suppose que la colonne "B" est toujours la première et la colonne "F" est l'endroit où vous souhaitez enregistrer l'image

6 = colonne "F"

VB: 
Private Sub CommandButton1_Click()

Dim x As Integer

ActiveSheet.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

x = ActiveCell.Row

deImageAFeuille Me.Image1, ActiveSheet, x, "6"

End Sub

J'espère aider
 
Vote positif 0 Vote négatif
Maathis

Maathis

XLDnaute Nouveau
Yes merci ça fonctionne bien :) mais j'aurais quelques questions sur ce code.

VB: 
Private Sub deImageAFeuille(monImage, sht As Worksheet, r As Integer, c As Integer)

Dim pic As String, L As Double, T As Double, H As Double
Dim Sh As Shape

pic = ThisWorkbook.Path & "\" & Format(Now, "yymmdd hhmmss") & "bmp"

SavePicture monImage.Picture, pic

For Each Sh In sht.Cells(r, c).Parent.Shapes
    If Sh.Name = pic _
    Or (Sh.Top = sht.Cells(r, c).Top And Sh.Left = sht.Cells(r, c).Left) Then Sh.Delete
Next Sh

L = sht.Cells(r, c).Left: T = sht.Cells(r, c).Top

With sht.Shapes.AddPicture(Filename:=pic, linktofile:=msoFalse, savewithdocument:=msoCTrue, Left:=L, Top:=T, Width:=sht.Cells(r, c).Width, Height:=sht.Cells(r, c).Height)
    .Placement = xlMove
    .OLEFormat.Object.PrintObject = msoTrue
    .OLEFormat.Object.Locked = msoTrue

End With

Kill pic

End Sub

Tout d'abord pourquoi sommes nous obligés de sauvegarder l'image au format bmp ?
Et existe-t-il un moyen pour que l'image garde sa taille qu'elle a pris dans le useform et qu'elle se déplace avec la cellule ( dans le cas de filtres automatiques)?

Merci beaucoup pour votre aide.
 
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Bonjour,

Une autre solution :
VB: 
Private Sub import_photo_Click()
'-----
If strFileName = "False" Then
    MsgBox "Aucune image sélectionnée"
Else
    boxphoto.Picture = LoadPicture(strFileName)
    boxphoto.PictureSizeMode = fmPictureSizeModeStretch
    Me.Repaint
    Dim i
    With ActiveCell 'à adapter
        For i = 1 To 255
            .ColumnWidth = i: If .Width > boxphoto.Width Then Exit For
        Next
        For i = 1 To 409
            .RowHeight = i: If .Height > boxphoto.Height Then Exit For
        Next
        .Parent.Pictures.Insert strFileName
    End With
End If
End Sub
A+
 
Dernière édition:
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
La seule raison que je vois c'est que la feuille active est protégée.

Il n'y a pas de bug pour le dimensionnement de la cellule active parce que lors de la protection les options "Mettre en forme les colonnes" et "Format de lignes" ont été cochées.

Mais il n'y a pas d'option possible pour l'insertion d'images.

Donc ôtez la protection, manuellement ou dans la macro.
 
Vote positif 0 Vote négatif
Maathis

Maathis

XLDnaute Nouveau
Je pense avoir compris pourquoi.
Dans mon formulaire, je veux d'abord insérer une image qui s'affiche dans la zone d'image.
Et ensuite, l'image ira avec les autres valeurs dans une feuille suivant le critère choisi par l'utilisateur, l'image peut aller sur 7 feuilles différentes.

Alors que le code que vous m'avez envoyé est fait pour choisir l'image sur son pc et ensuite directement la mettre dans une même cellule. Ca fonctionne mais ce n'est pas ce dont j'ai besoin, je me suis mal exprimé sur mon besoin.

J'ai réussi à sélectionner une image sur son pc et l'insérer dans la zone image du userform.
J'ai réussi à envoyer les donnés saisies par l'utilisateur dans la feuille correspondante à son critère, avec des IF mais la ou je bloque c'est réussir à prendre l'image qui est dans la zone image du useform et la transférer dans la cellule de mon choix au mêmes dimensions.

J'espère ne pas avoir trop compliqué dans mes explications :(

Merci d'avance
 
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Maathis à dit:
mais la ou je bloque c'est réussir à prendre l'image qui est dans la zone image du useform et la transférer dans la cellule de mon choix au mêmes dimensions.
Cliquez pour agrandir...
Je pense que ce n'est pas possible, il faut copier l'image à la source, voici le bon code :
VB: 
Private Sub import_photo_Click()
Dim strFileName As Variant, o As Object, i%
strFileName = Application.GetOpenFilename(filefilter:="Tiff Files(*.tif;*.tiff),*.tif;*.tiff,JPEG Files (*.jpg;*.jpeg;*.jfif;*.jpe),*.jpg;*.jpeg;*.jfif;*.jpe,Bitmap Files(*.bmp),*.bmp", FilterIndex:=2, Title:="Select a File", MultiSelect:=False)
If strFileName = False Then
    MsgBox "Aucune image sélectionnée"
Else
    boxphoto.Picture = LoadPicture(strFileName)
    boxphoto.PictureSizeMode = fmPictureSizeModeStretch
    Me.Repaint
    With ActiveCell 'à adapter
        For Each o In .Parent.DrawingObjects
            If o.TopLeftCell.Address = .Address Then o.Delete 'RAZ
        Next
        Set o = .Parent.Pictures.Insert(strFileName)
        o.Placement = 2
        For i = 1 To 255
            .ColumnWidth = i: If .Width > o.Width Then Exit For
        Next
        For i = 1 To 409
            .RowHeight = i: If .Height > o.Height Then Exit For
        Next
    End With
End If
End Sub
 
Vote positif 0 Vote négatif

Discussions similaires

N
  • Résolu(e)
XL 2021 erreur Vba
2
Réponses
21
Affichages
2 K
Oneida
Oneida
patricktoulon
  • Question
XL 2013 enregistrer la capture d'une shape avec les api avec transparence
2
Réponses
26
Affichages
925
patricktoulon
patricktoulon
patricktoulon
  • Question
Autres la fonction similaire
Réponses
11
Affichages
434
patricktoulon
patricktoulon
Nico2978
  • Résolu(e)
XL 2019 Aide pour un module d'archivage de feuille en pdf dans répertoire
Réponses
5
Affichages
545
Nico2978
Nico2978
D
  • Question
XL 2021 VBA - Erreur 1004 aléatoire - Image/Logo
Réponses
10
Affichages
650
crocrocro
C
N
  • Question
XL 2021 Inclure dans mail une image déjà dans le fichier .xlm
Réponses
9
Affichages
452
nano33320
N
Messan
  • Résolu(e)
XL 2019 Organiser les données dans listbox
Réponses
2
Affichages
692
Messan
Messan
A
  • Question
XL 2010 Contrôles dans USF avant ajout
Réponses
5
Affichages
650
Oneida
Oneida
mromain
Génération de QR Codes
Réponses
1
Affichages
749
Cousinhub
Cousinhub
T
  • Question
XL 2019 Comparer la valeur numérique de 2 textbox
Réponses
6
Affichages
1 K
terrier
T

Membres actuellement en ligne

11 membres et 96 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
315 143
Messages
2 116 711
Membres
112 841
dernier inscrit
Guillaume05200