Boostez vos compétences Excel avec notre communauté !
Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !
Public Dossier As String
Sub images_dossier()
'nom macro originale:ListeFichiersRepert
'auteur: michelxld
'activer la reference Microsoft scripting Runtime
Dossier = InputBox("Lecteur et nom du dossier à traiter")
'Saisir C:\Temp par exemple
Dim fso As Scripting.FileSystemObject
Dim Source As String, f As File, x As Integer
Dim f1 As Folder, f2 As File
Set fso = CreateObject("Scripting.FileSystemObject")
Source = Dossier
x = 1
For Each f In fso.GetFolder(Dossier).Files
Cells(x, 1).Value = Left(f.Name, Len(f.Name) - 4)
x = x + 1
Next f
Call test
End Sub
Sub test()
'auteur: richard
Application.ScreenUpdating = False
Dim i As Integer, p As Picture, r As Range, c As Range, ii As Integer, f As Integer
ii = 0
f = ActiveSheet.Range("A6556").End(xlUp).Row
Set r = ActiveSheet.Range("A1:A" & f)
ActiveSheet.DrawingObjects.Delete
For Each c In r
ii = ii + 1
If c <> "" Then
With Application.FileSearch
.NewSearch
.LookIn = Dossier
.SearchSubFolders = False
.Filename = "*" & c & ".jpg"
.Execute
For i = 1 To .FoundFiles.Count
With ActiveSheet
Set p = .Pictures.Insert(Application.FileSearch.FoundFiles(i))
.DrawingObjects(p.Name).Left = .Columns("B").Left
.DrawingObjects(p.Name).Top = .Rows(ii).Top
.DrawingObjects(p.Name).Width = .Columns("C").Left - .Columns("B").Left
.DrawingObjects(p.Name).Height = .Rows(ii + 1).Top - .Rows(ii).Top
.DrawingObjects(p.Name).Placement = xlMoveAndSize
.DrawingObjects(p.Name).PrintObject = True
End With
Exit For
Next i
End With
End If
Next c
Application.ScreenUpdating = True
End SubPublic Dossier As String
Sub liste_fichiers()
Dossier = InputBox("Quel répertoire ?" & Chr(13) & "Taper le répertoire voulu sous la forme C:\NomRépertoire")
Dim lstfile As Long
Dim i As Integer, p As Picture, r As Range, c As Range, ii As Integer, f As Integer
With Application.FileSearch
.Filename = "*.jpg"
'adapter selon l'extension désirée gif, bmp
.LookIn = Dossier
.SearchSubFolders = False
For lstfile = 1 To .Execute(msoSortByFileName)
ActiveSheet.Cells(lstfile, 1).Value = Left(Mid(.FoundFiles(lstfile), Len(Dossier) + 2), Len(Mid(.FoundFiles(lstfile), Len(Dossier) + 2)) - 4)
Next lstfile
End With
Call import_images
End Sub
Sub import_images()
'auteur: richard
Application.ScreenUpdating = False
Dim i As Integer, p As Picture, r As Range, c As Range, ii As Integer, f As Integer
ii = 0
f = ActiveSheet.Range("A6556").End(xlUp).Row
Set r = ActiveSheet.Range("A1:A" & f)
ActiveSheet.DrawingObjects.Delete
For Each c In r
ii = ii + 1
If c <> "" Then
With Application.FileSearch
.NewSearch
.LookIn = Dossier
.SearchSubFolders = False
.Filename = "*" & c & ".jpg"
'adapter selon l'extension désirée gif, bmp
.Execute
For i = 1 To .FoundFiles.Count
With ActiveSheet
Set p = .Pictures.Insert(Application.FileSearch.FoundFiles(i))
.DrawingObjects(p.Name).Left = .Columns("B").Left
.DrawingObjects(p.Name).Top = .Rows(ii).Top
.DrawingObjects(p.Name).Width = .Columns("C").Left - .Columns("B").Left
.DrawingObjects(p.Name).Height = .Rows(ii + 1).Top - .Rows(ii).Top
.DrawingObjects(p.Name).Placement = xlMoveAndSize
.DrawingObjects(p.Name).PrintObject = True
End With
Exit For
Next i
End With
End If
Next c
Application.ScreenUpdating = True
End SubPublic Dossier As String
Sub enfin_j_y_arrive()
Dim p As Picture
Dim i As Integer
Dim ii As Integer
Dossier = 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 = "*.gif;*.jpg;*.jpeg;*.bmp"
.MatchTextExactly = False
.SearchSubFolders = False
.Execute
ii = 0
ActiveSheet.DrawingObjects.Delete
ActiveSheet.Cells.Clear
For i = 1 To .FoundFiles.Count
ii = ii + 1
ActiveSheet.Cells(i, 1) = Left(Mid(.FoundFiles(i), Len(Dossier) + 2), Len(Mid(.FoundFiles(i), Len(Dossier) + 2)) - 4)
With ActiveSheet
Set p = .Pictures.Insert(Application.FileSearch.FoundFiles(i))
.DrawingObjects(p.Name).Left = .Columns("B").Left
.DrawingObjects(p.Name).Top = .Rows(ii).Top
.DrawingObjects(p.Name).Width = .Columns("C").Left - .Columns("B").Left
.DrawingObjects(p.Name).Height = .Rows(ii + 1).Top - .Rows(ii).Top
.DrawingObjects(p.Name).Placement = xlMoveAndSize
.DrawingObjects(p.Name).PrintObject = True
End With
Next i
End With
Application.ScreenUpdating = True
End SubPublic Dossier As String
Sub enfin_j_y_arrive()
Dim p As Picture
Dim i As Integer
Dim ii As Integer
Dim iii As Integer
Dossier = "p:\" '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
ActiveSheet.DrawingObjects.Delete
ActiveSheet.Cells.Clear
For i = 1 To .FoundFiles.Count
ii = ii + 2
iii = iii + 3
ActiveSheet.Cells(i + ii, 1) = Left(Mid(.FoundFiles(i), Len(Dossier) + 1), Len(Mid(.FoundFiles(i), Len(Dossier) + 2)) - 3)
With ActiveSheet
Set p = .Pictures.Insert(Application.FileSearch.FoundFiles(i))
.DrawingObjects(p.Name).Left = .Columns("c").Left
.DrawingObjects(p.Name).Top = .Rows(iii).Top
.DrawingObjects(p.Name).Width = .Columns("e").Left - .Columns("c").Left
.DrawingObjects(p.Name).Height = .Rows(iii + 3).Top - .Rows(iii).Top
.DrawingObjects(p.Name).Placement = xlMoveAndSize
.DrawingObjects(p.Name).PrintObject = True
End With
Next i
End With
Application.ScreenUpdating = True
End Sub
