Forum - Problèmes liés à mes codes mis à disposition - Alternative à la fonction Dir2Table
le 17/03/2018 : 15:33
par robH
visiteur
Bonjour à tous,
La fonction Dir2Table ne fonctionne plus après Access 2007 (Application.FileSearch plus supporté).
Citation : « http://allenbrowne.com/ser-59.html & https://www.techonthenet.com/access/functions/file/filelen.php »
Après quelques recherche j'ai trouvé ceci : http://allenbrowne.com/ser-59.html et https://www.techonthenet.com/access/functions/file/filelen.php
Sur base de ces deux article et la philosophie de la fonction Dir2Table je vous propose l'adaptation suivante qui visiblement fonctionne très bien sur la version 2016
Les paramètres :
strPath : le répertoire à scanner et importer dans la table strTableName : Le nom de votre table strTblFieldName : Le champs qui recevra le nom des fichiers strTblFieldLength : Le champs qui recevra la taille des fichiers strFileSpec : Filtré le fichiers à remonté (ex "*.pdf" pour ne remonté que les fichier PDF, si non préciser remonte tout les fichiers) bIncludeSubfolders : True/False, inclure les sous répertoire dans le scan
Public Function ListFiles(strPath As String, strTableName As String, strTblFieldName As String, strTblFieldLength As String, Optional strFileSpec As String, Optional bIncludeSubfolders As Boolean) On Error GoTo Err_Handler 'Purpose: List the files in the path. 'Method: FilDir() adds items to a collection, calling itself recursively for subfolders. Dim colDirList As New Collection Dim varItem As Variant Call FillDir(colDirList, strPath, strFileSpec, bIncludeSubfolders) 'Add the files to table. For Each varItem In colDirList CurrentDb.Execute "INSERT INTO [" & strTableName & "] " _ & "([" & strTblFieldName & "]," _ & "[" & strTblFieldLength & "])" _ & "SELECT """ & varItem & """," _ & FileLen(varItem) & ";" Next Exit_Handler: Exit Function Err_Handler: MsgBox "Error " & Err.Number & ": " & Err.Description Resume Exit_Handler End Function Private Function FillDir(colDirList As Collection, ByVal strFolder As String, strFileSpec As String, _ bIncludeSubfolders As Boolean) 'Build up a list of files, and then add add to this list, any additional folders Dim strTemp As String Dim colFolders As New Collection Dim vFolderName As Variant 'Add the files to the folder. strFolder = TrailingSlash(strFolder) strTemp = Dir(strFolder & strFileSpec) Do While strTemp <> vbNullString colDirList.Add strFolder & strTemp strTemp = Dir Loop If bIncludeSubfolders Then 'Build collection of additional subfolders. 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 'Call function recursively for each subfolder. For Each vFolderName In colFolders Call FillDir(colDirList, strFolder & TrailingSlash(vFolderName), strFileSpec, True) Next vFolderName End If 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
Rectifier message Clôturer sujet Remonter