inserer une image dans AddTextBox

[stormless]

Bonjour a tous

je suis a la recherche de methodes ou d'exemples pour inserer des photos dans une addtextbox.

le but etant de generer autant de addtextbox ( format 3cm x 3cm) qu'il y a de photos dans un repertoire (X) de compresser les images puis de mettre les photos dans la addtextbox de grouper le tout afin de pourvoir les deplacer dans la feuille et de mettre numeroter les addtextbox's

un petit exemple en piece jointe

sinon je suis ouvert a d'autres idées ou solutions pour inserer des photos en forme de vignettes dans une feuille excel

merci d'avance de votre aide

 

[stormless]

Re : inserer une image dans AddTextBox

re

merci pour l'exemple je vais etudier cela

@+

 

[stormless]

Re :grouper une image et une AddTextBox

BOnjour a tous

j'ai repris la macro faite par staple 1600 que j'ai modifié mon probleme se trouve dans le groupage de la addtextbox et la photo.
en vert dans la macro

Sub importation_images()
Dim p As Picture
Dim i As Integer
Dim ii As Integer
Dim iii As Integer
Dim iiii As Integer


Dossier = "f:\" 'InputBox("Quel répertoire ?" & Chr(13) & "Taper le répertoire voulu sous la forme C:\NomRépertoire")

Application.ScreenUpdating = False

With Application.FileSearch
.NewSearch
.LookIn = Dossier
.Filename = "*.jpg;*.jpeg"
.MatchTextExactly = False
.SearchSubFolders = False
.Execute
ii = 0
base = 30
iiii = 0
ActiveSheet.DrawingObjects.Delete
ActiveSheet.Cells.Clear
For i = 1 To .FoundFiles.Count
ii = ii + 2
iii = iii + 3
iiii = 45 + iiii


'ActiveSheet.Cells(i + ii, 8) = Left(Mid(.FoundFiles(i), Len(Dossier) + 1), Len(Mid(.FoundFiles(i), Len(Dossier) + 2)) - 3)
ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, 520#, -15 + iiii, _
17#, 45#).Select
Selection.Characters.Text = i
With ActiveSheet
Set p = .Pictures.Insert(Application.FileSearch.FoundFiles(i))
.DrawingObjects(p.Name).Left = .Columns("j").Left
.DrawingObjects(p.Name).Top = .Rows(iii).Top
.DrawingObjects(p.Name).Width = .Columns("l").Left - .Columns("j").Left
.DrawingObjects(p.Name).Height = .Rows(iii + 3).Top - .Rows(iii).Top
.DrawingObjects(p.Name).Placement = xlMoveAndSize
.DrawingObjects(p.Name).PrintObject = True

' .Shapes.Range(Array(p.Name, AddTextbox)).Select
' Selection.ShapeRange.Group.Select
End With

Next i
End With
Application.ScreenUpdating = True
End Sub

donc voila si quelqu'un a une solution a me proposer je suis preneur

merci d'avance