importer des photos

S

stormless

XLDnaute Junior
bonsoir a tous

Je suis à la recherche d'une macro qui importe toutes les photos d'un répertoire
dans une feuille les unes derrières les autres en les redimensionnent en petit format

merci d'avance de votre aide
 
Trier par date Trier par votes
Staple1600

Staple1600

XLDnaute Barbatruc
Re : importer des photos

Bonsoir


Une ébauche bidouillée (à améliorer)
Code: 
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 Sub

Testé sous Excel 2000.
 
Dernière édition:
Vote positif 0 Vote négatif
S

stormless

XLDnaute Junior
Re : importer des photos

bonjour staple 1600

deja merci d'avoir lu et passé un peu de temps

malheureusement j'ai office 2007 et j'ai une erreur de compilation ici
" fso As Scripting.FileSystemObject "

mais je vais installé office 2003 quand j'aurai retouvé le cd et ainsi pouvoir tester la macro

encore merci de ton aide et je te tiens au courant

@+
 
Vote positif 0 Vote négatif
Staple1600

Staple1600

XLDnaute Barbatruc
Re : importer des photos

Bonjour


As-tu pensé à faire ce qui était indiqué dans le code


'activer la reference Microsoft scripting Runtime


Dans l'éditeur VBE, Outils/Références

cocher Microsoft scripting Runtime

(enfin cela c'est sous Excel 2000)

Je suppose que c'est différent sous 2007

Personnellement je ne réinstallerai pas 2003 pour simplement tester une macro

Attends que d'autres forumeurs te proposent une solution plus abouti.

Ou utilise la macro ci dessous (dont j'ai un peu honte, mais qui fonctionne
sans faire référence à Microsoft scripting Runtime)

Si tu vois comment éviter le code redondant
n'hésite pas à nous le faire savoir

Code: 
Public 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 Sub
 
Dernière édition:
Vote positif 0 Vote négatif
Staple1600

Staple1600

XLDnaute Barbatruc
Re : importer des photos

Re


Après avoir carburer à la caféine

(je peux maintenant avoir totalement honte)

Voici la macro modifiée et fonctionnelle
Code: 
Public 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 Sub

testée sous XL 2000

En cas de problème, activer la référence à:

Microsoft Excel 9.0 Object Library
Microsoft Office 9.0 Object Library

Pour Excel 2007 je suppose que c'est 12.0

Désolé de pas avoir été efficace en une seule fois.

Bon week-end

PS:
En commentant cette ligne
ActiveSheet.Cells(i, 1) = Left(Mid(.FoundFiles(i), Len(Dossier) + 2), Len(Mid(.FoundFiles(i), Len(Dossier) + 2)) - 4)
Tu n'auras pas les noms des fichiers
Avec celle-ci
ActiveSheet.Cells(i, 1) = FoundFiles(i)
Tu auras le chemin complet et le nom du fichier avec son extenstion


Staple
 
Dernière édition:
Vote positif 0 Vote négatif
S

stormless

XLDnaute Junior
Re : importer des photos

bonsoir a tous et a staple 1600

que dire a part merci beaucoup ;) et good job

j'ai modifier un peu le code tres legerement pour avoir ce que je voulais enfin 99% du taf etait fait par staple

voila encore merci :D:D:D

ci joint le code final

Code: 
Public 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
 
Vote positif 0 Vote négatif
Staple1600

Staple1600

XLDnaute Barbatruc
Re : importer des photos

re

Content d'avoir pu t'aider

Mais le good job n'est pas mien


J'ai juste péniblement (avant mon mug de café)
assembler du code VBA trouvé sur le net


La seule chose à porter à mon seul crédit c'est cette ligne
ActiveSheet.Cells(i, 1) = Left(Mid(.FoundFiles(i), Len(Dossier) + 2), Len(Mid(.FoundFiles(i), Len(Dossier) + 2)) - 4)

Donc merci aux auteurs du reste du code
(et merci aussi à laide VBA)
 
Vote positif 0 Vote négatif
S

stormless

XLDnaute Junior
Re : importer des photos

re

meme si le good job n'est pas le tien, tu as quand meme passé du temps et je t'en remercie encore

autre question toujours sur le meme sujet, comment peut on gerer la compression des images car le fichier fait tres vite des mega's. les photos sont en 200 dpi et avec la compression je peux les passer a 96 dpi.
j'ai fait des essais avec l'enregistreur de macro pour voir la methode a utiliser mais pas concluant

as tu une idée ?
 
Vote positif 0 Vote négatif

Discussions similaires

P
  • Question
XL 2010 INSERTION DES PHOTOS SUR DES PAGES EN FONCTION DE LA VALEUR D'UNE CELLULE
Réponses
2
Affichages
468
Pronzito
P
gaetan.dhe
  • Question
Microsoft 365 Réalisation d'une planche contact par VBA qui font planter excel.
Réponses
7
Affichages
207
gaetan.dhe
gaetan.dhe
P
  • Question
XL 2016 Code vba pour supprimer des images définies a la fermeture du fichier
Réponses
7
Affichages
223
phoceenjo
P
M
  • Question
Microsoft 365 Importer des PDF dans Excel
Réponses
8
Affichages
420
patricktoulon
patricktoulon
R
  • Question
XL 2013 Lien hypertexte - Référence
Réponses
3
Affichages
415
Gégé-45550
Gégé-45550
CISCO
  • Question
Microsoft 365 VBA : Transformer une liste de textes en liens.
Réponses
2
Affichages
254
CISCO
CISCO
H
  • Question
XL 2021 Attribuer une note uniquement aux 3 plus grandes valeurs
2
Réponses
23
Affichages
692
Hamid84
H
C
  • Question
XL 2021 Dernière ligne d'un fichier fermé
Réponses
7
Affichages
201
Chris 33
C
C
  • Résolu(e)
XL 2013 importer des données sans modifier le format des cellules distinataires
Réponses
6
Affichages
271
chindou
C
B
  • Résolu(e)
Power Query récupérer fichier excel toujours de la première à la nième colonne
Réponses
7
Affichages
318
Cousinhub
Cousinhub

Membres actuellement en ligne

12 membres et 121 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 321
Messages
2 087 235
Membres
103 497
dernier inscrit
JP9231