Application.FileDialog(msoFileDialogFolderPicker) / help

Version imprimable

Bonjour,
J'ai ce code qui fonctionne très bien (récupération partiel sur le net).
Mais je souhaiterais pouvoir :
- sélectionner plusieurs dossiers et non un seul
- que le code prenne les sous folders également

Merci pour votre aide

Code:

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
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
Dim fd As FileDialog
 
Dim vrtSelectedItem As Variant
'Définit le répertoire pour débuter la recherche de fichiers
SRC = vrtSelectedItem
 
'**********
 
'Declare a variable as a FileDialog object
 
 
 'Create a FileDialog object as a Folder Picker dialog box.
 Set fd = Application.FileDialog(msoFileDialogFolderPicker)
 
 'Declare a variable to contain the path
 'of each selected item. Even though the path is aString,
 'the variable must be a Variant because For Each...Next
 'routines only work with Variants and Objects.
 
 'Use a With...End With block to reference the FileDialog object.
 With fd
 
 'Set the initial path to the C:\ drive.
 .InitialFileName = ""
 
 'Use the Show method to display the File Picker dialog box and return the user's action.
 'If the user presses the button...
 If .Show = -1 Then
 
 'Step through each string in the FileDialogSelectedItems collection.
 For Each vrtSelectedItem In .SelectedItems
 SRC = vrtSelectedItem & "\"
 Debug.Print SRC
 Next vrtSelectedItem
 
 'If the user presses Cancel...
 Else
 End If
 End With
 
 'Set the object variable to Nothing.
 Set fd = Nothing
 
 
    '************
    TABLE = "Loonkostgegeven"
    EXT = ".mdb"
 
    Set WK = ThisWorkbook
    Set WS = WK.Worksheets("Feuil1")
    DL = WS.Range("A" & Rows.Count).End(xlUp).Row + 1
    Debug.Print DL
    With WS
        .Range("A2:AD" & DL).ClearContents
    End With
 
 
    FILE = Dir(SRC & "*" & EXT)
 
    While FILE <> ""
 
        Set DbExt = OpenDatabase(SRC & FILE)
        Application.StatusBar = "Import_" & FILE
        Debug.Print SRC & FILE
'        SQL = "select * from & NOM"
'        Set rs = DbExt.OpenRecordset(SQL, dbOpenSnapshot)
        Set rs = DbExt.OpenRecordset(TABLE, dbOpenTable)
        DL = WS.Range("A" & Rows.Count).End(xlUp).Row + 1
        Debug.Print DL
        WS.Range("A" & DL).CopyFromRecordset rs
 
        Set rs = Nothing
        DbExt.Close
        Set DbExt = Nothing
        FILE = Dir
        Application.StatusBar = False
 
    Wend

19/06/2024, 09h18
jurassic pork

Hello,
Apparemment on ne peut pas sélectionner plusieurs éléments pour les dossiers :

Citation:

expression.AllowMultiSelect
expression A variable that represents a FileDialog object.

This property has no effect on Folder Picker dialog boxes or SaveAs dialog boxes because users should never be able to select multiple files in these types of file dialog boxes.

Ami calmant, J.P
19/06/2024, 09h26
rossemma

merci

et pour les sous folders ?

Salut,

Pour les sous dossiers, une fonction récursive fera l'affaire.
Par contre, le code que tu as repiqué ne peut faire l'affaire, du simple fait que non seulement il permet de sélectionner un dossier, mais également ouvrir, lire une une base de données et écrire dans le classeur (soit 3 truc de trop),
ce qui ne respecte pas le SRP: https://en.wikipedia.org/wiki/Single...lity_principle

On va commencer par diviser en 2 fonction pour répondre à ta demande:
Une fonction qui récupère le dossier de base,
une fonction qui récupère la liste des sous-dossiers:

Code:

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
26
27
28
29
30
31
32
33
34
35
36
Public Function OpenFolder() As String
    Dim Dlg As Office.FileDialog
    Set Dlg = Application.FileDialog(msoFileDialogFolderPicker)
 
    Dlg.AllowMultiSelect = True
    If (Dlg.Show) Then
        OpenFolder = Dlg.SelectedItems(1)
    End If
End Function
 
Public Sub GetFolders(ByVal Folder As Object, ByRef Folders As Collection)
    Dim SubFolder As Object     '// Scripting.Folder
    For Each SubFolder In Folder.SubFolders
        Folders.Add SubFolder.Path
    Next
End Sub
 
Public Sub Test()
    Dim Path As String
    Path = OpenFolder
 
    If (Path <> vbNullString) Then
        Dim Folders As Collection
        Set Folders = New Collection
        Folders.Add Path
 
        Dim Fso As Object       '// Scripting.FileSystemObject
        Set Fso = CreateObject("Scripting.FileSystemObject")
        GetFolders Fso.GetFolder(Path), Folders
 
        Dim Item As Variant
        For Each Item In Folders
            Debug.Print Item
        Next
    End If
End Sub