XL 2010 Insérer image dans une zone de texte

[madoupa]

Bonjour tout le monde
j'ai ce code pour insérer des images, SVP je veux modifier l'emplacement pour les insérer dans des zones de texte
merci

 Dim Emplacement As Range
  Dim img As Object
  Dim ShapeObj As Shape, i%
 
  'Boucle pour supprimer les images sauf le bouton
  For Each ShapeObj In Sheets("feuil1").Shapes
      If ShapeObj.Name = "Cible1" Then ShapeObj.Delete
  Next ShapeObj
  Sheets("feuil1").Activate
  If Application.Dialogs(xlDialogInsertPicture).Show Then
      For i = 1 To 2 'Boucle pour 2 images
        If i = 1 Then '1ère image
          Set Emplacement = Range("I15:I20") '1er emplacement
        Else 'sinon pour 2ème image, copie de la première
          ActiveSheet.Shapes.Range(Array("Cible1")).Select
          Selection.Copy
          ActiveSheet.Paste
          Set Emplacement = Range("I41:I46") '2ème emplacement
        End If
        Set img = ActiveSheet.DrawingObjects(ActiveSheet.Shapes.Count)
        With img.ShapeRange
          'Nommer l'image insérée (Pour la supprimer plus facilement ensuite)
          .Name = "Cible1" 'Nomme les images 1 ou 2
          .LockAspectRatio = msoFalse
          .Left = Emplacement.Left
          .Top = Emplacement.Top
          .Height = Emplacement.Height
          .Width = Emplacement.Width
          .ZOrder msoSendToBack
      End With
      Next i

 

[kiki29]

Salut, va voir sur JBoisgontier

 

[madoupa]

Salut, va voir sur JBoisgontier

salut
j'ai pas trouvé

 

[madoupa]

Salut, va voir sur JBoisgontier

Bonjour
Svp, je connaiis pas beaucoup on vba, je veux remplacer set Emplacement = Range("I41:I46") par un emplacement zone de texte (textbox)
merci d'avance

 

[p56]

Bonjour à tous,
Voici du code fonctionnel

' Auteur : Pierre - P56 - http://tatiak.canalblog.com/
Sub Image_dans_Texte()
Dim ndf As Variant, W As Single, H As Single

    ndf = Choix_Image
    If Not ndf = False Then
        On Error Resume Next
        ActiveSheet.Shapes("_Test").Delete
        
        With ActiveSheet.Pictures.Insert(ndf)
            W = .Width
            H = .Height
            .Delete
        End With
    
        With ActiveSheet.Shapes.AddTextbox(1, 100, 50, W, H)
            .Fill.UserPicture ndf
            .Name = "_Test"
        End With
    End If
End Sub

Function Choix_Image() As String
    ChDrive (Left(ActiveWorkbook.Path, 1))
    ChDir ActiveWorkbook.Path
    Choix_Image = Application.GetOpenFilename("Fichiers images,*.jpg;*.gif;*.png")
End Function

P.

 

[patricktoulon]

re
Bonjour
bien vu tatiak je n'y ai pas pensé a fillformat

 

[madoupa]

Bonjour à tous,
Voici du code fonctionnel

' Auteur : Pierre - P56 - http://tatiak.canalblog.com/
Sub Image_dans_Texte()
Dim ndf As Variant, W As Single, H As Single

    ndf = Choix_Image
    If Not ndf = False Then
        On Error Resume Next
        ActiveSheet.Shapes("_Test").Delete
       
        With ActiveSheet.Pictures.Insert(ndf)
            W = .Width
            H = .Height
            .Delete
        End With
   
        With ActiveSheet.Shapes.AddTextbox(1, 100, 50, W, H)
            .Fill.UserPicture ndf
            .Name = "_Test"
        End With
    End If
End Sub

Function Choix_Image() As String
    ChDrive (Left(ActiveWorkbook.Path, 1))
    ChDir ActiveWorkbook.Path
    Choix_Image = Application.GetOpenFilename("Fichiers images,*.jpg;*.gif;*.png")
End Function

P.

Merci, ça marche bien ton code
mais ce que je veux c'est d'insérer une image sur un textbox qui est déjà sur ma feuil pour ne pas prendre la forme des cellules, car l'image est un tampon rond.
merci

 

[p56]

Et bien le principe est le même. Ici du code pour remplacer l'image du textbox nommé "_Test", en gardant les dimensions de l'image choisie

' Auteur : Pierre - P56 - http://tatiak.canalblog.com/
Sub Remplace_Image_dans_Texte()
Dim ndf As Variant, W As Single, H As Single

    ndf = Choix_Image
    If Not ndf = False Then
        With ActiveSheet.Pictures.Insert(ndf)
            W = .Width
            H = .Height
            .Delete
        End With
       
        With ActiveSheet.Shapes("_Test")
            .Width = W
            .Height = H
            .Fill.UserPicture ndf
        End With
    End If
End Sub

Function Choix_Image() As String
    ChDrive (Left(ActiveWorkbook.Path, 1))
    ChDir ActiveWorkbook.Path
    Choix_Image = Application.GetOpenFilename("Fichiers images,*.jpg;*.gif;*.png")
End Function

 

[patricktoulon]

re
@p56 il serait intéressant de remplir le textbox en gardant le ration de l'image
faire un peu comme un encart journal

si ça vous intéresse je sais comment faire

 

[madoupa]

Et bien le principe est le même. Ici du code pour remplacer l'image du textbox nommé "_Test", en gardant les dimensions de l'image choisie

' Auteur : Pierre - P56 - http://tatiak.canalblog.com/
Sub Remplace_Image_dans_Texte()
Dim ndf As Variant, W As Single, H As Single

    ndf = Choix_Image
    If Not ndf = False Then
        With ActiveSheet.Pictures.Insert(ndf)
            W = .Width
            H = .Height
            .Delete
        End With
      
        With ActiveSheet.Shapes("_Test")
            .Width = W
            .Height = H
            .Fill.UserPicture ndf
        End With
    End If
End Sub

Function Choix_Image() As String
    ChDrive (Left(ActiveWorkbook.Path, 1))
    ChDir ActiveWorkbook.Path
    Choix_Image = Application.GetOpenFilename("Fichiers images,*.jpg;*.gif;*.png")
End Function

Merci beaucoup
il reste un seul souci c'est le code pour enlever le trait du contour de la textbox ça m'aidera beaucoup
merci d'avance

 

[p56]

Trés simple :

With ActiveSheet.Shapes("_Test")
    .Line.Visible = msoFalse
    ' etc ...

 

[patricktoulon]

re
Bonjour a tous
j'aurais une question
ajouter un textbox formulaire par vba ok
mais par le menu le bouton est grisé(déactivé)
quelqu'un pourrait me dire pourquoi ?

 

[p56]

Bonjour à tous,
Encore très simple : cf Menu Insertion/Texte/Zone de texte

 

[patricktoulon]

re
ok @p56 reçu

 

[guy72]

Comment ajouter une image dans une zone de texte si la cellule G31 contient un nombre de plus de 21