Discussion :

[ouskel'n'or]

Bonjour vous tous nombreux qui fréquentez ce forum le dimanche soir

........................................................1

Je cherche à lister les fichiers d'un répertoire et de ses sous-répertoires en vue de l'insertion de ces fichiers dans une diapositive.
Avec Dir et pour un seul répertoire, (exemple de l'aide en ligne sur Dir à peine modifiée) l'insertion et la répartition des images dans la diapo se fait... les doigts dans le nez !

Le code qui fonctionne :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
Sub InsèreLesFichiersDunRépertoireAvecDirSansProblèmeAucun()
Dim rep As String, NomFich As String, NomRep(), i As Integer, Haut as integer, Gauche as integer
    rep = "C:\Code fluvial\1 - Les Panneaux d'Interdiction\"
    NomFich = Dir(rep)
    Haut = 0
    Gauche = 0
    Do While NomFich <> ""
        Debug.Print rep & NomFich
        ActiveWindow.Selection.SlideRange.Shapes.AddPicture(FileName:=rep & NomFich, LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, Left:=Gauche, Top:=Haut, Width:=175, Height:=79).Select
        With ActiveWindow.Selection.ShapeRange
            .LockAspectRatio = msoFalse
            .Height = 80#
            .Width = 80#
            .Left = Gauche
            .Top = Haut
        End With
        If Gauche < 640 - 80 Then
            Gauche = Gauche + 82
            Else
            Haut = Haut + 82
            Gauche = 0
        End If
        NomFich = Dir()
    Loop
End Sub

........................................................2

Maintenant je liste les répertoires d'un répertoire avec Dir et tente d'insérer toutes les images de ces sous-répertoires (en un premier temps dans une même diapo)
Là, comme j'utilise une procédure paramétrée, Dir perd l'origine et ne liste que le premier sous-répertoire du répertoire principal et buggue pour le second.
Message d'erreur sur Dir() "Argument ou appel de procédure incorrect"

Le code suivant fonctionne donc pour le premier sous-répertoire ***

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
Sub Appel()
Dim Rep As String, NomFich As String, Chemin As String
    Rep = "C:\Code fluvial\"
    NomFich = Dir(Rep, vbDirectory)
    Do While NomFich <> ""
        If NomFich <> "." And NomFich <> ".." Then
            Chemin = Rep & NomFich & "\"
            MsgBox Chemin
            ListerLesFichiersAvecDir Chemin
        End If
        NomFich = Dir() '*** et buggue ici pour le second ***
    Loop
End Sub

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
Sub ListerLesFichiersAvecDir(Rep)
Dim NomFich As String, NomRep(), i As Integer, Haut As Integer, Gauche As Integer
    NomFich = Dir(Rep)
    Haut = 0
    Gauche = 0
    Do While NomFich <> ""
        Debug.Print Rep & NomFich
        ActiveWindow.Selection.SlideRange.Shapes.AddPicture(FileName:=Rep & NomFich, LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, Left:=Gauche, Top:=Haut, Width:=175, Height:=79).Select
        With ActiveWindow.Selection.ShapeRange
            .LockAspectRatio = msoFalse
            .Height = 80#
            .Width = 80#
            .Left = Gauche
            .Top = Haut
        End With
        If Gauche < 640 - 80 Then
            Gauche = Gauche + 82
            Else
            Haut = Haut + 82
            Gauche = 0
        End If
        NomFich = Dir()
    Loop
End Sub

........................................................3

A présent, je liste les répertoires en utilisant FSO et envoie les sous-répertoires en paramètre à la procédure ListerLesFichiersParOrdreAlpha.
Et là, sur la ligne encadrée par des "*" j'ai le message d'erreur "Shapes (unknown member) : Out of memory error" dès le premier fichier.
Je précise que si je supprime cette ligne ou ajoute une gestion d'erreurs, les fichiers de tous les sous-répertoires sont bien listés, leurs chemins sont corrects et complets dans la fenêtre exécution.
D'abord yakatester

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
Sub Appel2()
Dim fs As Scripting.FileSystemObject
Dim Rep As String, Chemin As String, element As Object
    Set fs = New Scripting.FileSystemObject
    Rep = "C:\Code fluvial"
        For Each element In fs.GetFolder(Rep).SubFolders
            Chemin = element.Path
            'Debug.Print Chemin
            ListerLesFichiersParOrdreAlpha Chemin & "\"
        Next element
End Sub

Code corrigé

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
Sub ListerLesFichiersParOrdreAlpha(Chemin)
Dim fs as object, i As Integer, Haut As Integer, Gauche As Integer
    Haut = 0
    Gauche = 0
    Set fs = Application.FileSearch
    With fs
        .LookIn = Chemin
        .FileType = 1
        If .Execute(SortBy:=msoSortByFileName, _
            SortOrder:=msoSortOrderAscending) > 0 Then
            For i = 1 To .FoundFiles.Count
'*******La ligne qui fonctionne maintenant
                ActiveWindow.Selection.SlideRange.Shapes.AddPicture(FileName:=.FoundFiles(i), LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, Left:=Gauche, Top:=Haut, Width:=175, Height:=79).Select
'***************************
            Next i
          Else
            MsgBox "Fichier pas trouvé, cékiennapa."
        End I
    End With
End Sub

Une explication me siérait assez, oui !
A défaut d'une solution

Bref, si vous voyez l'erreur, vous être bien gentil de m'en faire part.
Par avance, merci

PS - J'ai bien sûr une possibilité un peu lourde pour faire fonctionner la solution 2 en créant un tableau des sous-répertoires comme paramétre de la procédure ListerLesFichiersAvecDir mais je trouve pas ça beau et je perds le tri alpha que permet fso simplement.