Attribute VB_Name = "ScriptObj"
Option Explicit

Function FindFolder(Optional Title As String, Optional Initial_Path As Variant, Optional HwndPW As Long) As String
On Local Error GoTo errFunction
Dim objShell As Object, objFolder As Object, o_Carpeta As Object
Set objShell = CreateObject("Shell.Application")
On Error Resume Next
Set objFolder = objShell.BrowseForFolder(HwndPW, Title, 1, Initial_Path)
Set o_Carpeta = objFolder.Self
FindFolder = o_Carpeta.Path
Exit Function
errFunction:
MsgBox Err.Description, vbCritical
FindFolder = vbNullString
End Function

Function ExisteCarpeta(Ruta As String) As Boolean
ExisteCarpeta = CreateObject("Scripting.FileSystemObject").FolderExists(Ruta)
End Function

Public Function ListarArchivosDeDir(Ruta As String, Optional Filtro As String) As String()
'Devuelve una matriz con las rutas completas de los archivos contenidos
'en el directorio especificado
'Si el directorio no contiene ningun archivo devuelve una matriz con un unico elemento NullString
'Menor indice de la matriz de retorno: 1

'Estructura del filtro: "Extension1:Extension2:Extension3...ExtensionN:"
'Notar que se debe agregar : como separador de lista y al final de la lista tambien
Dim fs, f1
Dim Ret() As String
Dim i As Long
If ExisteCarpeta(Ruta) = False Then
ReDim Ret(1 To 1)
ListarArchivosDeDir = Ret
Exit Function
End If
Set fs = CreateObject("Scripting.FileSystemObject").GetFolder(Ruta).Files
i = 1
ReDim Ret(i To i)
For Each f1 In fs
ReDim Preserve Ret(1 To i)
Ret(i) = f1.Path
i = i + 1
Next
If Filtro <> "" And Ret(1) <> "" Then Ret = FiltrarLista(Ret, Filtro)
ListarArchivosDeDir = Ret
End Function

Private Function FiltrarLista(Rutas() As String, Optional Filtro As String) As String()
'Filtra la lista de archivos por extension
'Si ningun archivo tiene la(s) extension(es) especificada devuelve una matriz cuyo unico
'elemento es NullString
'Indice menor de la matriz: 1
Dim Ret() As String
Dim MatrizFlt() As String
Dim i As Integer, j As Integer, Extension As String, k As Integer

'Convierte el filtro de string a matriz

i = 1
j = 1
k = 0
While i <= Len(Filtro)
If Mid(Filtro, i, 1) = ":" Then
k = k + 1
ReDim Preserve MatrizFlt(1 To k)
MatrizFlt(k) = Mid(Filtro, j, i - j)
j = i + 1
End If
i = i + 1
Wend

ReDim Ret(1 To 1)
If k = 0 Then
FiltrarLista = Rutas
Exit Function
End If
k = 0
i = LBound(Rutas)
While i <= UBound(Rutas)
Extension = CreateObject("Scripting.FileSystemObject").GetExtensionName(Rutas(i))
j = 1
While j <= UBound(MatrizFlt)
If LCase(Extension) = LCase(MatrizFlt(j)) Then
k = k + 1
ReDim Preserve Ret(1 To k)
Ret(k) = Rutas(i)
j = UBound(MatrizFlt)
End If
j = j + 1
Wend
i = i + 1
Wend
FiltrarLista = Ret
End Function

Function ExisteArchivo(Ruta As String) As Boolean
'Devuelve True si el archivo existe, False si no
ExisteArchivo = CreateObject("Scripting.FileSystemObject").FileExists(Ruta)
End Function

Public Function CrearCarpeta(Ruta As String) As Boolean
'Crea una carpeta de texto y devuelve true si el proceso pudo realizarse
'Devuelve false si el proceso no pudo realizarse ó si la carpeta ya existe
On Error GoTo Salir
CreateObject("Scripting.FileSystemObject").CreateFolder Ruta
CrearCarpeta = True
Salir:
End Function

Public Function ResolverConflictoDeNombres(Ruta As String, Optional Existe As Boolean = False) As String
Dim i As Integer, Nombre As String, Extension As String, DirPadre As String
Dim NuevoNombre As String
DirPadre = DirectorioPadre(Ruta)
Nombre = NombreBase(Ruta)
NuevoNombre = Nombre
If Existe Then NuevoNombre = NuevoNombre & " (2)"
Extension = DevolverExtension(Ruta)
i = 2
While ExisteArchivo(DirPadre & "\" & NuevoNombre & "." & Extension) Or ExisteCarpeta(DirPadre & "\" & NuevoNombre & "." & Extension)
NuevoNombre = Nombre & " (" & Trim(CStr(i)) & ")"
i = i + 1
Wend
ResolverConflictoDeNombres = DirPadre & "\" & NuevoNombre
If Extension <> "" Then ResolverConflictoDeNombres = ResolverConflictoDeNombres & "." & Extension
End Function

Public Function DirectorioPadre(Ruta As String) As String
'Devuelve la ruta del directorio padre, no es necesario que exista el archivo ó carpeta
Dim i As Long
On Error GoTo Salir
i = InStrRev(Ruta, "\", Len(Ruta))
If i < 1 Then Exit Function
DirectorioPadre = Left(Ruta, i - 1)
Salir:
End Function

Public Function NombreBase(Ruta As String) As String
'Devuelve el nombre base de un archivo (existente o no) sin la extension
NombreBase = CreateObject("Scripting.FileSystemObject").GetBaseName(Ruta)
End Function

Public Function DevolverExtension(Ruta As String) As String
'Devuelve la extension contenida en una ruta, no es necesario que el archivo ó carpeta existan
DevolverExtension = CreateObject("Scripting.FileSystemObject").GetExtensionName(Ruta)
End Function

Public Function CambiarNombreBaseArchivo(Ruta As String, NuevoNombre As String) As Boolean
Dim NombreNuevo As String
On Error GoTo Salir
NombreNuevo = NuevoNombre & "." & CreateObject("Scripting.FileSystemObject").GetExtensionName(Ruta)
CreateObject("Scripting.FileSystemObject").GetFile(Ruta).Name = NombreNuevo
CambiarNombreBaseArchivo = True
Salir:
End Function

Public Function FilenameIsValid(FileName As String) As Boolean
FilenameIsValid = (InStr(1, FileName, "/", vbBinaryCompare) = 0 And InStr(1, FileName, "\", vbBinaryCompare) = 0 And InStr(1, FileName, ":", vbBinaryCompare) = 0 And InStr(1, FileName, "*", vbBinaryCompare) = 0 And InStr(1, FileName, "?", vbBinaryCompare) = 0 And InStr(1, FileName, Chr(34), vbBinaryCompare) = 0 And InStr(1, FileName, "<", vbBinaryCompare) = 0 And InStr(1, FileName, ">", vbBinaryCompare) = 0 And InStr(1, FileName, "|", vbBinaryCompare) = 0)
End Function

Public Function CrearArbol(RutaObjetivo As String) As Boolean
Dim DirNames() As String, i As Integer, DirPathBuffer As String, j As Integer
On Error GoTo Finalizar
CrearArbol = False
DirNames = Split(RutaObjetivo, "\")

'Buscar el ultimo componente de la ruta que NO existe
i = LBound(DirNames)
j = -1
DirPathBuffer = ""
While i <= UBound(DirNames) And j = -1
DirPathBuffer = DirPathBuffer & DirNames(i) & "\"
If ExisteCarpeta(DirPathBuffer) = False Then j = i
i = i + 1
Wend

'Crear arbol
If j <> -1 Then
While j <= UBound(DirNames)
If CrearCarpeta(DirPathBuffer) = False Then Exit Function
j = j + 1
DirPathBuffer = DirPathBuffer & DirNames(j) & "\"
Wend
End If

Finalizar:
CrearArbol = ExisteCarpeta(RutaObjetivo)
End Function

Function CopiarArchivo(Origen As String, Destino As String, Optional Sobreescibir As Boolean = False) As Boolean
'Si destino contiene \ al final se supone que es un directorio existente en el
'cual se copiará el archivo, de lo contrario se supone será el nombre del archivo
'copiado y su ruta completa
'La función devuelve TRUE si el archivo se copió con éxito
'devuelve FALSE si el archivo no se pudo copiar
'Nota: los archivos de solo lectura no pueden sobreescribirse
On Error GoTo Salir
CopiarArchivo = True
CreateObject("Scripting.FileSystemObject").CopyFile Origen, Destino, Sobreescibir
Exit Function
Salir:
CopiarArchivo = False
End Function


Public Function BorrarCarpeta(Ruta As String, Optional EliminarSoloLectura As Boolean) As Boolean
On Error GoTo Salir
CreateObject("Scripting.FileSystemObject").DeleteFolder Ruta, EliminarSoloLectura
BorrarCarpeta = Not ExisteCarpeta(Ruta)
Salir:
End Function

Function ListarArchivosEnArbol(RutaRaiz As String, Optional Filtro As String) As String()
Dim Directorios() As String, Archivos() As String, i As Long, Temp() As String, j As Long
Dim n As Long
Archivos = ListarArchivosDeDir(RutaRaiz, Filtro)
ListarArchivosEnArbol = Archivos
Directorios = ListarDirectoriosEnArbol(RutaRaiz)
If Directorios(1) = "" Then GoTo Salir
If Archivos(1) = "" Then n = 0 Else n = UBound(Archivos)
For i = 1 To UBound(Directorios)
Erase Temp
Temp = ListarArchivosDeDir(Directorios(i), Filtro)
If Temp(1) <> "" Then
For j = 1 To UBound(Temp)
n = n + 1
ReDim Preserve Archivos(1 To n)
Archivos(UBound(Archivos)) = Temp(j)
Next
End If
Next
On Error GoTo Salir
j = UBound(Archivos)
ListarArchivosEnArbol = Archivos
Salir:
End Function

Function ListarDirectoriosEnArbol(RutaRaiz As String) As String()
Dim Directorios() As String, i As Long, Temp() As String, j As Long
Directorios = ListarSubDirectorios(RutaRaiz)
ListarDirectoriosEnArbol = Directorios
If Directorios(1) = "" Then GoTo Salir
i = 1
While i <= UBound(Directorios)
Erase Temp
Temp = ListarSubDirectorios(Directorios(i))
If Temp(1) <> "" Then
For j = 1 To UBound(Temp)
ReDim Preserve Directorios(1 To UBound(Directorios) + 1)
Directorios(UBound(Directorios)) = Temp(j)
Next
End If
i = i + 1
Wend
ListarDirectoriosEnArbol = Directorios
Salir:
End Function

Function ListarSubDirectorios(Ruta As String) As String()
On Error GoTo Salir
Dim Directorios() As String, i As Long, fs As Object, f1 As Object
ReDim Directorios(1 To 1)
Directorios(1) = ""
ListarSubDirectorios = Directorios
Set fs = CreateObject("Scripting.FileSystemObject").GetFolder(Ruta).SubFolders
i = 0
For Each f1 In fs
i = i + 1
ReDim Preserve Directorios(1 To i)
Directorios(i) = f1
Next
ListarSubDirectorios = Directorios
Salir:
End Function

Function Archivo_RutaCorta(Ruta As String) As String
On Error Resume Next
Archivo_RutaCorta = CreateObject("Scripting.FileSystemObject").GetFile(Ruta).ShortPath
If ExisteArchivo(Archivo_RutaCorta) = False Then Archivo_RutaCorta = Ruta
End Function

Public Function TamanoArchivo(Ruta As String) As Long
'Devuelve el tamaño del archivo especificado en Bytes
On Error GoTo Salir
TamanoArchivo = CreateObject("Scripting.FileSystemObject").GetFile(Ruta).Size
Salir:
End Function

Public Function FormatearTamanoArchivo(Tamano As Long) As String
On Error GoTo Salir
Dim Ret As String, TamanoDbl As Double, SizeUnit As Byte
TamanoDbl = Tamano
While TamanoDbl > 1024 And SizeUnit < 3
    TamanoDbl = TamanoDbl / 1024
    SizeUnit = SizeUnit + 1
Wend
TamanoDbl = Round(TamanoDbl, 2)
Select Case SizeUnit
    Case 0: Ret = CStr(Tamano) & " Bytes"
    Case 1: Ret = CStr(TamanoDbl) & " KB"
    Case 2: Ret = CStr(TamanoDbl) & " MB"
    Case 3: Ret = CStr(TamanoDbl) & " GB"
End Select
FormatearTamanoArchivo = Ret
Salir:
End Function

Public Function BorrarArchivo(Ruta As String, Optional EliminarSoloLectura As Boolean) As Boolean
On Error GoTo Salir:
CreateObject("Scripting.FileSystemObject").DeleteFile Ruta, EliminarSoloLectura
BorrarArchivo = Not ExisteArchivo(Ruta)
Salir:
End Function

Public Function TamanoCarpeta(Ruta As String) As Long
On Error Resume Next
TamanoCarpeta = CreateObject("Scripting.FileSystemObject").GetFolder(Ruta).Size
End Function

Function MoverArchivo(Origen As String, Destino As String) As Boolean
'Esta función devuelve TRUE si el archivo fue movido
'Devuelve FALSE si el archivo no pudo moverse
'No se pueden reemplazar archivos o direcorios existentes
'Si destino contiene \ al final se supone que Destino es un Directorio al cual
'se moverá el archivo
'Si destino no contiene \ al final se supone será la ruta que tendrá el
'archivo una vez que haya sido movido
On Error GoTo Salir
MoverArchivo = True
CreateObject("Scripting.FileSystemObject").MoveFile Origen, Destino
Exit Function
Salir:
MoverArchivo = False
End Function

Function DirectorioEstaVacio(Ruta As String) As Boolean
Dim i As Long
i = CreateObject("Scripting.FileSystemObject").GetFolder(Ruta).Files.Count
i = i + CreateObject("Scripting.FileSystemObject").GetFolder(Ruta).SubFolders.Count
DirectorioEstaVacio = (i = 0)
End Function

Function DevolverNombre(Ruta As String) As String
On Error GoTo Salir
Dim i As Long
i = InStrRev(Ruta, "\")
DevolverNombre = Right(Ruta, Len(Ruta) - i)
Salir:
End Function
