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
fanch55

fanch55

XLDnaute Barbatruc
Une autre approche dans le classeur joint :
les images sont enregistrées dans une colonne d'un tableau structurée .

Elles sont plus petites que la cellule d'accueil pour pouvoir être détruites en même temps que la ligne du tableau.

A ce propos, pour tous les gourous de ce forum, je me heurte à un phénomène énervant:
l'image de la première ligne du tableau n'est jamais détruite sinon manuellement...
 

Pièces jointes

  • Maathis.xlsm
    24.9 KB · Affichages: 13
Vote positif 0 Vote négatif
R

Rhysand

XLDnaute Junior
Bonjour à tous

Width:=-1, Height:=-1 -> cela signifie que l'image conserve sa taille d'origine

J'ai changé le code pour que la ligne et la colonne aient la dimension de l'image

sur "ColumnWidth" j'ai écrit "30" au lieu de l'image.Width, modifiez cette valeur si nécessaire



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

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

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

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:=-1, Height:=-1)
    .Placement = xlMove
    .OLEFormat.Object.PrintObject = msoTrue
    .OLEFormat.Object.Locked = msoTrue
    
End With

For Each Sh In sht.Cells(r, c).Parent.Shapes
    If (Sh.Left = sht.Cells(r, c).Left) Then
    sht.Range("F" & c).ColumnWidth = 30 'Sh.Width
    sht.Range("A" & r).RowHeight = Sh.Height
    End If
Next Sh

Kill pic

End Sub

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

job75

XLDnaute Barbatruc
job75 à dit:
Je pense que ce n'est pas possible, il faut copier l'image à la source
Cliquez pour agrandir...
Au temps pour moi, j'oubliais qu'il existe SavePicture, voyez ce fichier et la macro dans l'USF :
VB: 
Private Sub CommandButton1_Click()
If boxphoto.Picture Is Nothing Then Exit Sub
Dim fichier$, cellules, c, o As Object, i%
Application.ScreenUpdating = False
fichier = ThisWorkbook.Path & "\MonImage.jpg"
SavePicture boxphoto.Picture, fichier
cellules = Array("Feuil1!A2", "Feuil2!B2", "Feuil3!C2") 'liste des adresses à adapter
For Each c In cellules
    With Evaluate(c)
        .Parent.Visible = xlSheetVisible 'si la feuille est masquée
        Application.Goto .Cells
        For Each o In .Parent.DrawingObjects
            If o.TopLeftCell.Address = .Address Then o.Delete 'RAZ
        Next
        Set o = .Parent.Pictures.Insert(fichier)
        o.Placement = 2
        For i = 1 To 255
            .ColumnWidth = i: If .Width > o.Width Then Exit For
        Next i
        For i = 1 To 409
            .RowHeight = i: If .Height > o.Height Then Exit For
        Next i
    End With
Next c
Kill fichier
Feuil1.Activate
Application.ScreenUpdating = True
End Sub
 

Pièces jointes

  • Images(1).xlsm
    37.3 KB · Affichages: 7
Vote positif 0 Vote négatif
Maathis

Maathis

XLDnaute Nouveau
fanch55 à dit:
Une autre approche dans le classeur joint :
les images sont enregistrées dans une colonne d'un tableau structurée .

Elles sont plus petites que la cellule d'accueil pour pouvoir être détruites en même temps que la ligne du tableau.

A ce propos, pour tous les gourous de ce forum, je me heurte à un phénomène énervant:
l'image de la première ligne du tableau n'est jamais détruite sinon manuellement...
Cliquez pour agrandir...

Merci à vous c'est exactement ce dont j'ai besoin, mais dans votre code pour créer une nouvelle ligne et ensuite à l'aide de la variable "row" vous insérer votre image si je ne me trompe pas.

Serait-il possible justement d'adapter le code. J'ai deja essayé d'adapter ton code mais l'image s'affiche sur la mauvaise cellule. Elle s'affiche sur "activecell" alors que je voudrais qu'elle s'affiche sur activecell.offset(0,4). Ci joint ton code adapté:
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
             With ActiveCell.Offset(0, 4).Parent.Pictures.Insert(TempFileName)
                .Placement = xlMoveAndSize
                .PrintObject = msoFalse
                .ShapeRange.LockAspectRatio = msoFalse
       
                .Height = boxphoto.Height
                .Width = boxphoto.Width

            End With
           
                Unload Me

Merci :)
 
Vote positif 0 Vote négatif
Maathis

Maathis

XLDnaute Nouveau
Rhysand à dit:
Bonjour à tous

Width:=-1, Height:=-1 -> cela signifie que l'image conserve sa taille d'origine

J'ai changé le code pour que la ligne et la colonne aient la dimension de l'image

sur "ColumnWidth" j'ai écrit "30" au lieu de l'image.Width, modifiez cette valeur si nécessaire



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

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

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

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:=-1, Height:=-1)
    .Placement = xlMove
    .OLEFormat.Object.PrintObject = msoTrue
    .OLEFormat.Object.Locked = msoTrue
   
End With

For Each Sh In sht.Cells(r, c).Parent.Shapes
    If (Sh.Left = sht.Cells(r, c).Left) Then
    sht.Range("F" & c).ColumnWidth = 30 'Sh.Width
    sht.Range("A" & r).RowHeight = Sh.Height
    End If
Next Sh

Kill pic

End Sub

J'espère aider
Cliquez pour agrandir...

Bonjour, merci pour votre réponse

Dans votre code à quoi correspond ces commandes svp :
Code: 
    .OLEFormat.Object.PrintObject = msoTrue
    .OLEFormat.Object.Locked = msoTrue

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

Maathis

XLDnaute Nouveau
Yesss j'ai réussi je vous met le code que j'ai adapter ci joint.
Merci à tous pour votre aide et votre patience avec moi :):)

Code: 
                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 Selection.Parent.Pictures.Insert(TempFileName)
                .Placement = xlMoveAndSize
                .PrintObject = msoFalse
                .ShapeRange.LockAspectRatio = msoFalse
        
                .Height = boxphoto.Height
                .Width = boxphoto.Width
                

            End With
            
                Unload Me
 
Vote positif 0 Vote négatif
Maathis

Maathis

XLDnaute Nouveau
Maathis à dit:
Yesss j'ai réussi je vous met le code que j'ai adapter ci joint.
Merci à tous pour votre aide et votre patience avec moi :):)

Code: 
                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 Selection.Parent.Pictures.Insert(TempFileName)
                .Placement = xlMoveAndSize
                .PrintObject = msoFalse
                .ShapeRange.LockAspectRatio = msoFalse
       
                .Height = boxphoto.Height
                .Width = boxphoto.Width
               

            End With
           
                Unload Me
Cliquez pour agrandir...

J'ai crié victoire un peu trop vite.
L'image s'insère bien au bon endroit et au début la cellule prenait la taille de l'image, mais maintenant la ligne reste à la même taille sans s'adapter à l'image :rolleyes:

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

Rhysand

XLDnaute Junior
Bonjour,

J'ai ajouté ces lignes de commande si vous souhaitez imprimer l'image avec les données de la feuille de calcul et si l'objet (image) est protégé ou non.

= Vrai, apparaît sur la feuille d'impression;
= Faux, lors de l'impression, n'apparaît pas

et pour la protection de l'objet, c'est pareil

:)
 
Vote positif 0 Vote négatif
fanch55

fanch55

XLDnaute Barbatruc
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 Selection.Parent.Pictures.Insert(TempFileName)
                    .Placement = xlFreeFloating
                        .PrintObject = msoFalse
                        .ShapeRange.LockAspectRatio = msoFalse
                        .Height = boxphoto.Height
                        .Width = boxphoto.Width
               
                        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
           
                Unload Me
 
Vote positif 0 Vote négatif
Solution
Maathis

Maathis

XLDnaute Nouveau
fanch55 à dit:
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 Selection.Parent.Pictures.Insert(TempFileName)
                    .Placement = xlFreeFloating
                        .PrintObject = msoFalse
                        .ShapeRange.LockAspectRatio = msoFalse
                        .Height = boxphoto.Height
                        .Width = boxphoto.Width
              
                        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
          
                Unload Me
Cliquez pour agrandir...

Merci beaucoup, ça marche exactement comment je voulais :D
Merci à tous pour votre aide
 
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 102 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 712
Membres
112 842
dernier inscrit
Ahmed El banhaji