Visual Basic For Application. Objeto "Application.FileSearch" en Office 2007/10

[Aberroncho]

Tengo unas bases de datos de Access con macros en Visual Basic for Application hechas en la versión 2003 de Access. Ahora me he puesto a migrarlas a Access 2010 y me he encontrado con una sorpresa: El objeto "Application.FileSearch" dejó de implementarse en VBA a partir de la versión 2007 de Office.

Para los que no sepáis que hace el objeto, a grandes trazos es un objeto que permite configurar una serie de filtros para buscar ficheros, ejecuta la búsqueda y devuelve la lista de ficheros que cumplen con los criterios elegidos. Puedes, por ejemplo, pedirle la lista de ficheros "*.zip" que están en el directorio "C:\Temp" y que lo haga de forma recursiva buscando por los subdirectorios.

Después de mucho mirar por la ayuda y consultar al gran oráculo Google, descubrí que no sólo ha dejado de implementarse "Application.FileSearch", además su funcionalidad no ha sido sustituida por ningún otro objeto. Si quieres hacerlo tienes que implementarte a mano tu búsqueda de ficheros.

Entre los resultados de Google estaba el código de varios procedimientos para hacer lo mismo, incluido el que Microsoft proporciona en su web de soporte. Después de revisarlos todos y probar alguno, decidí implementar mi propio objeto FileSearch basándome en el procedimiento FileSearch que había implementado un tal Havrda y que yo encontré en http://www.pcreview.co.uk/forums/application-filesearch-error-t3743946p2.html

A continuación os pongo el objeto que he implementado por si alguno os encontráis con este problema en el futuro. La ventaja que tiene este objeto es que tiene un funcionamiento parecido al que tenía "Application.FileSearch" por lo que los cambios en vuestras macros serán menores que si intentáis adaptar un procedimiento de los muchos que encontraréis por Internet.


classError.cls
Objeto que agrupa el código de error y los mensajes que se producen dentro del objeto classFileSearch.

Código (vb) [Seleccionar] Expandir


Option Compare Database
Option Explicit


Public iNumError        As Integer
Public sDonde           As String
Public sMensaSist       As String
Public sMensaApli       As String


Private Sub class_initialize()
   On Error Resume Next
   
   Limpiar
End Sub


Public Sub Limpiar()
   On Error Resume Next

   iNumError = 0
   sDonde = ""
   sMensaSist = ""
   sMensaApli = ""
End Sub

Public Sub Copiar(ByRef oObjOrigen As classError)
   On Error Resume Next

   iNumError = oObjOrigen.iNumError
   sDonde = oObjOrigen.sDonde
   sMensaSist = oObjOrigen.sMensaSist
   sMensaApli = oObjOrigen.sMensaApli
End Sub




classFileSearch.cls
Objeto que realiza la búsqueda de los ficheros. La lista de ficheros encontrados es una colección de objetos "FILE".

Código (vb) [Seleccionar] Expandir


Option Compare Database
Option Explicit


Public oError               As classError       ' Control de errores
Public sDirIniBusqueda      As String           ' Directorio desde el que iniciar la búsqueda de ficheros
Public sPatronBusqueda      As String           ' Patrón de búsqueda de ficheros. Por ejemplo: "*.rar"
Public bBusquedaRecursiva   As Boolean          ' True: Busca recursivamente por los subdirectorios
Public lstListaFicheros     As Collection       ' Lista de ficheros encontrados que coinciden con el patrón

Private objFileSystem       As Object


Private Sub class_initialize()
   On Error GoTo ERROR_CLASSINITIALIZE

   Set oError = New classError
   
   sDirIniBusqueda = ""
   sPatronBusqueda = ""
   bBusquedaRecursiva = False
   
   Set objFileSystem = CreateObject("Scripting.FileSystemObject")

   Exit Sub
   
ERROR_CLASSINITIALIZE:
   oError.iNumError = Err.Number
   oError.sMensaSist = Err.Description
   oError.sDonde = "classFileSearch.class_initialize()"
   oError.sMensaApli = "Error inicializando una instancia de la clase"

End Sub

Private Sub class_terminate()
   On Error Resume Next
   Set oError = Nothing
   Set lstListaFicheros = Nothing
   Set objFileSystem = Nothing
End Sub

Public Function Ejecutar() As Integer
   On Error GoTo ERROR_EJECUTAR
   
   Dim iIndice     As Integer
   Dim sDirectorio As String
   Dim sFichero    As String


   If (sDirIniBusqueda = "") Then
       oError.iNumError = -9999
       oError.sMensaSist = ""
       oError.sDonde = "classFileSearch.Ejecutar()"
       oError.sMensaApli = "No se ha indicado ninguna ruta de directorio desde la que iniciar la búsqueda"
       Ejecutar = -9999
   
   ElseIf (sPatronBusqueda = "") Then
       oError.iNumError = -9999
       oError.sMensaSist = ""
       oError.sDonde = "classFileSearch.Ejecutar()"
       oError.sMensaApli = "No se ha indicado ningún patrón de archivo a buscar"
       Ejecutar = -9999
   Else
       '___Comprobar si la colección de ficheros tiene información, y si la tiene borrarla___

       Set lstListaFicheros = Nothing
       Set lstListaFicheros = New Collection
       
       sDirectorio = Trim(sDirIniBusqueda)
       sFichero = sPatronBusqueda
       
       BuscarFicheros sDirectorio, sFichero

       If (oError.iNumError = 0) Then
           Ejecutar = lstListaFicheros.Count
       Else
           Ejecutar = -1
       End If
   End If
   
   Exit Function
   
ERROR_EJECUTAR:
   oError.iNumError = Err.Number
   oError.sMensaSist = Err.Description
   oError.sDonde = "classFileSearch.Ejecutar()"
   oError.sMensaApli = "Error ejecutando la búsqueda de ficheros indicada"
   Ejecutar = -1
   
End Function

Private Sub BuscarFicheros(sDirectorio As String, sFichero As String)
   On Error GoTo ERROR_BUSCARFICHEROS

   Dim sDirectorioFichero As String
   Dim vSubdirectorio As Variant
   Dim lstSubdirectorios As New Collection


   '___Añade la barra de directorio al final del nombre de directorio si no la tuviera___

   If (Right(sDirectorio, 1) <> "\") Then
       sDirectorio = sDirectorio & "\"
   End If


   '___Realiza la búsqueda de ficheros en el directorio actual___

   sDirectorioFichero = Dir(sDirectorio & sFichero)

   While (sDirectorioFichero <> "")
       lstListaFicheros.Add objFileSystem.GetFile(sDirectorio & sDirectorioFichero)   'Añade el fichero a la lista de ficheros encontrados
       sDirectorioFichero = Dir
   Wend


   '___Buscar en los subdirectorios si se ha definido la búsqueda como recursiva___

   If (bBusquedaRecursiva) Then
   
       sDirectorioFichero = Dir(sDirectorio & "*", vbDirectory)
   
       While (sDirectorioFichero <> "")
   
           If (sDirectorioFichero <> "." And sDirectorioFichero <> "..") Then
               If ((GetAttr(sDirectorio & sDirectorioFichero) And vbDirectory) = 16) Then
                   lstSubdirectorios.Add sDirectorio & sDirectorioFichero
               End If
           End If

           sDirectorioFichero = Dir
       Wend
   
   
       '___Procesar la lista de subdirectorios___
   
       For Each vSubdirectorio In lstSubdirectorios
           BuscarFicheros CStr(vSubdirectorio), sFichero   'Llamada recursiva
           
           If (oError.iNumError <> 0) Then
               Exit For
           End If
       Next
   End If

   Exit Sub
   
ERROR_BUSCARFICHEROS:
   oError.iNumError = Err.Number
   oError.sMensaSist = Err.Description
   oError.sDonde = "classFileSearch.BuscarFicheros()"
   oError.sMensaApli = "Error en el procedimiento de búsqueda de ficheros"
   
End Sub




Procedimiento de prueba (.bas)
Esta es una pequeña función que lo único que hace es instanciar un objeto de la clase classFileSearch, lanzar una búsqueda y mostrar el resultado por la ventana de inspección.

Código (vb) [Seleccionar] Expandir


Public Function fnMain() As Boolean
   Dim objFileSearch   As classFileSearch
   Dim objFichero      As Object


   fnMain = True
   Set objFileSearch = New classFileSearch
   
   If (objFileSearch.oError.iNumError = 0) Then

       '___Configurar los parámetros de búsqueda de fichero___
       
       objFileSearch.sDirIniBusqueda = "E:\Mis documentos"
       objFileSearch.sPatronBusqueda = "*.zip"
       objFileSearch.bBusquedaRecursiva = True

       If (objFileSearch.Ejecutar() > 0) Then  '_Se han encontrado ficheros

           For Each objFichero In objFileSearch.lstListaFicheros
               Debug.Print "Fichero........: " & objFichero.Name
               Debug.Print "Directorio.....: " & objFichero.parentfolder
               Debug.Print "Nombre completo: " & objFichero.Path
               Debug.Print "--------------------------"
           Next objFichero

       ElseIf (objFileSearch.oError.iNumError = 0) Then   '_No hay error => No se han encontrado ficheros

           Debug.Print "No hay ficheros que mostrar"
       
       Else    '_Error

           Debug.Print "<* ERROR *>"
           Debug.Print "   Lugar del error.......: " & objFileSearch.oError.sDonde
           Debug.Print "   Número de error.......: " & objFileSearch.oError.iNumError
           Debug.Print "   Error devuelto por VBA: " & objFileSearch.oError.sMensaSist
           Debug.Print "   Error de aplicación...: " & objFileSearch.oError.sMensaApli
           Debug.Print "--------------------------"

           fnMain = False
       End If
   Else
       Debug.Print "<* ERROR *>"
       Debug.Print "   Lugar del error.......: " & objFileSearch.oError.sDonde
       Debug.Print "   Número de error.......: " & objFileSearch.oError.iNumError
       Debug.Print "   Error devuelto por VBA: " & objFileSearch.oError.sMensaSist
       Debug.Print "   Error de aplicación...: " & objFileSearch.oError.sMensaApli
       Debug.Print "--------------------------"
       
       fnMain = False
   End If

   Set objFileSearch = Nothing
End Function




El código está probado y funciona. No implementa la funcionalidad completa de "Application.FileSearch" pero cubre lo más básico.

Supongo que viendo el código ya os habréis dado cuenta que el Visual Basic no es mi especialidad así que comentarios, sugerencias, críticas constructivas y mejoras serán bienvenidas

[x64core]

esta bien pero porque se escribe "Option Compare Database"
el codigo me funka si la linea no esta quiza sera porque mencionas que trabajas con base de datos y eso yo la verdad no se casi nada de base de datos y esas cosas y pues mejor usaria APIs que un Objeto
las cadena de comprobacion vacia ( "" ) es mejor Vbnullstrings

[raul338]

Nunca programe profundamente en VBA. Pero es bueno saberlo y si la clase funciona, a la biblioteca
Esta prolijo y entendible el codigo

También puedes usar la Clase para Buscar de LeandroA que incluye comodines "?" y "*"

[Aberroncho]

esta bien pero porque se escribe "Option Compare Database"

"Option Compare" determina el modo en que se compararán las cadenas de texto. En VBA para Access tiene tres valores posibles:

• Binary: Realiza la comparación utilizando el orde que establece el código ASCII del caracter. Esta opción haría que al ordenar, la 'ñ' y la 'Ñ' vayan después de la Z ya que su código ASCII es mayor.
• Text: Realiza la comparación de forma alfabética atendiendo a la configuración regional del sistema y sin distinguir mayúsculas de minúsculas.
• Database: Realiza la comparación siguiendo el criterio configurado en la base de datos.