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