Création d'une boucle pour importer des images

Bonjour à tous,

Je suis un nouveau membre et novice concernant le langage VBA.

Voici mon problème :

Je souhaite importer une image issue d'un répertoire sur une feuille Excel et répéter cette action autant de fois que de fichiers présents dans mon répertoire.

Pour chaque fichier importé (ici une image), une nouvelle feuille s'ouvre avec une mise en page identique pour toutes les feuilles. De plus, le nom de la feuille prend celui du fichier importé.

J'ai réussi à faire ce codage mais certains de mes répertoires contiennent énormément de fichiers.

D'où la nécessitée de créer une boucle mais je ne sais pas comment la créer (malgres les cours présents sur le site et la lecture de différentes discutions sur le forum)

Voici le codage pour un import de fichier :

Sub Importation_photos()
'
' Importation_photos Macro
' Création de classeurs avec photos HMI
'

'
'feuille 1'

   Sheets("Feuil1").Select
    Sheets("Feuil1").Name = "Amenee"
    Selection.ColumnWidth = 0.83
    ActiveCell.Rows("1:1").EntireRow.Select
    Selection.RowHeight = 7.5
    Range("B2").Select
    ActiveSheet.Pictures.Insert( _
        "P:\Documentations techniques\Combibloc\ACB\Paramètres_HMI\Amenee.JPG").Select
    Columns("M:M").ColumnWidth = 31.14
    Range("M2").Select
    ActiveCell.FormulaR1C1 = "Paramètres modifiés"
    Range("M2").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Selection.Font.Size = 12
    Selection.Font.Bold = True
    Columns("N:N").ColumnWidth = 14.43
    Range("N2").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Selection.Font.Size = 12
    Selection.Font.Bold = True
    ActiveCell.FormulaR1C1 = "Date"
    Range("N3").Select
ActiveSheet.Shapes.Range(Array("Picture 2")).Select
    Selection.ShapeRange.ScaleWidth 1.0147058824, msoFalse, msoScaleFromTopLeft
    Selection.ShapeRange.ScaleHeight 1.0147058824, msoFalse, msoScaleFromTopLeft
    Range("M2:N32").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    Range("M2:N2").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorDark2
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With

End Sub

Merci.

Bonjour Xavier !

Voilà une procédure qui compte le nombre de fichiers contenus dans un répertoire !:

Sub cpt()
    Dim Fichier As String, NbFic As Integer

    NbFic = 0

    Fichier = Dir("C:\Users\elbmar09\Desktop\Test_Xavier\")

    Do While Fichier <> ""

      NbFic = NbFic + 1

      Fichier = Dir

    Loop

    MsgBox NbFic

End Sub

Attention, il faut éviter les espaces dans les noms de fichier et préférer les underscore, sinon la macro marche pas bien !

Bonsoir,

Merci de votre réponse, je mets de côté cette boucle qui me servira :)

Par contre, mon problème n'est pas là.

Je dois créer une boucle qui va me permettre d'aller chercher chaque fichier d'un répertoire (dans mon cas, des fichiers .png) et chaque fichier (image) doit être ouvert individuellement dans une feuille Excel (une image par feuille). Et, si possible, nommer automatiquement le nom de chaque feuille par le fichier qui y est intégré.

bonsoir,

voilà la partie "boucle" (avec le même problème d'espace !)

Sub Tous_Les_Images()
     mypath = "P:\Documentations techniques\Combibloc\ACB\Paramètres_HMI\"     'votre directory
     mypath = Environ("USERPROFILE") & "\Downloads\"     'mon directory pour tester

     myfiles = Split(Replace(CreateObject("wscript.shell").Exec("cmd /c Dir """ & mypath & "*""/b").StdOut.ReadAll, ".xlsm", ""), vbCrLf)     'array avec tous les files
     For Each ext In Array("png", "jpg", "bmp", "jpeg", "img")    'toute sorte des images
          fl = Filter(myfiles, "." & ext, 1, vbTextCompare)     'filter un catégorie d'images
          If UBound(fl) > -1 Then     'il y a des images comme-cà
               For i = 0 To Application.Min(9, UBound(fl))     'montre les 10 premiers
                    If StrComp(Right(fl(i), Len(ext)), ext, vbTextCompare) = 0 Then MsgBox fl(i)
               Next
          End If
     Next
End Sub

je sais qu'on peux utiliser PQ pour faire le même truc, mais je ne suis pas expert là-dedans.

Bonjour,

J'ai essayé la boucle mais un débogage apparaît sur cette ligne (avec le message "accès refusé") :

myfiles = Split(Replace(CreateObject("wscript.shell").Exec("cmd /c Dir """ & mypath & "*""/b").StdOut.ReadAll, ".xlsm", ""), vbCrLf) 'array avec tous les files

J'ai cherché l'erreur avec l'aide des fonctions mais impossible de résoudre le problème.

boonjour,

J'ai cherché l'erreur avec l'aide des fonctions mais impossible de résoudre le problème. >>> voilà la partie "boucle" (avec le même problème d'espace !)

méthode classique et la partie entre "do while ... loop", il faut l'adapter à vos besoins.

Sub Boucle_Des_Images()
     Application.ScreenUpdating = False
     t = Timer
     mypath = "P:\Documentations techniques\Combibloc\ACB\Paramètres_HMI\"     'votre repertoire
     mypath = Environ("USERPROFILE") & "\Downloads\"     'mon repertoire pour tester

     For Each ext In Array("png", "jpg", "bmp", "jpeg", "img")    'toute sorte des images
          Set sh = Sheets(CStr(ext))     'une feuille
          With sh
               .Activate
               Effacer_Images     'effacer tous les images dans cette feuille
               With .Cells
                    .ClearContents     'vider la feuille
                    .ColumnWidth = 40     'adjuste width & height of colonnes et lignes
                    .RowHeight = 200
               End With

               ptr = 0     'pointer
               myfile = Dir(mypath & "*." & ext)     'filtrer les files du type EXT
               Do While myfile <> ""     'boucle jusqu'aux tous files sont traités
                    s = mypath & myfile 'fullname
                    If ptr Mod 10 = 0 Then Application.StatusBar = sh.Name & "    " & ptr: DoEvents: DoEvents 'montrer progrès sur statusbar
                    ptr = ptr + 1 'augmente pointer
                    ligne = (ptr - 1) \ 10 + 1 'ligne pour l'image
                    col = (ptr - 1) Mod 10 + 1 'colonne pour l'image
                    Set c = .Cells(ligne, col) 'mettez l'image dans cette cellule
                    lft = c.Left + 2 'gauche de l'image
                    tp = c.Top + 2 'top de l'image
                    wdth = c.Offset(, 1).Left - c.Left - 5 'largeur de l'image
                    hgth = c.Offset(1).Top - c.Top - 5 'hauteur de l'image
                    .Shapes.AddPicture s, 1, 1, lft, tp, wdth, hgth 'add image
                    c.Value = s 'nom de l'image
                    DoEvents: DoEvents 'ralentir le système
                    myfile = Dir 'prochaine file
               Loop
          End With
     Next

     Application.ScreenUpdating = True
     Application.StatusBar = ""

     MsgBox "prêt : " & Format(Timer - t, "0.00\s")
End Sub

Sub Effacer_Images()
     With ActiveSheet
          For i = .Shapes.Count To 1 Step -1
               .Shapes(i).Delete
          Next
     End With
End Sub

Bonjour,

Voici ce que je cherche à faire :

Sub Importimagesversfeuilles()

    sh = Sheet
    rg = Range
    mypath = "P:\Documentations_techniques\aaa\bbb\ccc"
    f = fichier lambda inclut dans le répertoire

    For Each f In mypath
    'J'ouvre une nouvelle feuille
    'Je vérifie que le fichier je j'importe est bien au format image ("png", "jpg", "bmp", "jpeg", "img") dans le répertoire source
    'Si oui je place l'image en "Range(B2)" dans la feuille que je viens d'ouvrir
    'J'intègre ma mise en page en enregistrant une macro
    'Je nomme la feuille par "ccc"
    'Renouveler ce travail jusqu'au dernier fichier du répertoire
    Next
End Sub
    

J'essaie mais en vain...

Quelqu'un aurait-il un code à proposer ?

Sub Boucle_Des_Images()
     Application.ScreenUpdating = False
     t = Timer
     mypath = "P:\Documentations techniques\Combibloc\ACB\Paramètres_HMI\"     'votre repertoire
     'mypath = Environ("USERPROFILE") & "\Downloads\"     'mon repertoire pour tester

     For Each ext In Array("png", "jpg", "bmp", "jpeg", "img")    'toute sorte des images
          ptr = ptr + 1
          If ptr Mod 10 = 0 Then Application.StatusBar = ptr: DoEvents      'montrer progrès sur statusbar

          myfile = Dir(mypath & "*." & ext)     'filtrer les files du type EXT
          Do While myfile <> ""     'boucle jusqu'aux tous files sont traités
               s = mypath & myfile     'fullname
               Worksheets.Add after:=Worksheets(Worksheets.Count)
               On Error Resume Next
               ActiveSheet.Name = Left(Trim(myfile), 30)     'max nombre de charactères !!!!
               On Error GoTo 0
               Set c = Range("B2")     'mettez l'image dans cette cellule
               lft = c.Left + 2     'gauche de l'image
               tp = c.Top + 2     'top de l'image
               wdth = -1     'c.Offset(, 1).Left - c.Left - 5     'largeur de l'image
               hgth = -1     'c.Offset(1).Top - c.Top - 5     'hauteur de l'image
               ActiveSheet.Shapes.AddPicture s, 1, 1, lft, tp, wdth, hgth     'add image
               Range("A1").Value = s     'nom de l'image
               DoEvents: DoEvents     'ralentir le système
               MsgBox "maintenant encore un macro de Xavier_09", vbInformation, myfile

               myfile = Dir     'prochaine file
          Loop
     Next

     Application.ScreenUpdating = True
     Application.StatusBar = ""

     MsgBox "prêt : " & Format(Timer - t, "0.00\s")
End Sub

Salut,

Le code fonctionne bien, c'est ce que je cherchais, bien joué ;)

Par contre, le code télécharge que les images de mon dossier "Téléchargements" !!! J'ai remplacé "\Dowloads\" par mon répertoire source "P:\Documentations_techniques\Combibloc\ACB\Paramètres_HMI\" mais il ne télécharge plus rien...

Avec ce code ça fonctionne :

Sub Boucle_Des_Images()
     Application.ScreenUpdating = False
     t = Timer
     mypath = "P:\Documentations_techniques\Combibloc\ACB\Paramètres_HMI\"     'votre repertoire

     For Each ext In Array("png", "jpg", "bmp", "jpeg", "img")    'toute sorte des images
          ptr = ptr + 1
          If ptr Mod 10 = 0 Then Application.StatusBar = ptr: DoEvents      'montrer progrès sur statusbar

          myfile = Dir(mypath & "*." & ext)     'filtrer les files du type EXT
          Do While myfile <> ""     'boucle jusqu'aux tous files sont traités
               s = mypath & myfile     'fullname
               Worksheets.Add after:=Worksheets(Worksheets.Count)
               On Error Resume Next
               ActiveSheet.Name = Left(Trim(myfile), 30)     'max nombre de charactères !!!!
               On Error GoTo 0
               Set c = Range("B2")     'mettez l'image dans cette cellule
               lft = c.Left + 2     'gauche de l'image
               tp = c.Top + 2     'top de l'image
               wdth = -10     'c.Offset(, 1).Left - c.Left - 5     'largeur de l'image
               hgth = -10     'c.Offset(1).Top - c.Top - 5     'hauteur de l'image
               ActiveSheet.Shapes.AddPicture s, 1, 1, lft, tp, wdth, hgth     'add image
               Range("A1").Value = s     'nom de l'image
               DoEvents: DoEvents     'ralentir le système
               MsgBox "maintenant encore un macro de Xavier_09", vbInformation, myfile

               myfile = Dir     'prochaine file
          Loop
     Next

     Application.ScreenUpdating = True
     Application.StatusBar = ""

     MsgBox "prêt : " & Format(Timer - t, "0.00\s")
End Sub

Comment fait-on pour modifier la taille des images importées ?

Merci pour toutes ces informations, ça va me facilité la vie au travail

avec width and height = -1, vous ne definiez pas leur dimensions, mais si vous leur donnez un vrai valeur ..., donc changez ce -1 en 50 pour commencer

  wdth = -1        'largeur de l'image
  hgth = -1         'hauteur de l'image
ActiveSheet.Shapes.AddPicture s, 1, 1, lft, tp, wdth, hgth     'add image

Trouvé : il faut partir dans les positifs sur "wdth" et "hgth"

Merci

Peut-on, avec le langage VBA, insérer un tableau avec les liens hypertextes de toutes les feuilles crées avec la macro du dessus ? car je remarque que la "Feuil1" est toujours présente donc autant l'utiliser pour une meilleure navigation

le macro pour tous les noms

Sub Contenu()
     Set dict = CreateObject("scripting.dictionary")     'cahier de brouillon
     For Each ws In ThisWorkbook.Worksheets     'boucle toutes les feuilles
          dict(ws.Name) = Empty     'ajouter nom au cahier de brouillon
     Next

     With Sheets("feuil1").ListObjects(1)     '1ier tableau dans Feuil1
          If .ListRows.Count Then .DataBodyRange.Delete     'vider s'il n'est pas vide
          If dict.Count Then .ListRows.Add.Range.Range("A1").Resize(dict.Count).Value = Application.Transpose(dict.keys)     'ajouter tous les nom trouvés
          With .Range     'tout le tableau
               .EntireColumn.AutoFit     'ajuster colonne largeur
               .Sort .Range("A1"), Header:=xlYes     'sorter alphabetique----> mettez un ' our REM en face de cette ligne pour la bloquer
          End With
     End With
End Sub

Puis si vous "DoubleClick" sur une de ces cellules du tableau (pas un hypertexte vrai), ce macro saute vers cette feuille. (dans le VBA module de la feuil1)

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
     If Intersect(Target, Me.ListObjects(1).DataBodyRange) Is Nothing Then Exit Sub
     Cancel = True
     Application.Goto Sheets(Target.Value).Range("A10"), 1
End Sub

et finallement, si vous "DoubleClick" dans cellule A1 de n'importe quelle feuille, vour retourner vers A1 de feuil1 (dans Thisworkbook)

Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
     If Target.Address <> "$A$1" Then Exit Sub
     Cancel = True
     Application.Goto Sheets("feuil1").Range("A1")
End Sub

j"ajoute le fichier, mais ce n'est pas la dernière version de l'autre macro, donc c'est plutot comme exemple

Salut,

Je viens de tester, ça fonctionne ! Merci pour ton aide ;)

merci pour votre reponse.