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
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
| Option Compare Database
Option Explicit
'Liste des fichiers dans une table
Dim gCount As Long ' added by Crystal
Sub Thierry()
runListFiles "C", "xlsx", True
End Sub
Sub runListFiles(strPath As String, strFileSpec As String, blnOuiNon As Boolean)
Dim booIncludeSubfolders As Boolean
strPath = strPath & ":\" ' JS
strFileSpec = "*." & strFileSpec
booIncludeSubfolders = True
' ListFilesToTable strPath, strFileSpec, booIncludeSubfolders ' manque le dernier argument
ListFilesToTable strPath, strFileSpec, booIncludeSubfolders, blnOuiNon
End Sub
Public Function ListFilesToTable(strPath As String _
, Optional strFileSpec As String = "*.*" _
, Optional bIncludeSubfolders As Boolean _
, Optional blnOuiNon As Boolean _
)
On Error GoTo Err_Handler
'Purpose: List the files in the path.
'Arguments: strPath = the path to search.
' strFileSpec = "*.*" unless you specify differently.
' bIncludeSubfolders: If True, returns results from subdirectories of strPath as well.
'Method: FilDir() adds items to a collection, calling itself recursively for subfolders.
Dim colDirList As New Collection
Dim varItem As Variant
Dim rst As DAO.Recordset
Call FillDirToTable(colDirList, strPath, strFileSpec, bIncludeSubfolders, blnOuiNon)
Exit_Handler:
SysCmd acSysCmdClearStatus
'--------
Exit Function
Err_Handler:
MsgBox "Error " & Err.Number & ": " & Err.Description, , "ERROR"
'Supprimer cette ligne après débogage
Stop: Resume
Resume Exit_Handler
End Function
Private Function FillDirToTable(colDirList As Collection _
, ByVal strFolder As String _
, strFileSpec As String _
, bIncludeSubfolders As Boolean _
, blnOuiNon)
' Construction de la liste des fichier
On Error GoTo Err_Handler
Dim strTemp As String
Dim colFolders As New Collection
Dim vFolderName As Variant
Dim strSQL As String
strFolder = TrailingSlash(strFolder)
strTemp = Dir(strFolder & strFileSpec)
Do While strTemp <> vbNullString
gCount = gCount + 1
SysCmd acSysCmdSetStatus, gCount
' strSQL = "INSERT INTO tblFiles " _
' & " (FName, FPath) " _
' & " SELECT """ & strTemp & """" _
' & ", """ & strFolder & """;"
' strSQL = "INSERT INTO tblFiles " _
' & " (FName, FPath,Executable) " _
' & " SELECT """ & strTemp & """" _
' & ", """ & strFolder & """" _
' & ", " & CInt(blnOuiNon) & ";"
'Apparement ça marche mieux avec les Alias (nom de champs), notament pour le champ boolean
strSQL = "INSERT INTO tblFiles " _
& " (FName, FPath,Executable) " _
& " SELECT """ & strTemp & """" _
& " AS Expr1, """ & strFolder & """" _
& " AS Expr2, " & CInt(blnOuiNon) & " AS Expr3;"
' Debug.Print strSQL
CurrentDb.Execute strSQL
colDirList.Add strFolder & strTemp
strTemp = Dir
Loop
If bIncludeSubfolders Then
'Construire la collection des sous-dossiers
strTemp = Dir(strFolder, vbDirectory)
Do While strTemp <> vbNullString
If (strTemp <> ".") And (strTemp <> "..") Then
If (GetAttr(strFolder & strTemp) And vbDirectory) <> 0& Then
colFolders.Add strTemp
End If
End If
strTemp = Dir
Loop
'Appel de la fonction récursive pour les sous-dossiers
For Each vFolderName In colFolders
Call FillDirToTable(colDirList, strFolder & TrailingSlash(vFolderName), strFileSpec, True, blnOuiNon)
Next vFolderName
End If
Exit_Handler:
Exit Function
Err_Handler:
If Err.Number = 52 Then
strSQL = "INSERT INTO tblFiles " _
& " (FName, FPath) " _
& " SELECT "" ~~pas d'autorisation sur le dossier ?~~""" _
& ", """ & strFolder & """;"
CurrentDb.Execute strSQL
Resume Exit_Handler
Else
strSQL = "INSERT INTO tblFiles " _
& " (FName, FPath) " _
& " SELECT "" ~~~ ERROR ~~~""" _
& ", """ & strFolder & """;"
CurrentDb.Execute strSQL
Resume Exit_Handler
End If
' Resume Exit_Handler
End Function
Public Function TrailingSlash(varIn As Variant) As String
If Len(varIn) > 0& Then
If Right(varIn, 1&) = "\" Then
TrailingSlash = varIn
Else
TrailingSlash = varIn & "\"
End If
End If
End Function |
Besoin d'aide pour modifier une fonction
Répondre avec citation
Partager