Recherche dans Dossier et sous dossierRésolu

Question

Bijour,
Je d&#233;veloppe actuellement une appli et je souhaiterais que l'utilisateur puisse s&#233;lectionner un dossier et ensuite recherche tous les dossiers d'un certain type (ex : "*.doc") ou en recherchant un mot dans tous les fichiers et sous-dossiers.
En gros, cela ressemble &#224; ce que l'on peut trouver sous windows en faisant rechercher (ou ctrl + F).

Je remercie les bonnes &#226;mes m'aidant dans ma recherche.

cs_DPhBxl · Accepted Answer

Voici un code interessant :

Corp du programme:

    'Choix du r&#233;pertoire de d&#233;part
    strFolderStart = funcFolderStart()
    
    'Recherche des fichiers et sous r&#233;pertoires
    subFolderFileScan strFolderStart

Fonction:
'***************************************************************************************
' Project   : Link
'***************************************************************************************
' Module    : FolderStart
' DateTime  : 25/05/2005 11:07
' Author    : FFH173
' Purpose   : Selection du r&#233;pertoire de d&#233;part
'***************************************************************************************


Private Type BrowseInfo
    hWndOwner As Long
    pIDLRoot As Long
    pszDisplayName As Long
    lpszTitle As Long
    ulFlags As Long
    lpfnCallback As Long
    lParam As Long
    iImage As Long
End Type


Const BIF_RETURNONLYFSDIRS = 1
Const MAX_PATH = 260


Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long)
Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long


'---------------------------------------------------------------------------------------
' Procedure : funcFolderStart
' DateTime  : 24/05/2005 16:26
' Author    : FFH173
' Purpose   : Selection du r&#233;pertoire de d&#233;part
'---------------------------------------------------------------------------------------


Public Function funcFolderStart() As String


    Dim iNull As Integer
    Dim lpIDList As Long
    Dim lResult As Long
    Dim strPath As String
    Dim udtBI As BrowseInfo
    
    On Error GoTo funcFolderStart_Error


    With udtBI
        'Set the owner window
        .hWndOwner = frmMain.hWnd
        'lstrcat appends the two strings and returns the memory address
        .lpszTitle = lstrcat("C:", "")
        'Return only if the user selected a directory
        .ulFlags = BIF_RETURNONLYFSDIRS
    End With


    'Show the 'Browse for folder' dialog
    lpIDList = SHBrowseForFolder(udtBI)
    If lpIDList Then
        strPath = String$(MAX_PATH, 0)
        'Get the path from the IDList
        SHGetPathFromIDList lpIDList, strPath
        'Free the block of memory
        CoTaskMemFree lpIDList
        iNull = InStr(strPath, vbNullChar)
        If iNull Then
            strPath = Left$(strPath, iNull - 1)
        End If
    End If


    funcFolderStart = strPath


funcFolderStart_Exit:


    On Error GoTo 0


    Exit Function


funcFolderStart_Error:
    MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure funcFolderStart of Module frmMain"
    Resume funcFolderStart_Exit


End Function

'***************************************************************************************
' Project   : Link
'***************************************************************************************
' Module    : FolderFileScan
' DateTime  : 25/05/2005 13:06
' Author    : FFH173
' Purpose   : Recherche des fichiers et sous-r&#233;pertoires dans un r&#233;pertoire de d&#233;part
'***************************************************************************************


Option Explicit


Dim FSO As New FileSystemObject


'---------------------------------------------------------------------------------------
' Procedure : funcFolderFileScan
' DateTime  : 25/05/2005 13:07
' Author    : FFH173
' Purpose   : Recherche des fichiers et sous-r&#233;pertoires dans un r&#233;pertoire de d&#233;part
'---------------------------------------------------------------------------------------


Sub subFolderFileScan(Path As String)


    Dim Folder As Folder
    Dim File As File


    On Error GoTo subFolderFileScan_Error


    'Transformation du string en nom de folder
    Set Folder = FSO.GetFolder(Path)
    
    'Liste de tous les fichiers dans un r&#233;pertoire
    For Each File In Folder.Files
        Select Case Right(File.Name, 3)
            Case "doc", "xls", "ppt", "pfd", "mdb"
                funcLinkScan Folder.Path, File.Name, 1, FreeFile
            Case "xls"
                funcLinkScan Folder.Path, File.Name, 2, FreeFile
            Case "ppt"
                funcLinkScan Folder.Path, File.Name, 3, FreeFile
            Case "pfd"
                funcLinkScan Folder.Path, File.Name, 4, FreeFile
            Case "mdb"
                funcLinkScan Folder.Path, File.Name, 5, FreeFile
        End Select
    Next File
    
    'Liste de tous les sous-r&#233;pertoires dans un r&#233;pertoire et
    'r&#233;cursivit&#233; de la proc&#233;dure pour la recherche sur le niveau suivant
    For Each Folder In FSO.GetFolder(Path).SubFolders
        subFolderFileScan Folder.Path
    Next Folder


subFolderFileScan_Exit:


    On Error GoTo 0


    Exit Sub


subFolderFileScan_Error:
    MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure subFolderFileScan of Module FolderFileScan"
    Resume subFolderFileScan_Exit


End Sub

DPhBxl

nawakator · Answer

Essaye la source http://www.vbfrance.com/code.aspx?ID=4928.
 
( y'a tous et c'est tr&#232;s rapide).

cs_Sweet_7694 · Answer

Merci &#224; vous 2.

Ca marche ! 

@+++ bonne prog

Recherche dans Dossier et sous dossier

3 réponses

Discussions similaires