inserer une image dans AddTextBox

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

Cliquez pour agrandir...