Microsoft 365 Envoyer une image dans une cellule avec un userform

[dubarre]

Bonjour à tous,

Je viens vers vous car je cherche la solution depuis plusieurs jours pour pouvoir envoyer une image qui se trouve dans un formulaire dans une cellule.

Je m'explique j'ai un formulaire avec trois objets image1, commandbutton1,commandbutton2.

commandbutton1 = va chercher l'image dans le dossier ça j'ai réussi à le faire par contre pour ma connaissance personnelle si vous avez d'autres solutions pourquoi pas

image1 = reçoit l'image du dossier

commandbutton2 = je voudrais que ce bouton envoie l'image dans la cellule("B2") je précise: réellement la photo et non le lien s'il vous plaît

Pouvez-vous m'aider s'il vous plaît.

 

[sousou]

Bonjour
Le code du boutton
Private Sub CommandButton2_Click()
With Sheets(1)

Set monimage = .Pictures.Insert(xRecherche)
monimage.Left = .Range("b2").Left
monimage.Top = .Range("b2").Top
monimage.Width = .Range("b2").MergeArea.Width
End With
End Sub

 

[dubarre]

Bonjour à toi,

Merci pour ta proposition cela fonctionne correctement par contre comment limiter et respecter les dimensions quand même de la photo si je veux mettre exemple B2 et que la photo se limite à F16
s'il vous plaît

 

[sousou]

Ici j'ai cadré la photo sur la largeur des cellules fusionnées.
monimage.Width = .Range("b2").MergeArea.Width
monimage.Width = .Range("b2").Width ici la photo ne sera pas redimensionnée
il faut voir exactement ce que tu souhaites

 

[Dudu2]

Bonjour,

Plusieurs choses...
D'une part ton fichier est incomplet, il n'y a que le UserForm et il manque les macros, donc on ne peut rien en faire.
D'autre part si tu as la localisation de l'image pour la mettre dans le UserForm, pourquoi ne pas utiliser cette localisation pour l'insérer dans une cellule comme l'a fait sousou.

Sinon pour exporter une image d'un UserForm il faut l'enregistrer puis l'insérer.

Private Sub CommandButton2_Click()
    Call PictureToCell(UserForm1.Image1, ActiveSheet.Range("B2"))
End Sub

Private Sub PictureToCell(PictureControl, Cell As Range, Optional InCell As Boolean = True)
    Dim FSO As Object
    Dim FullName As String
    Dim Picture As Object
    Dim Sh As Shape
    Dim Ratio As Single
    Dim Width As Single
    Dim Height As Single
    Const TemporaryFolder = 2
  
    'Delete existing picture at destination or same name
    For Each Sh In Cell.Parent.Shapes
        If Sh.Name = PictureControl.Name _
        Or (Sh.Top = Cell.Top And Sh.Left = Cell.Left) Then Sh.Delete
    Next Sh
  
    'Save Picture to temporary folder
    Set FSO = CreateObject("scripting.filesystemobject")
    FullName = FSO.GetSpecialFolder(TemporaryFolder).Path & "\" & FSO.gettempname
    SavePicture PictureControl.Picture, FullName
  
    'Image size
    If InCell Then
        Ratio = Application.Min(Cell.MergeArea.Width / PictureControl.Width, Cell.MergeArea.Height / PictureControl.Height)
    Else
        Ratio = 1
    End If
  
    Width = PictureControl.Width * Ratio
    Height = PictureControl.Height * Ratio
  
    'Insert Picture in the Worksheet
    Set Sh = Cell.Parent.Shapes.AddShape(msoShapeRectangle, Cell.Left, Cell.Top, Width, Height)
    Sh.Name = PictureControl.Name
    Sh.Fill.UserPicture FullName

    'delete temporary file
    FSO.deletefile FullName
End Sub

 

[Dranreb]

Bonjour.
Pourquoi pas un OLEObject Image :

Private Sub CommandButton2_Click()
   Dim OOt As OLEObject, Img As MSForms.Image
   On Error Resume Next
   Set OOt = Feuil1.OLEObjects("ImgB2")
   On Error GoTo 0
   If OOt Is Nothing Then
      Set OOt = Feuil1.OLEObjects.Add("Forms.Image.1")
      OOt.Name = "ImgB2"
      OOt.Left = Feuil1.[B2].Left: OOt.Top = Feuil1.[B2].Top
      OOt.Width = Feuil1.[B2].MergeArea.Width: OOt.Height = Feuil1.[B2].MergeArea.Height
      Set Img = OOt.Object
      Img.PictureSizeMode = fmPictureSizeModeZoom
      Img.BackColor = &HC8BCB0: Img.BorderStyle = fmBorderStyleNone
   Else: Set Img = OOt.Object: End If
   Img.Picture = Image1.Picture
   End Sub

 

[patricktoulon]

bonjour a tous
vide ton code userform et met ceci

Public xRecherche As String
Public FichName As String
Private Sub CommandButton1_Click()
    xRecherche = Application.GetOpenFilename("Images Files (*.jpg;*.bmp;*.gif;*.tif), *.jpg;*.bmp;*.gif;*.tif", 1, "CHOISIR UNE IMAGE")
    If xRecherche = "" Then Exit Sub
    Image1.Picture = LoadPicture(xRecherche)
    FichName = Mid(xRecherche, InStrRev(xRecherche, "\") + 1)
    Me.Caption = FichName
End Sub

Private Sub CommandButton2_Click()
    Dim temp$, Destination As Range
    temp = Environ("userprofile") & "\DeskTop\imgtemp.jpg"
    SavePicture Image1.Picture, temp
    With Sheets("Feuil1")
        Set Destination = .[B2:E16]
        .Pictures.Insert (temp)
        place_l_image_au_centre_dans Destination, .Pictures(.Pictures.Count)
    End With
    Kill temp
End Sub


Sub place_l_image_au_centre_dans(rng As Range, Shp As Picture)
   'patricktoulon
   'redimentionne l'image le plus possible pour qu'elle rentre dans le range sans déformation
   With Shp
        .ShapeRange.LockAspectRatio = msoTrue    ' lock leratio indéformable
        ratio = .Width / .Height     ' calcul ratio
        w = rng.Width       ' width  range
        h = rng.Height      ' height range
        If (w / h < ratio) Then 'comparaison des ratios(rng/shp)
            .Width = w - 2
        Else
            .Height = h - (2 / ratio)
        End If
        .Left = rng.Left + ((rng.Width - .Width) / 2)
        .Top = rng.Top + ((rng.Height - .Height) / 2)
        .Placement = 1
    End With
End Sub

bien avec l'oleobject Dranreb

 

[dubarre]

Bonjour à tous,

Tout d'abord je vais répondre à dudu le fichier que je vous ai transmis à bien les macros je viens de télécharger le dossier que je vous ai transmis il fonctionne si les autres personnes peuvent me le confirmer s'il vous plaît.

D'autre par vous m'avait transmis de codes différents je tiens à préciser que je dois dans cet exemple aller chercher la photo dans mon dossier l'insérer dans image1 et ensuite je puisse envoyer la photo dans la cellule correspondante à mon choix.

Je tiens à préciser une petite chose pour toutes les personnes qui m'aident je rencontre un problème j'ai une base de données où il y a l'il y a des photo qui sont insérées quand je vais chercher les éléments correspondants à la photo sincère correctement donc formulaire la je n'arrive pas à envoyer la photo dans la cellule.

Ça fonctionne que si je vais chercher la photo et ensuite je fais l'impression donc si vous avez une solution.

En vous remerciant.

 

[dubarre]

Bonjour Patrick,

Nos messages se sont croisés je vais regarder ce que tu me proposes par contre je voudrais demander à tous ceux j'essaie de vous transmettre sur le classeur réel que je travaille mais j'ai un problème je n'arrive pas à comprendre d'où ça vient la première fois que ça me le fait mon classeur fait plus de 1MO pouvez-vous me dire pourquoi étant donné qu'il y a qu'un formulaire avec plusieurs choses dedans et par contre il y a huit onglets je n'arrive pas à trouver d'où peut venir le problème pour qu'il soit si important le classeur avec peu de choses.

 

[patricktoulon]

re
pour ton fichier trop gros
essaie si tu a winrar de le compresser avec méthode hard sinon essaie la compression de windows natif
dernier recours cjoint.com et autre hébergeur gratuits
sinon voici ton fichier avec mon code

 

[dubarre]

Bonjour à tous encore une fois nos messages se croisent un grand merci pour votre aide la solution qui se rapproche le plus à ce que j'ai besoin et la solution de Patrick car je peux jouer sur le format pour l'adapter au mieux à la grandeur que j'ai besoin mais en tout cas un grand merci à vous tous

 

[patricktoulon]

Bonjour à tous encore une fois nos messages se croisent un grand merci pour votre aide la solution qui se rapproche le plus à ce que j'ai besoin et la solution de Patrick car je peux jouer sur le format pour l'adapter au mieux à la grandeur que j'ai besoin mais en tout cas un grand merci à vous tous

ben oui ma sub est faite pour ça, tu n'a pas besoins de jouer, elle le fait toute seule

j'ai ajouté la possibilité de recommencer a l'infini en supprimant l'image précédente a chaque fois
tu clique/choisi l'image tu clique ça met l'image à l'infini

 

[dubarre]

OK je vais regarder ça merci encore de votre aide cordialement

 

[Dudu2]

Salut les experts,

Petite remarque: dans son fichier dubarre a fusionné des cellules pour avoir comme destination non pas une plage mais une cellule (B2). Ça n'a pas échappé à Dranreb qui, dans sa Macro savante, a bien précisé MergeArea ce qui m'a amené à corriger mon propre code. De toutes façons si dans une plage il y a 1 ou plusieurs cellules fusionnées, c'est assez complexe de calculer les largeur et hauteur de la plage, et les références Range.Width et Range.Height globales ne donneront pas les bonnes valeurs.

Simplification: pour le ratio à appliquer de manière à remplir au mieux (maximiser l'utilisation de la cellule destination B2 tout en gardant les proportions de l'image, le ratio à appliquer aux dimensions de l'image est simple:
Ratio = Application.Min(<cellule destination>.MergeArea.Width / <image à copier>.Width, <cellule destination>.MergeArea.Height / <image à copier>.Height).

 

[patricktoulon]

bonjour @Dudu2

Ratio = Application.Min(Cell.MergeArea.Width / PictureControl.Width, Cell.MergeArea.Height / PictureControl.Height).

c'est bien beau ton truc mais tu l'applique a quoi ???
fait le reste du code pour l'appliquer a l'image et dis moi encore que c'est plus simple

pour t'amener a la compréhension de l'erreur de raisonnement que tu fait je dirais

" qui a dit que je prenais le plus petit"

LOL