Option Compare Database
'Option Explicit
Private Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Dim miRuta, RutaArchSal, mi_Ct, carpetaSalida As String
Dim vNum
Dim db As Database
Sub main()
Dim user_rst As Recordset
Set db = CurrentDb
carpetaSalida = "T:\CONCENTRADO"
RutaArchSal = "C:\Users\Diego\Documents\"
On Error Resume Next
Kill RutaArchSal & "analisis.txt"
Open RutaArchSal & "analisis.txt" For Append As #2
vNum = 1
miRuta = "T:\CONCENTRADO"
On Error Resume Next
Mostrar_Archivos (miRuta)
MsgBox "Proceso terminado!"
Close #2
End Sub
Sub Mostrar_Archivos(ruta)
'Sección 1: Declaración de variables y objetos
Dim fs, carpeta, archivo, subcarpeta, miArchivo As Object
Set fs = CreateObject("Scripting.FileSystemObject")
'Sección 2: Ajustes necesarios a ruta
If ruta = "" Then
Exit Sub
ElseIf Right(ruta, 1) <> "" Then
ruta = ruta & ""
End If
'Sección 3: Objeto Folder de la ruta indicada
On Error GoTo ErrHandler
Set carpeta = fs.getfolder(ruta)
'Sección 4: Obtener archivos del objeto Folder
For Each archivo In carpeta.files
'VALIDA SI NOMBRE DE CARPETA ES CURP
If (archivo.Size > 300000) Then
If (archivo.Type <> "Archivo WinRAR ZIP") Then
Debug.Print vNum & " - PROCESANDO: " & archivo '& (Chr(13)) & archivo2
Print #2, vNum & " - COMPRIMIR " & archivo
vNum = vNum + 1
Shell "C:\Windows\explorer.exe " & carpeta, vbNormalFocus
res = VistaPrevia(archivo) 'Archivo que intenta agregar
MsgBox "CONTINUAR S/N ?", vbOKCancel
End If
End If
Next
'Sección 5: Obtener subcarpetas del objeto Folder
For Each subcarpeta In carpeta.SubFolders
If subcarpeta.Name <> "CONCENTRADO" Then
Mostrar_Archivos (subcarpeta)
End If
If (subcarpeta.Size = 0) Then
fs.deletefolder (subcarpeta)
End If
Next
Exit Sub
ErrHandler:
'ActiveCell.Value = "Ruta inexistente"
End Sub
'------------------------------------------------------------
' VistaPrevia
'------------------------------------------------------------
Public Function VistaPrevia(archivo)
On Error GoTo VistaPrevia_Err
ShellExecute 0&, vbNullString, archivo, vbNullString, vbNullString, vbNormalFocus
VistaPrevia_Exit:
'MsgBox archivo
Exit Function
VistaPrevia_Err:
MsgBox "PROGRAMA: ", vbInformation, Error$
Resume VistaPrevia_Exit
End Function
