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