[RETO] Ruta más oculta

[LeandroA]

Ojo dependiendo el método la función puede ser mas rápida la segunda vez que se ejecuta, por lo tanto debe medirse en varios bucles.

esta es la mia

Código (vb) [Seleccionar] Expandir


Option Explicit
Private Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" (ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long
Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As String) As Long

Private Const MAX_PATH                  As Long = 260
Private Const INVALID_HANDLE_VALUE      As Long = -1

Private Type FILETIME
    dwLowDateTime As Long
    dwHighDateTime As Long
End Type
 
Private Type WIN32_FIND_DATA
    dwFileAttributes As Long
    ftCreationTime As FILETIME
    ftLastAccessTime As FILETIME
    ftLastWriteTime As FILETIME
    nFileSizeHigh As Long
    nFileSizeLow As Long
    dwReserved0 As Long
    dwReserved1 As Long
    cFileName As String * MAX_PATH
    cAlternate As String * 14
End Type
 
Private c_cFolders  As Collection
Private m_Max As Long

Public Function GetLastFolder(ByVal sStartPath As String) As Collection
    m_Max = 0
    Set c_cFolders = New Collection
    sStartPath = IIf(Right$(sStartPath, 1) = "\", sStartPath, sStartPath & "\")
    pvFindFolders sStartPath, 0
    Set GetLastFolder = c_cFolders
End Function


Private Sub pvFindFolders(sPath As String, lMax As Long)
 
    Dim lRet                As Long
    Dim lhSearch            As Long
    Dim tWFD                As WIN32_FIND_DATA
    Dim svDirs()            As String
    Dim lCount              As Long
    Dim sDir                As String
    Dim i                   As Long
    Dim sFolder             As String

    lhSearch = FindFirstFile(sPath & "*", tWFD)
   
    If Not lhSearch = INVALID_HANDLE_VALUE Then
 
        Do
            If (tWFD.dwFileAttributes And vbDirectory) = vbDirectory Then

                sFolder = Left$(tWFD.cFileName, lstrlen(tWFD.cFileName))
                If InStrB(sFolder, ".") <> 1 Then
                    sDir = sPath & sFolder
 
                    ReDim Preserve svDirs(lCount)
                    svDirs(lCount) = sDir & "\"
                    lCount = lCount + 1
                   
                    If lMax > m_Max Then
                        m_Max = lMax
                        Set c_cFolders = New Collection
                        Call c_cFolders.Add(sDir)
                    ElseIf lMax = m_Max Then
                        Call c_cFolders.Add(sDir)
                    End If

                End If
            End If
 
            lRet = FindNextFile(lhSearch, tWFD)
        Loop While lRet
       
        Call FindClose(lhSearch)
   
   
        For i = 0 To lCount - 1
            Call pvFindFolders(svDirs(i), lMax + 1)
        Next
       
    End If

End Sub


Código (vb) [Seleccionar] Expandir

Option Explicit

Private Sub Form_Load()
   Dim cColl As Collection
   Dim i As Long
   
   Set cColl = GetLastFolder("C:\Users\Windows\")
   
   For i = 1 To cColl.Count
       Debug.Print cColl(i)
   Next
End Sub

[seba123neo]

aca va otra forma, igual a la que usa Dir$ que puse antes, pero esta es recursiva y usa apis, lo cual es muchisimo mas rapida.

la anterior funcion me tarda 7 segundos en escanear la carpeta de program files de mi pc (que tiene 7 mil carpetas), esta solo tarda 1 segundo  y a veces menos .

Código (vb) [Seleccionar] Expandir

Option Explicit

Private Const vbDot = 46
Private Const MAXDWORD As Long = &HFFFFFFFF
Private Const MAX_PATH As Long = 260
Private Const INVALID_HANDLE_VALUE = -1
Private Const FILE_ATTRIBUTE_DIRECTORY = &H10

Private Type FILETIME
   dwLowDateTime As Long
   dwHighDateTime As Long
End Type

Private Type WIN32_FIND_DATA
   dwFileAttributes As Long
   ftCreationTime As FILETIME
   ftLastAccessTime As FILETIME
   ftLastWriteTime As FILETIME
   nFileSizeHigh As Long
   nFileSizeLow As Long
   dwReserved0 As Long
   dwReserved1 As Long
   cFileName As String * MAX_PATH
   cAlternate As String * 14
End Type

Private Type FILE_PARAMS
   bRecurse As Boolean
   sFileRoot As String
   sFileNameExt As String
   sResult As String
   sMatches As String
   Count As Long
End Type

Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long
Private Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" (ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long

Dim vCarpetas As New Collection

Private Sub Command1_Click()
   Call CarpetaMasProfunda("c:\program files (x86)")
   
   Dim vResult As String
   vResult = ""

   Dim vArr() As String
   Dim vCont As Integer
   Dim i As Integer

   For i = 1 To vCarpetas.Count

       vArr = Split(vCarpetas(i), "\")

       If UBound(vArr) > vCont Then
           vCont = UBound(vArr)
           vResult = vCarpetas(i)
       End If
   Next i
   
   MsgBox vResult
End Sub

Private Sub CarpetaMasProfunda(ByVal pPath As String)

   Dim FP As FILE_PARAMS
   
   With FP
      .sFileRoot = pPath
      .sFileNameExt = "*.*"
      .bRecurse = 1
   End With

   Dim WFD As WIN32_FIND_DATA
   Dim hFile As Long
   Dim sRoot As String
   Dim spath As String
   Dim sTmp As String
   
   sRoot = QualifyPath(FP.sFileRoot)
   spath = sRoot & FP.sFileNameExt

   hFile = FindFirstFile(spath, WFD)

   If hFile <> INVALID_HANDLE_VALUE Then
         
      Do
         
         If (WFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) And Asc(WFD.cFileName) <> vbDot Then
           
            sTmp = TrimNull(WFD.cFileName)
                       
            FP.Count = FP.Count + 1
            vCarpetas.Add sRoot & sTmp
           
            If FP.bRecurse Then
           
               FP.sFileRoot = sRoot & sTmp
               Call CarpetaMasProfunda(FP.sFileRoot)
           
            End If

         End If
         
      Loop While FindNextFile(hFile, WFD)
     
      hFile = FindClose(hFile)
   End If
End Sub

Private Function TrimNull(pStart As String) As String
   Dim vPos As Integer
   
   vPos = InStr(pStart, Chr$(0))
   
   If vPos Then
      TrimNull = Left$(pStart, vPos - 1)
      Exit Function
   End If
 
   TrimNull = pStart
End Function

Private Function QualifyPath(pPath As String) As String
   If Right$(pPath, 1) <> "\" Then
      QualifyPath = pPath & "\"
   Else
      QualifyPath = pPath
   End If
End Function

saludos.

[Karcrack]

Para aumentar la velocidad deberíais llamar a FindFirstFileEx() usando estos flags:

Código (cpp) [Seleccionar] Expandir

hFind = FindFirstFileEx(path, FindExInfoBasic, pCurrent, FindExSearchLimitToDirectories, NULL, FIND_FIRST_EX_LARGE_FETCH);

Aunque FindExInfoBasic y FIND_FIRST_EX_LARGE_FETCH sólo sirven de W$>Vista aumentarán mucho la velocidad en llamadas recurrentes. Y con FindExSearchLimitToDirectories también aunque tiene que ser cierta versión de NTFS...

Yo hice una vez algo similar en C++ pero no he conseguido encontrar el código

[BlackZeroX]

pues aca te pongo algo simple con Dir$, no creo que sea lo mas rapido, seguro alguna recursiva podra ser mas veloz, como con FSO, pero por lo menos cumple el objetivo.

Creo que querías decir iterativa, la recursividad es lenta...

A reinstalar VB6 canijo!¡.

Dulces Lunas!¡.

[LeandroA]

Si es verdad FindFirstFileEx es un poco mas rapida, almenos vajo W7 o W8 aqui para que prueben, la diferencia se nota si utilizan las flags FindExInfoBasic  o FindExInfoStandard, la primera hace que la funcion no rellene  cAlternate de la extructura WIN32_FIND_DATA, con lo cual hace que sea has rapida.

Código (vb) [Seleccionar] Expandir


Option Explicit
Private Declare Function FindFirstFileEx Lib "kernel32.dll" Alias "FindFirstFileExA" (ByVal lpFileName As String, ByVal fInfoLevelId As FINDEX_INFO_LEVELS, lpFindFileData As WIN32_FIND_DATA, ByVal fSearchOp As FINDEX_SEARCH_OPS, ByRef lpSearchFilter As Any, ByVal dwAdditionalFlags As Long) As Long
Private Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" (ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long
Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As String) As Long
Private Declare Function GetTickCount Lib "kernel32.dll" () As Long
Private Declare Function GetVersion Lib "kernel32.dll" () As Long

Private Const MAX_PATH                  As Long = 260
Private Const INVALID_HANDLE_VALUE      As Long = -1

Private Type FILETIME
   dwLowDateTime As Long
   dwHighDateTime As Long
End Type

Private Type WIN32_FIND_DATA
   dwFileAttributes As Long
   ftCreationTime As FILETIME
   ftLastAccessTime As FILETIME
   ftLastWriteTime As FILETIME
   nFileSizeHigh As Long
   nFileSizeLow As Long
   dwReserved0 As Long
   dwReserved1 As Long
   cFileName As String * MAX_PATH
   cAlternate As String * 14
End Type

Private Enum FINDEX_INFO_LEVELS
   FindExInfoStandard
   FindExInfoBasic
   FindExInfoMaxInfoLevel
End Enum

Private Enum FINDEX_SEARCH_OPS
   FindExSearchNameMatch
   FindExSearchLimitToDirectories
   FindExSearchLimitToDevices
   FindExSearchMaxSearchOp
End Enum

'FIND FLAGS
Private Const FIND_FIRST_EX_CASE_SENSITIVE = 0
Private Const FIND_FIRST_EX_LARGE_FETCH = 2

Private c_cFolders  As Collection
Private m_Max As Long
Private m_IsW7OrLater As Boolean

Public Function GetLastFolder(ByVal sStartPath As String) As Collection
   Dim lR As Long
   
   lR = GetVersion
   If ((lR And &HFF) > 5) And (((lR And &HFF00&) \ &H100) > 0) Then m_IsW7OrLater = True
   m_Max = 0
   Set c_cFolders = New Collection
   sStartPath = IIf(Right$(sStartPath, 1) = "\", sStartPath, sStartPath & "\")
   pvFindFolders sStartPath, 0
   Set GetLastFolder = c_cFolders
End Function


Private Sub pvFindFolders(sPath As String, lMax As Long)

   Dim lRet                As Long
   Dim lhSearch            As Long
   Dim tWFD                As WIN32_FIND_DATA
   Dim svDirs()            As String
   Dim lCount              As Long
   Dim sDir                As String
   Dim i                   As Long
   Dim sFolder             As String

   
   If m_IsW7OrLater Then
       lhSearch = FindFirstFileEx(sPath & "*", FindExInfoBasic, tWFD, FindExSearchNameMatch, 0&, FIND_FIRST_EX_LARGE_FETCH)
   Else
       lhSearch = FindFirstFileEx(sPath & "*", FindExInfoStandard, tWFD, FindExSearchNameMatch, 0&, FIND_FIRST_EX_CASE_SENSITIVE)
   End If
   'lhSearch = FindFirstFile(sPath & "*", tWFD)
   
   If Not lhSearch = INVALID_HANDLE_VALUE Then

       Do
           If (tWFD.dwFileAttributes And vbDirectory) = vbDirectory Then

               sFolder = Left$(tWFD.cFileName, lstrlen(tWFD.cFileName))
               If InStrB(sFolder, ".") <> 1 Then
                   sDir = sPath & sFolder

                   ReDim Preserve svDirs(lCount)
                   svDirs(lCount) = sDir & "\"
                   lCount = lCount + 1

                   If lMax > m_Max Then
                       m_Max = lMax
                       Set c_cFolders = New Collection
                       Call c_cFolders.Add(sDir)
                   ElseIf lMax = m_Max Then
                       Call c_cFolders.Add(sDir)
                   End If

               End If
           End If

           lRet = FindNextFile(lhSearch, tWFD)
       Loop While lRet

       Call FindClose(lhSearch)


       For i = 0 To lCount - 1
           Call pvFindFolders(svDirs(i), lMax + 1)
       Next

   End If

End Sub



Private Sub Form_Load()
   Dim cColl As Collection
   Dim i As Long
   Dim T As Long

   T = GetTickCount
   Set cColl = GetLastFolder("C:\Users\Windows\")
   Debug.Print GetTickCount - T

   For i = 1 To cColl.Count
       Debug.Print cColl(i)
   Next
End Sub


[Karcrack]

@LeandroA: Si filtras las carpetas que contengan un punto vas a quitar varias carpetas a parte de las relativas "." y "..". Como (en mi caso) .ssh, .designer...
Por cierto, tal y como tienes el código sería fácil hacer la búsqueda de forma iterativa en lugar de recursiva... ¿No sería mucho más rápido?

[LeandroA]

Hola Karcrack, en principio pense que no se podia crear una carpeta con un punto por delante, almenos el explorer de windows no te deja, ahora que lo mencionas cree una carpeta con el vb y si se pude, asi que si hay que modificar ese filtro
no entiendo la diferncia de  iterativa a recursiva, como seria iterativa?

Saludos.

[MCKSys Argentina]

La carpeta (o directorio) "." es la carpeta actual.

Si haces en un cmd un "dir .", es lo mismo que hacer solo "dir": Lista el contenido del directorio actual.

[Karcrack]

@LeandroA: Sin llamarte a ti mismo. Haciendo otro bucle antes de FindFirstFileEx cambiando sPath y lMax

Las carpetas empezando por "." son muy comunes en %APPDATA% o %USERPROFILE%. Muchas aplicaciones las crean.