Logo_Access_global_380x114Favicon_Access_global_180x180Logo_Access_global_380x114Logo_Access_global_380x114
  • Home
  • University
    • Destellos formativos
  • Labs
  • TV
  • Secciones
    • El mundo de Access
    • Explorando VBA
      • Artículos sobre VBA
      • Un trocito de código
    • Entrevistas
      • Profesionales de Access
    • El rincón de Excel
    • Bases de datos
      • MS SQL
      • MySQL
      • postgreSQL
      • SQLite
    • Clases magistrales
    • Utilidades hechas con Access
  • Access en el mundo
  • ¿Quiénes somos?
  • Cómo colaborar
  • Eventos
✕
            No hay resultados Mostrar todos los resultados
            Access: Instancias de formulario
            21/09/2022
            VBA: instalar nueva fuente
            23/09/2022
            Mostrar todos

            VBA: objeto FSO recopilación

            Publicado por Alba Salvá
            Categorías
            • Destellos formativos
            Etiquetas
            • CreateFolder
            • Drives
            • FileSystemObject
            • FolderExists
            • GetFile
            • GetFolder
            • OpenTextAsStream
            • VBA
            Option Compare Database
            Option Explicit
            
            '-----------------------------------------------------------------------------------------------------------------------------------------------
            ' Fuente            : https://access-global.net/vba-objeto-fso-recopilacion
            '-----------------------------------------------------------------------------------------------------------------------------------------------
            ' Título            : mod_FSO
            ' Autor original    : Alba Salvá
            ' Creado            : diferentes fechas
            ' Propósito         : mostrar el uso de todas las posibilidad del objeto FSO en un único ejemplo
            '-----------------------------------------------------------------------------------------------------------------------------------------------
            ' Referencia        : https://learn.microsoft.com/en-us/office/vba/language/reference/user-interface-help/filesystemobject-object
            ' Más información   : diferentes funciones que recorren el PC del usuario y van creando un fichero de texto con todo lo que este contiene.
            '                     - Directorios
            '                     - Carpetas
            '                     - Ficheros y sus propiedades
            '-----------------------------------------------------------------------------------------------------------------------------------------------
            Dim fso As Object
            Dim ts As Object
            Dim fl As Object
            
            Dim MiForm As Form_Principal
            Dim SumaBytes As Currency
            
            Const ForWriting = 2
            Const ForAppending = 8
            Const TristateUseDefault = &HFFFFFFFE '-2
            
            Sub recorrePC()
            '-----------------------------------------------------------------------------------------------------------------------------------------------
            ' Título            : recorrePC
            ' Autor original    : Alba Salvá
            ' Creado            : diferentes fechas
            ' Propósito         : recorrer el PC del usuario extrayendo unidades y sus propiedades
            ' Retorno           : va creando un archivo txt con lo que va encontrando
            '-----------------------------------------------------------------------------------------------------------------------------------------------
            ' Referencia        : https://docs.microsoft.com/en-us/previous-versions/windows/desktop/ms723602(v=vs.85)?redirectedfrom=MSDN
            '-----------------------------------------------------------------------------------------------------------------------------------------------
            ' Test:             : Para adaptar este código en tu aplicación puedes basarte en este procedimiento test. Copiar el bloque siguiente al
            '                     portapapeles y pega en el editor de VBA. Descomentar la línea que nos interese y pulsar F5 para ver su funcionamiento.
            '
            ' Sub recorrerpc_test()
            '
            '        Call recorrerPC
            '
            ' End Sub
            '-----------------------------------------------------------------------------------------------------------------------------------------------
            Dim Discos As Object
            Dim Disco As Object
            Dim strMsg As String
                
                Set MiForm = Form_Principal
                
                MiForm.BarMin = 0
                MiForm.BarValue = 0
                
                Set fso = CreateObject("Scripting.FileSystemObject")
                
                If Not fso.FolderExists("C:\Listado_PC") Then fso.CreateFolder "C:\Listado_PC"
                fso.CreateTextFile "C:\Listado_PC\Listado_PC.txt"
                Set fl = fso.GetFile("C:\Listado_PC\Listado_PC.txt")
                
                Set ts = fl.OpenAsTextStream(ForWriting, TristateUseDefault)
                ts.WriteLine "Listado de unidades, carpetas y archivos, y sus características."
                ts.WriteLine "================================================================"
                ts.WriteBlankLines 3
                
                Set Discos = fso.Drives
                
                ts.WriteLine "Tu PC tiene " & Discos.Count & " unidades de disco"
                ts.Close
                
                For Each Disco In Discos
                    DoEvents
                      
                    strMsg = "C:\Listado_PC\Unidad " & Disco.DriveLetter & ".txt"
                    MiForm.txtUnidad = Disco.Path
                    MiForm.txtFichero = strMsg
                    
                    fso.CreateTextFile strMsg
                    Set fl = fso.GetFile(strMsg)
                
                    Set ts = fl.OpenAsTextStream(ForAppending, TristateUseDefault)
                    
                    ts.WriteBlankLines 1
                    
                    With Disco
                                    
                        ts.Write vbTab & .DriveLetter & " - "
                        Select Case .DriveType
                            Case 1
                                ts.Write "Removible"
                            Case 2
                                ts.Write "Fijo"
                            Case 3
                                ts.Write " en Red"
                            Case 4
                                ts.Write "CDRom"
                            Case 5
                                ts.Write "Disco RAM"
                            Case Else
                                ts.Write "Desconocido"
                        End Select
                        
                        If .DriveType = 3 Then
                            
                            ts.WriteLine "Recurso de red: " & .ShareName
                        Else
                            If .IsReady Then
                                ts.WriteLine vbTab & "Nombre: " & .VolumeName
                            Else
                                ts.WriteLine vbTab & "Unidad no disponible"
                            End If
                        End If
                        
                        ts.WriteLine vbTab & vbTab & "Está activo: " & .IsReady
                        If .IsReady Then
                            ts.WriteLine vbTab & vbTab & "Nº de serie: " & .SerialNumber
                            ts.WriteLine vbTab & vbTab & "Sistema de srchivos: " & .FileSystem
                            ts.WriteLine vbTab & vbTab & "Capacidad total: " & Format(.TotalSize, "#,##0") & " bytes"
                            ts.WriteLine vbTab & vbTab & "Espacio libre  : " & Format(.FreeSpace, "#,##0") & " bytes"
                            ts.WriteLine vbTab & vbTab & "Carpeta raiz: " & .RootFolder
                            
                            MiForm.BarMax = .TotalSize - .FreeSpace
                        
                        End If
                        ts.WriteLine vbTab & vbTab & "Ruta: " & .Path
                        ts.Close
                        
                        If .IsReady Then recorreCarpetas .RootFolder
                        
                    End With
            'Para listar sólo la primera unidad, quita el comentario
            'Stop
                    
                Next
            
                Set fso = Nothing
                
            End Sub
            
            Sub recorreCarpetas(strCarpeta As String)
            '-----------------------------------------------------------------------------------------------------------------------------------------------
            ' Título            : recorreCarpetas
            ' Autor original    : Alba Salvá
            ' Creado            : diferentes fechas
            ' Propósito         : recorrer las diferentes carpetas del PC del usuario extrayendo propiedades de las mismas, obteniendo así, el árbol de
            '                     carpetas
            ' Argumento/s       : La sintaxis de la función consta del siguiente argumento:
            '                     Parte           Modo             Descripción
            '-----------------------------------------------------------------------------------------------------------------------------------------------
            '                     strCarpeta      Obligatorio      Carpeta PADRE desde la que queremos extrar su árbol
            '-----------------------------------------------------------------------------------------------------------------------------------------------
            ' Retorno           : va creando un archivo txt con lo que va encontrando
            '-----------------------------------------------------------------------------------------------------------------------------------------------
            ' Test:             : Para adaptar este código en tu aplicación puedes basarte en este procedimiento test. Copiar el bloque siguiente al
            '                     portapapeles y pega en el editor de VBA. Descomentar la línea que nos interese y pulsar F5 para ver su funcionamiento.
            '
            ' Sub recorreCarpetas_test( unidadPadre)
            '
            '        Call recorrerPC
            '
            ' End Sub
            '-----------------------------------------------------------------------------------------------------------------------------------------------
                Static nivel As Integer, n As Integer
                Dim subCarpeta As Object, Fichero As Object
                Dim MiFile As Object
                Dim Saltos As String
                
                On Error Resume Next
                
                Set ts = fl.OpenAsTextStream(ForAppending, TristateUseDefault)
                
                MiForm.txtRuta = strCarpeta
                
                Set subCarpeta = fso.GetFolder(strCarpeta)
                
                MiForm.txtCFiles = subCarpeta.Files.Count
                MiForm.txtcSize = Format(subCarpeta.Size, "#,##0") & " bytes"
                MiForm.txtCFolders = subCarpeta.SubFolders.Count
                
                If subCarpeta.Name <> "Listado_PC" Then
                    For n = 0 To nivel + 1
                        Saltos = Saltos & vbTab
                    Next
                    
                    ts.WriteBlankLines 1
                    ts.WriteLine "======= DATOS CARPETA ========"
                    
                    With subCarpeta
                        
                        Set ts = fl.OpenAsTextStream(ForAppending, TristateUseDefault)
                        
                        ts.WriteBlankLines 1
                        
                        ts.WriteLine Saltos & "Nombre           : " & .Name
                        ts.WriteLine Saltos & "Nombre corto     : " & .ShortName
                        ts.WriteLine Saltos & "Ruta             : " & .Path
                        ts.WriteLine Saltos & "Ruta corta       : " & .ShortPath
                        ts.WriteLine Saltos & "Tipo             : " & .Type
                        ts.WriteLine Saltos & "Atributos        : " & sacaAtributos(.Attributes)
                        ts.WriteLine Saltos & "Creada el        : " & .DateCreated
                        ts.WriteLine Saltos & "Modificada el    : " & .DateLastModified
                        ts.WriteLine Saltos & "Último acceso el : " & .DateLastAccessed
                        
                        ts.WriteLine Saltos & "Carpeta superior : " & .ParentFolder
                        
                        ts.WriteLine Saltos & "Coniene          : " & subCarpeta.Files.Count & " fichero(s) y " & .SubFolders.Count & " subcarpeta(s)"
                        ts.WriteLine Saltos & "Utiliza          : " & Format(.Size, "#,##0") & " bytes"
                        
                    End With
                End If
                
                ts.WriteBlankLines 1
                ts.WriteLine "=============================="
                
                If subCarpeta.Files.Count > 0 Then
                    ts.WriteBlankLines 2
                    ts.WriteLine "========== FICHEROS =========="
                End If
                
                
                On Error GoTo 0
                
                Echo False
                If subCarpeta.Files.Count > 0 Then
                    Saltos = ""
                    nivel = nivel + 1
                    For n = 0 To nivel + 1
                        Saltos = Saltos & vbTab
                    Next
            
                    For Each Fichero In subCarpeta.Files
                        DoEvents
            
                        Set MiFile = fso.GetFile(Fichero)
                        On Error Resume Next
                        With MiFile
                            
                            ts.WriteBlankLines 1
                            ts.WriteLine Saltos & "Nombre          : " & .Name
                            ts.WriteLine Saltos & "Nombre corto    : " & .ShortName
                            ts.WriteLine Saltos & "Ruta            : " & .Path
                            ts.WriteLine Saltos & "Ruta corta      : " & .ShortPath
                            ts.WriteLine Saltos & "Nombre base     : " & fso.GetBaseName(.Path)
                            ts.WriteLine Saltos & "Extnsión        : " & fso.GetExtensionName(.Path)
                            ts.WriteLine Saltos & "Tipo            : " & .Type
                            ts.WriteLine Saltos & "Atributos       : " & sacaAtributos(.Attributes)
                            ts.WriteLine Saltos & "Carpeta         : " & .ParentFolder
                            ts.WriteLine Saltos & "Creado el       : " & .DateCreated
                            ts.WriteLine Saltos & "Modificado el   : " & .DateLastModified
                            ts.WriteLine Saltos & "Último acceso el: " & .DateLastAccessed
                            ts.WriteLine Saltos & "Tamaño          : " & Format(.Size, "#,##0") & " bytes"
                               
                            SumaBytes = SumaBytes + .Size
                            MiForm.BarValue = SumaBytes
                            
                        End With
                    Next
                    nivel = nivel - 1
                End If
                Echo True
                
                Set subCarpeta = Nothing
                
                If fso.GetFolder(strCarpeta).Files.Count > 0 Then
                    ts.WriteBlankLines 1
                    ts.WriteLine "=============================="
                End If
                
                If fso.GetFolder(strCarpeta).SubFolders.Count > 0 Then
                    
                    ts.WriteBlankLines 2
                    ts.WriteLine "========== CARPETAS =========="
                    ts.WriteBlankLines 1
                    ts.Close
                    
                    For Each subCarpeta In fso.GetFolder(strCarpeta).SubFolders
                        DoEvents
                        If subCarpeta.Name <> "Listado_PC" Then
                            Saltos = ""
                            nivel = nivel + 1
                        
                            For n = 0 To nivel + 1
                                Saltos = Saltos & vbTab
                            Next
                            
                            On Error Resume Next
                            With subCarpeta
                                
                                Set ts = fl.OpenAsTextStream(ForAppending, TristateUseDefault)
                                
                                ts.WriteLine Saltos & "Nombre           : " & .Name
                                ts.Close
                                
                            End With
                            recorreCarpetas subCarpeta.Path
                            nivel = nivel - 1
                        End If
                    Next
                    If fso.GetFolder(strCarpeta).SubFolders.Count > 0 Then
                        ts.WriteBlankLines 1
                        ts.WriteLine "=============================="
                    End If
            
                 End If
                
            End Sub
            
            
            Function sacaAtributos(Atrib As Integer) As String
            '-----------------------------------------------------------------------------------------------------------------------------------------------
            ' Título            : sacaAtributos
            ' Autor original    : Alba Salvá
            ' Creado            : diferentes fechas
            ' Propósito         : extrayendo los atributos las diferentes carpetas. Se usa con la función "recorreCarpetas"
            ' Argumento/s       : La sintaxis de la función consta del siguiente argumento:
            '                     Parte           Modo             Descripción
            '-----------------------------------------------------------------------------------------------------------------------------------------------
            '                     Atrib         Obligatorio     Representa la atributo
            '-----------------------------------------------------------------------------------------------------------------------------------------------
            ' Retorno           : devuelve una cadena con el atributo
            '-----------------------------------------------------------------------------------------------------------------------------------------------
            ' Test:             : Para adaptar este código en tu aplicación puedes basarte en este procedimiento test. Copiar el bloque siguiente al
            '                     portapapeles y pega en el editor de VBA. Descomentar la línea que nos interese y pulsar F5 para ver su funcionamiento.
            '
            ' Sub recorreCarpetas_test( unidadPadre)
            '
            '        Call recorrerPC
            '
            ' End Sub
            '-----------------------------------------------------------------------------------------------------------------------------------------------
            Dim t As String, x As String
                
                If Atrib And 1 Then 'ReadOnly = 1
                    t = "Sólo lectura"
                End If
                If Atrib And 2 Then 'Hidden = 2
                    x = "Oculto"
                    If t <> "" Then
                        t = t & ", " & x
                    Else
                        t = x
                    End If
                End If
                If Atrib And 4 Then 'System = 4
                    x = "Sistema"
                    If t <> "" Then
                        t = t & ", " & x
                    Else
                        t = x
                    End If
                End If
                If Atrib And 8 Then 'Volume = 8
                    x = "Volumen"
                    If t <> "" Then
                        t = t & ", " & x
                    Else
                        t = x
                    End If
                End If
                If Atrib And 16 Then 'Directory = 16 ' (&H10)
                    x = "Directorio"
                    If t <> "" Then
                        t = t & ", " & x
                    Else
                        t = x
                    End If
                End If
                If Atrib And 32 Then 'Archive = 32 ' (&H20)
                    x = "Archivo"
                    If t <> "" Then
                        t = t & ", " & x
                    Else
                        t = x
                    End If
                End If
                If Atrib And 1024 Then 'Alias = 1024 ' (&H400)
                    x = "Alias"
                    If t <> "" Then
                        t = t & ", " & x
                    Else
                        t = x
                    End If
                End If
                If Atrib And 2048 Then 'Compressed = 2048 ' (&H800)
                    x = "Comprimido"
                    If t <> "" Then
                        t = t & ", " & x
                    Else
                        t = x
                    End If
                End If
                
                If t = "" Then
                    t = "Normal" ' = 0
                End If
                
                sacaAtributos = t
                
            End Function
            
            ¡Ver en el repositorio!
            ¡Descarga el ejemplo!
            Compartir
            30
            Alba Salvá
            Alba Salvá

            Entradas relacionadas

            21/03/2023

            ¿Mis procedimientos tienen tratamiento de errores?


            Leer más
            20/03/2023

            Moda, mediana y algo más


            Leer más
            17/03/2023

            Funciones de dominio de Alba


            Leer más

            Deja una respuesta Cancelar la respuesta

            Tu dirección de correo electrónico no será publicada. Los campos obligatorios están marcados con *

            ETIQUETAS

            Access API BD Botones ComboBox Consultas CountOfLines CStr Diseño DoCmd Excel Exportar Fecha FileSystemObject Filtros For Each...Next Formulario Formularios Funciones Funciones de dominio GetFolder GetWindowRect Google maps Informes InStr Jose Bengoechea Kill Left Listbox Mid Módulos Node ProcCountLines Procedimientos ProcOfLine References Ribbon RunCommand Seguridad Split SysCmd Tablas TreeView VBA VBIDE

            ÚLTIMAS ENTRADAS

            • 0
              ¿Mis procedimientos tienen tratamiento de errores?
              21/03/2023
            • 0
              Moda, mediana y algo más
              20/03/2023

            ¿QUIERES PUBLICITAR TU EMPRESA AQUÍ?

            SUSCRÍBETE A NUESTRO
            NEWSLETTER

            Recibirás información puntual sobre el mundo de Access y VBA

            ¡Próximamente!

            Promovemos el uso de Access y de la programación en VBA en todo el mundo

            Centro de conocimiento


            Toda la sabiduría de los mejores programadores de Access y VBA a tu alcance.

            Legal

            Política de privacidad

            Condiciones de uso

            Condiciones del redactor

            ®Access Global 2021 | All right reserved
                      No hay resultados Mostrar todos los resultados