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:
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:
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:
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:
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:
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
Mostrar Mensajes
