Imports Scripting Imports System.IO Imports System.String Public Class FSO Private oFSO As New Scripting.FileSystemObject Private Carp As Scripting.Folder, oDir As Scripting.Files, Fic As Scripting.File, Txt As Scripting.TextStream Public Ficheros() As String Dim ForReading As IOMode Dim ForAppending As IOMode Public Function ExisteFichero(RutaFic As String) As Boolean If oFSO.FileExists(RutaFic) Then Return True Else Return False End Function Public Sub CopiarFichero(Origen, Destino, Reescribir) If oFSO.FileExists(Origen) Then oFSO.CopyFile(Origen, Destino, Reescribir) End Sub Public Sub MoverFichero(Origen As String, Destino As String) If oFSO.FileExists(Origen) Then oFSO.MoveFile(Origen, Destino) End Sub Public Sub BorrarFichero(Fichero As String) If oFSO.FileExists(Fichero) Then oFSO.DeleteFile(Fichero) End Sub Public Function ExisteCarpeta(Carpeta As String) As Boolean If oFSO.FolderExists(Carpeta) Then Return True Else Return False End Function Public Sub CrearCarpeta(Carpeta As String) If Not oFSO.FolderExists(Carpeta) Then oFSO.CreateFolder(Carpeta) End Sub Public Sub MoverCarpeta(Origen As String, Destino As String) If oFSO.FolderExists(Origen) Then oFSO.MoveFolder(Origen, Destino) End Sub Public Sub CopiarCarpeta(Origen As String, Destino As String, Reescribir As Boolean) If oFSO.FolderExists(Origen) Then oFSO.CopyFolder(Origen, Destino, Reescribir) End Sub Public Sub BorrarCarpeta(Carpeta As String) If oFSO.FolderExists(Carpeta) Then oFSO.DeleteFolder(Carpeta) End Sub 'Public Function Directorio(Carpeta) As String() ' Dim x As Integer ' If oFSO.FolderExists(Carpeta) Then ' Carp = oFSO.GetFolder(Carpeta) ' oDir = Carp.Files ' x = 0 ' For Each Item In oDir ' ReDim Preserve Ficheros(x) ' Ficheros(x) = Item ' x = x + 1 ' Next ' End If ' Directorio = Ficheros 'End Function Public Function Directorio(Carpeta As String, bRecursivo As Boolean) As List(Of String) Dim Lista As New List(Of String) Dim Stack As New Stack(Of String) Directorio = Nothing Stack.Push(Carpeta) If oFSO.FolderExists(Carpeta) Then Do While (Stack.Count > 0) ' Get top directory string Dim dir As String = Stack.Pop Try ' Add all immediate file paths Lista.AddRange(Directory.GetFiles(dir, "*.*")) If bRecursivo Then ' Loop through all subdirectories and add them to the stack. Dim directoryName As String For Each directoryName In Directory.GetDirectories(dir) Stack.Push(directoryName) Next End If Catch ex As Exception End Try Loop Directorio = Lista End If End Function Public Function NombreFichero(Ruta As String) As String If oFSO.FileExists(Ruta) Then Fic = oFSO.GetFile(Ruta) NombreFichero = Fic.Name Else NombreFichero = "Fichero Desconocido" End If Fic = Nothing End Function Public Function TamannoFichero(Ruta As String) As Long If oFSO.FileExists(Ruta) Then Fic = oFSO.GetFile(Ruta) TamannoFichero = Fic.Size Else TamannoFichero = 0 End If Fic = Nothing End Function Function sTamanno(iTamanno As Long, iDecimales As Integer) As String If iTamanno < 1000 Then sTamanno = iTamanno & " bytes" ElseIf iTamanno > 999 And iTamanno < 1000000 Then sTamanno = Math.Round(iTamanno / 1000, iDecimales) & " Kb" ElseIf iTamanno > 999000 Then sTamanno = Math.Round(iTamanno / 1000000, iDecimales) & " Mb" Else sTamanno = iTamanno & " ?" End If End Function Public Function FechaModifFichero(Ruta As String) As Date FechaModifFichero = "01/01/1800" If oFSO.FileExists(Ruta) Then Fic = oFSO.GetFile(Ruta) FechaModifFichero = Fic.DateLastModified ' FechaModifFichero = CDate(Format(Fic.DateLastModified, "dd/mm/yyyy")) End If Fic = Nothing End Function Public Function FicheroFechaHoy(Ruta As String) As Boolean Dim Fecha As Date, strfecha As String Fecha = FechaModifFichero(Ruta) strfecha = Left(CStr(Fecha), 10) If Left(CStr(Date.Today), 10) <> strfecha Then Return False Return True End Function Public Sub CrearEscribirTxt(Fichero As String, Reescribir As Boolean, Texto As String) If Reescribir Then Txt = oFSO.OpenTextFile(Fichero, 2, True) Txt.Write(Texto) Txt.Close() ElseIf Not Reescribir Then If oFSO.FileExists(Fichero) Then Txt = oFSO.OpenTextFile(Fichero, 8, True) Txt.Write(Texto) Txt.Close() ElseIf Not oFSO.FileExists(Fichero) Then Txt = oFSO.OpenTextFile(Fichero, 2, True) Txt.Write(Texto) Txt.Close() End If End If Txt = Nothing End Sub Public Sub EscribirLineaTxt(Fichero As String, Texto As String, Optional Crear As Boolean = False) Txt = oFSO.OpenTextFile(Fichero, 8, Crear) Txt.WriteLine(Texto) Txt.Close() : Txt = Nothing End Sub Public Function LeerTxt(Fichero As String) As String Txt = oFSO.OpenTextFile(Fichero, 1, False) LeerTxt = Txt.ReadAll Txt.Close() Txt = Nothing : Txt = Nothing End Function Public Function LineasFichero(Fichero As String) As Integer Dim StrFic As String, Arr_Lineas() As String oFSO = CreateObject("Scripting.FileSystemObject") Try StrFic = oFSO.OpenTextFile(Fichero, IOMode.ForReading).ReadAll Arr_Lineas = Strings.Split(StrFic, vbCrLf) LineasFichero = UBound(Arr_Lineas) + 1 Catch ex As Exception LineasFichero = -1 End Try StrFic = "" : Arr_Lineas = Nothing End Function Public Sub RecorreLineas(Fichero As String) Dim s As String, ifila As Integer Txt = oFSO.OpenTextFile(Fichero, IOMode.ForReading, False) ifila = 1 While Not Txt.AtEndOfStream s = Txt.ReadLine If s = "" Then ' Txt.WriteLine("XXXXXXXXX ") End If ifila = ifila + 1 End While Txt.Close() Txt = Nothing : Txt = Nothing End Sub '*************** UNIR DOS FICHEROS DE TEXTO Public Sub UnirTxt(Txt1 As String, Txt2 As String, TxtUnion As String) Dim ts1 As TextStream Dim ts2 As TextStream Dim tsUnion As TextStream CrearEscribirTxt(TxtUnion, True, "") ts1 = oFSO.OpenTextFile(Txt1, IOMode.ForReading) ts2 = oFSO.OpenTextFile(Txt2, IOMode.ForReading) tsUnion = oFSO.OpenTextFile(TxtUnion, IOMode.ForAppending) tsUnion.Write(ts1.ReadAll) : tsUnion.Write(ts2.ReadAll) ts1.Close() : ts2.Close() : tsUnion.Close() ts1 = Nothing : ts2 = Nothing : tsUnion = Nothing End Sub '*************** UNIR VARIOS FICHEROS DE TEXTO Public Sub UnirTxts(Arr_TxtOrigen() As String, TxtUnion As String) Dim ts1 As TextStream Dim tsUnion As TextStream CrearEscribirTxt(TxtUnion, True, "") tsUnion = oFSO.OpenTextFile(TxtUnion, IOMode.ForAppending) For Each item As String In Arr_TxtOrigen ts1 = oFSO.OpenTextFile(item, IOMode.ForReading) tsUnion.Write(ts1.ReadAll) ts1.Close() : ts1 = Nothing Next tsUnion.Close() ts1 = Nothing : tsUnion = Nothing End Sub 'Public Sub UnirTxt(Txt1 As String, Txt2 As String, TxtUnion As String) ' Dim strRead1 As New IO.StreamReader(Txt1) 'aqui abro un lector de stream del primer archivo ' Dim strRead2 As New IO.StreamReader(Txt2) 'aqui abro un lector de stream del segundo archivo ' Dim strbuild As New System.Text.StringBuilder 'este objeto sirve para acumular textos ' While strRead2.Peek <> -1 Or strRead1.Peek <> -1 'hago un ciclo mientras en cualquiera de los dos me queden lineas ' If strRead1.Peek <> -1 Then 'pregunto si llegue al final del archivo 1 ' strbuild.Append(strRead1.ReadLine.Replace(vbCrLf, "")) 'no he llegado al final, leo la linea, elimino el enter final y la pego ' End If ' If strRead2.Peek <> -1 Then 'lo mismo con el segundo archivo ' strbuild.Append(" " & strRead2.ReadLine.Replace(vbCrLf, "")) ' esta linea la pego junto a la anterior, y dejo un espacio ' End If ' strbuild.Append(vbCrLf) 'le pego un enter al final de la linea ' End While ' strRead1.Close() 'cierro el primer archivo ' strRead2.Close() 'cierro el segundoarchivo ' Dim StrWriter As New IO.StreamWriter(TxtUnion) 'abro un stream para escritura ' StrWriter.Write(strbuild.ToString) 'escribo el stringbuilder completo (un solo string) ' StrWriter.Close() 'cierro el stream. 'End Sub End Class