[Source] Algoritmos de busquedas

Pues en el Fire AV/FW-Killer tenía que diseñar un code que me buscara archivos dentro de una carpeta...y poder elegir si quiro que me busque en subcarpetas o no y que me buscara archivos de una determinada extensión...

Si alguien quiere que lo revise y lo corrija...yo pienso que funciona bien pero no se a lo mejor tiene algun error...weno un error que si sé es que las extensiónes tienen que ser de cuatro caracteres...es decir ".exe" o ".bat" y una ".XXXX" no funcionaría...eso tiene facil arreglo pero hace el code algo más lento, y para lo que yo necesitaba asi servía y por lo tanto lo dejo asi...

Para llamar a la función sería asi:

Código

BuscarArchivos(ByVal ruta_en_la_que_buscar As String, ByRef array_con_extensiones() As String, ByVal buscar_en_subdirectorios? As Boolean)

Un ejemplo de como llamar a la función sería de esta forma:

Código

Private Sub Loquequieras()
Dim ext(0 To 5) As String
Dim files() As String
Dim i as Long
ext(0) = ".exe"
ext(1) = ".com"
ext(2) = ".scr"
ext(3) = ".bat"
ext(4) = ".cmd"
ext(5) = ".pif"
files = BuscarArchivos("C:\Archivos de programa", ext, True)
If files(0) = "" Then
  MsgBox "No se han encontrado archivos", vbCritical
Else
  For i = LBound(files) to UBound(files)
      MsgBox files(i), vbInformation
  Next i
End If
End Sub

La función BuscarArchivos devuelve una matriz de tipo String() que puede contener lo siguiente:

Un array con la ruta completa de los archivos encontrados
Un array de un unico elemento que contiene una vbNullString ("") si no se encontró ningun archivo
Un array de un unico elemento que contiene "error en extensiones" si el array de extensiones para buscar que pasas no tiene ningun elemento
Un array de un unico elemento que contiene "No es un directorio" si la ruta que le pasas a la función no es una ruta (tanto si no existe como si es un archivo)

aqui el code:

Código

Option Explicit
 
Public Function BuscarArchivos(ByVal sDir As String, ByRef exten() As String, ByVal subDirs As Boolean) As String()
Dim sFile As String
Dim tmpsFiles() As String
Dim sFiles() As String, sDirs() As String
Dim counD As Long, counF As Long
Dim coun As Long
Dim ext As String
Dim Lext As Long, Uext As Long, UBsFilestmp As Long
Dim i As Long, a As Long, o As Long
ReDim sFiles(0) As String
On Error Resume Next
Lext = LBound(exten)
If Err.Number = 9 Then
    sFiles(0) = "error en extensiones"
    BuscarArchivos = sFiles
    Exit Function
End If
Uext = UBound(exten)
  If IsDir(sDir) Then
    sDir = sDir & IIf(Not Right$(sDir, 1) Like "\", "\", vbNullString)
    sFile = Dir(sDir, 55)
    ext = LCase(Right(sFile, 4))
    Do
      If (Not sFile Like ".") And (Not sFile Like "..") Then
        If IsDir(sDir & sFile) Then
            ReDim Preserve sDirs(0 To counD) As String
            sDirs(counD) = sDir & sFile
            counD = counD + 1
        Else
            For i = Lext To Uext
                If exten(i) = ext Then
                    ReDim Preserve sFiles(0 To counF) As String
                    sFiles(counF) = sDir & sFile
                    counF = counF + 1
                    Exit For
                End If
            Next i
        End If
      End If
 
      sFile = Dir
      ext = LCase(Right(sFile, 4))
    Loop While sFile <> vbNullString
    If subDirs And (counD > 0) Then
        For a = 0 To counD - 1
            tmpsFiles = BuscarArchivos(sDirs(a), exten, True)
            If tmpsFiles(0) <> "" Then
                If sFiles(0) <> "" Then UBsFilestmp = UBound(sFiles) Else UBsFilestmp = -1
                ReDim Preserve sFiles(0 To UBsFilestmp + UBound(tmpsFiles) + 1) As String
                For o = LBound(tmpsFiles) To UBound(tmpsFiles)
                    sFiles(UBsFilestmp + 1 + o) = tmpsFiles(o)
                Next o
            End If
        Next a
    End If
  Else
    sFiles(0) = "No es un directorio"
    BuscarArchivos = sFiles
  End If
  BuscarArchivos = sFiles
End Function
 
Private Function IsDir(ByVal DirSpec As String) As Boolean
  On Error Resume Next
  IsDir = ((GetAttr(DirSpec) And vbDirectory) = vbDirectory)
End Function

Hice otro ejemplo de lo mismo pero usando APIs...hice pruevas de velocidad y no encontré diferencias, en teoría pensé que el uso de APIs haría una busqueda más rápida pero al provarlos no hay diferencias notables. El code es este:

Código

Option Explicit
 
Private Type FILETIME
    dwLowDateTime As Long
    dwHighDateTime As Long
End Type
 
Private Const MAX_PATH = 260
Private Const INVALID_HANDLE_VALUE = -1
 
Private Type WIN32_FIND_DATA
        dwFileAttributes As Long
        ftCreationTime As FILETIME
        ftLastAccessTime As FILETIME
        ftLastWriteTime As FILETIME
        nFileSizeHigh As Long
        nFileSizeLow As Long
        dwReserved0 As Long
        dwReserved1 As Long
        cFileName As String * MAX_PATH
        cAlternate As String * 14
End Type
 
Private Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" (ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long
 
Public Function BuscarArchivos(ByVal path As String, ByRef ext() As String, ByVal WithSubfolders As Boolean) As String()
Dim res As Boolean
Dim hFindFile As Long
Dim lpFindFileData As WIN32_FIND_DATA
ReDim sDirs(0 To 0) As String
ReDim tmparchivos(0 To 0) As String
ReDim archivos(0 To 0) As String
Dim coun As Long, coun2 As Long
Dim tmp As String, tmpL As Long
Dim i As Long, j As Long
Dim LB As Long, UB As Long
Dim exten As String
On Error Resume Next
LB = LBound(ext)
If Err.Number = 9 Then
    BuscarArchivos = archivos
    Exit Function
End If
UB = UBound(ext)
For i = LB To UB
    ext(i) = LCase(ext(i))
Next i
If Right(path, 1) <> "\" Then path = path & "\"
If IsDir(path) Then
    hFindFile = FindFirstFile(path & "*", lpFindFileData)
    If hFindFile <> INVALID_HANDLE_VALUE Then
        Do
            tmp = EliminarNull(lpFindFileData.cFileName)
            If IsDir(path & tmp) Then
                If (tmp <> ".") And (tmp <> "..") Then
                    ReDim Preserve sDirs(0 To coun2) As String
                    sDirs(coun2) = path & tmp
                    coun2 = coun2 + 1
                End If
            Else
                exten = LCase(Right(tmp, 4))
                For i = LB To UB
                    If exten = ext(i) Then
                        ReDim Preserve archivos(0 To coun) As String
                        archivos(coun) = path & EliminarNull(lpFindFileData.cFileName)
                        coun = coun + 1
                    End If
                Next i
            End If
            res = FindNextFile(hFindFile, lpFindFileData)
        Loop While res
        FindClose hFindFile
        If WithSubfolders Then
            If sDirs(0) <> vbNullString Then
                For i = 0 To coun2 - 1
                    tmparchivos = BuscarArchivos(sDirs(i), ext, True)
                    If tmparchivos(0) <> vbNullString Then
                        If archivos(0) <> vbNullString Then tmpL = UBound(archivos) + 1 Else tmpL = 0
                        ReDim Preserve archivos(tmpL + UBound(tmparchivos)) As String
                        For j = 0 To UBound(tmparchivos)
                            archivos(tmpL) = tmparchivos(j)
                            tmpL = tmpL + 1
                        Next j
                    End If
                Next i
            End If
        End If
    End If
Else
    archivos(0) = "No es un directorio"
End If
BuscarArchivos = archivos
End Function
Private Function IsDir(ByVal DirSpec As String) As Boolean
    On Error Resume Next
    IsDir = ((GetAttr(DirSpec) And vbDirectory) = vbDirectory)
End Function
 
Private Function EliminarNull(ByVal strName As String) As String
    Dim pos As Long
    pos = InStr(strName, vbNullChar)
    If (pos <> 0) Then strName = Left(strName, pos - 1)
    EliminarNull = strName
End Function

Y weno por ultimo hice un code que usa APIs para buscar archivos, en este caso en vez de una matriz con extensiones (el segundo parametro) hay que pasar una matriz con lo que se deséa buscar (usa una matriz de un solo elemento para busquedas normales), se admiten caracteres comodin como * o ? y la busqueda no es case sensitive. Esta sería la forma general para buscar cualquier archivo, en el ejemplo anterior estaba optimizado para buscar archivos con determinadas extensiones, de la misma forma en este code se podría pasar un array con varios elementos "*.txt", "*.exe" por ejemplo...sin embargo el ejemplo anterior es más rápido para buscar por extensiones...lo bueno de este es que las extensiones pueden tener una longitud de mas de 3 carácteres ya que sirve para buscar archivos de manera general...

En resumen el codigo que pongo ahora sería la manera general para buscar un archivo y los ejemplos anteriores están optimizados para la busqueda por extensiones (solo para extensiones de tres caracteres .XXX) y son más rápidos pero solo para ese tipo de busquedas.

Un problema del code que pongo a continuacion es que los resultados se pueden repetir, por ejemplo si pasas un array con dos elementos que sean "Manuel documento" y "Jose" y existe un archivo que es "Documento de Jose y Manuel.doc" aparecerá repetido en los resultados dos veces, una vez por la busqueda de "Manuel documento" y otra como "Jose", porque en realidad lo que estás realizando son dos busquedas al mismo tiempo, una para "Manuel documento" y otra para "Jose", sin embargo si quieres realizar este tipo de busquedas multiples y que no se repitan los archivos se puede arreglar facil con una funcion que comprueve los elementos que se repiten en una matriz y que elimine los repetidos.

Weno aki el code:

Código

Option Explicit
 
Private Type FILETIME
    dwLowDateTime As Long
    dwHighDateTime As Long
End Type
 
Private Const MAX_PATH = 260
Private Const INVALID_HANDLE_VALUE = -1
 
Private Type WIN32_FIND_DATA
        dwFileAttributes As Long
        ftCreationTime As FILETIME
        ftLastAccessTime As FILETIME
        ftLastWriteTime As FILETIME
        nFileSizeHigh As Long
        nFileSizeLow As Long
        dwReserved0 As Long
        dwReserved1 As Long
        cFileName As String * MAX_PATH
        cAlternate As String * 14
End Type
 
Private Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" (ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long
 
Public Function BuscarArchivos(ByVal path As String, ByRef strFind() As String, ByVal WithSubfolders As Boolean) As String()
Dim res As Boolean
Dim hFindFile As Long
Dim lpFindFileData As WIN32_FIND_DATA
ReDim sDirs(0 To 0) As String
ReDim tmparchivos(0 To 0) As String
ReDim archivos(0 To 0) As String
Dim coun As Long, coun2 As Long
Dim tmp As String, tmpL As Long
Dim i As Long, j As Long
Dim LB As Long, UB As Long
Dim exten As String
On Error Resume Next
LB = LBound(strFind)
If Err.Number = 9 Then
    archivos(0) = "error en parametros de busqueda"
    BuscarArchivos = archivos
    Exit Function
End If
UB = UBound(strFind)
 
If Right(path, 1) <> "\" Then path = path & "\"
 
If IsDir(path) Then
    For i = LB To UB
        hFindFile = FindFirstFile(path & strFind(i), lpFindFileData)
        If hFindFile <> INVALID_HANDLE_VALUE Then
            res = True
            Do
                ReDim Preserve archivos(0 To coun) As String
                archivos(coun) = path & EliminarNull(lpFindFileData.cFileName)
                coun = coun + 1
                res = FindNextFile(hFindFile, lpFindFileData)
            Loop While res
            FindClose hFindFile
        End If
    Next i
 
        hFindFile = FindFirstFile(path & "*", lpFindFileData)
        If hFindFile <> INVALID_HANDLE_VALUE Then
            Do
                tmp = EliminarNull(lpFindFileData.cFileName)
                If IsDir(path & tmp) And (tmp <> ".") And (tmp <> "..") Then
                    ReDim Preserve sDirs(0 To coun2) As String
                    sDirs(coun2) = path & tmp
                    coun2 = coun2 + 1
                End If
                res = FindNextFile(hFindFile, lpFindFileData)
            Loop While res
            FindClose hFindFile
            If WithSubfolders Then
                If sDirs(0) <> vbNullString Then
                    For i = 0 To coun2 - 1
                        tmparchivos = BuscarArchivos(sDirs(i), strFind, True)
                        If tmparchivos(0) <> vbNullString Then
                            If archivos(0) <> vbNullString Then tmpL = UBound(archivos) + 1 Else tmpL = 0
                            ReDim Preserve archivos(tmpL + UBound(tmparchivos)) As String
                            For j = 0 To UBound(tmparchivos)
                                archivos(tmpL) = tmparchivos(j)
                                tmpL = tmpL + 1
                            Next j
                        End If
                    Next i
                End If
            End If
        End If
Else
    archivos(0) = "No es un directorio"
End If
    BuscarArchivos = archivos
End Function
 
Private Function IsDir(ByVal DirSpec As String) As Boolean
    On Error Resume Next
    IsDir = ((GetAttr(DirSpec) And vbDirectory) = vbDirectory)
End Function
 
Private Function EliminarNull(ByVal strName As String) As String
    Dim pos As Long
    pos = InStr(strName, vbNullChar)
    If (pos <> 0) Then strName = Left(strName, pos - 1)
    EliminarNull = strName
End Function

Weno espero que os sirvan de algo y ya sabeis...cualquier comentario, duda o mejora es bienvenida

Saludos