 Autor
|
Tema: [RETO] Ruta más oculta (Leído 6,865 veces)
|
|
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 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
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
|
|
|
|
« Última modificación: 12 Enero 2013, 20:55 pm por LeandroA »
|
En línea
|
|
|
|
|
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  . 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.
|
|
|
|
|
En línea
|
|
|
|
Karcrack
 Desconectado
Mensajes: 2.416
Se siente observado ¬¬'
|
Para aumentar la velocidad deberíais llamar a FindFirstFileEx() usando estos flags: 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  |
|
|
|
|
En línea
|
|
|
|
BlackZeroX
Wiki
Desconectado
Mensajes: 3.158
I'Love...!¡.
|
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!¡.
|
|
|
|
|
En línea
|
The Dark Shadow is my passion.
|
|
|
|
LeandroA
|
Si es verdad FindFirstFile Ex 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. 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
|
|
|
|
« Última modificación: 15 Enero 2013, 02:04 am por LeandroA »
|
En línea
|
|
|
|
Karcrack
Desconectado
Mensajes: 2.416
Se siente observado ¬¬'
|
@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?
|
|
|
|
|
En línea
|
|
|
|
|
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.
|
|
|
|
|
En línea
|
|
|
|
|
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.
|
|
|
|
|
En línea
|
MCKSys Argentina "Si piensas que algo está bien sólo porque todo el mundo lo cree, no estás pensando." |
|
|
Karcrack
Desconectado
Mensajes: 2.416
Se siente observado ¬¬'
|
@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.
|
|
|
|
|
En línea
|
|
|
|
|
 |
