Pues eso, consiste en encontrar la manera más rápida de obtener la última carpeta accesible a partir de una ruta, los formatos válidos son estos:
Public Function getLastFolder(Byval sStartPath As String) As String()
Public Function getLastFolder(Byval sStartPath As String) As Collection
Ejemplo:
Debug.Print getLastFolder("C:\Users\casa-pc\Desktop\")
C:\Users\casa-pc\Desktop\Música\Sonido\Programas\Video\VLC\data\res
Consiste en encontrar la carpeta más profunda, en caso de haber más de una la función devolverá el resultado en una collection o en un array.
¡Suerte! :)
Pero tu tienes otras carpetas ademas de Musica en el Desktop no? xD
Es decir, si tengo 20 carpetas, pero solo una de ellas tiene mas carpetas dentro, entonces esta ultima es la que hay que buscar su ultima carpeta no?
Claro, hay que sacar la ruta más profunda. ;)
DoEvents! :P
No tengo instalado el VB6 pero queria pensarlo por lo menos. Si nadie contesta deja tu codigo que quiero verlo, se que tendras algo interesante xD
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.
Option Explicit
Private Function CarpetaMasProfunda(ByVal pPath As String)
Dim vCarpetas As New Collection
Dim vNext As Integer
Dim vDir As String
Dim vSubDir As String
Dim vResult As String
vNext = 1
vCarpetas.Add pPath
Do While vNext <= vCarpetas.Count
vDir = vCarpetas(vNext)
vNext = vNext + 1
vSubDir = Dir$(vDir & "\*", vbDirectory)
Do While vSubDir <> ""
If vSubDir <> "." And vSubDir <> ".." Then
vSubDir = vDir & "\" & vSubDir
On Error Resume Next
If GetAttr(vSubDir) And vbDirectory Then vCarpetas.Add vSubDir
End If
vSubDir = Dir$(, vbDirectory)
Loop
Loop
'---------------------------------------------------------------------
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
CarpetaMasProfunda = vResult
End Function
Private Sub Form_Load()
MsgBox CarpetaMasProfunda("C:\Program Files")
End Sub
lo probe con una carpeta con 10 mil carpetas adentro y en unos 10 segundos me muestra el path mas largo.
saludos.
Tampoco tengo VB acá, pero se me ocurre hacer un comando dir, guardar el resultado en un txt y parsear lineas buscando la que tiene mas barras "\", osea, el path mas profundo.
El comando dir sería:
dir * /ad /s /b > c:\lista.txt
donde "c:\lista.txt" sería el path completo al archivo donde se guardan los dirs.
Despues se abre, se recorre linea 1 a 1 y se devuelve la mas profunda (contando las barras invertidas "\")
Si hago tiempo subo code.
Saludos!
Cita de: MCKSys Argentina en 11 Enero 2013, 23:53 PM
Tampoco tengo VB acá, pero se me ocurre hacer un comando dir, guardar el resultado en un txt y parsear lineas buscando la que tiene mas barras "\", osea, el path mas profundo.
El comando dir sería:
dir * /ad /s /b > c:\lista.txt
donde "c:\lista.txt" sería el path completo al archivo donde se guardan los dirs.
Despues se abre, se recorre linea 1 a 1 y se devuelve la mas profunda (contando las barras invertidas "\")
Si hago tiempo subo code.
Saludos!
Cometi el error de copypastear tu codigo en una CMD.
CUIDADO CON EL PESO DEL TXT!
Cita de: Elemental Code en 12 Enero 2013, 00:41 AM
Cometi el error de copypastear tu codigo en una CMD.
CUIDADO CON EL PESO DEL TXT!
:xD
Si, hice un par de pruebas mas y vi que puede obtenerse un archivo grande, aunque habría que hacer algunas comparativas para ver si el método conviene o no...
Ni bien tenga VB a mano, armo code y copio...
EDIT: Mi intento
Option Explicit
Public Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Public Declare Function GetTempFileName Lib "kernel32" Alias "GetTempFileNameA" (ByVal lpszPath As String, ByVal lpPrefixString As String, ByVal wUnique As Long, ByVal lpTempFileName As String) As Long
Public Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As String) As Long
Const sEmpty = ""
Const cMaxPath = 260
Const cmDbl = """"
Public Function getDeeperPath(Folder As String) As String
'Function does not check if Folder is a valid path name
'Folder must NOT end with backslash (\)
Dim tmpFilePath As String
Dim sComm As String
Dim taskId As Long
Dim sLine As String
Dim lDepth As Long
Dim mPaths() As String
Dim curDeeperFolder As String
tmpFilePath = GetTempFile
sComm = "cmd /c dir " + cmDbl + Folder + "\*" + cmDbl + " /ad /s /b > " + cmDbl + tmpFilePath + cmDbl
Err.Clear
On Error GoTo Hell
taskId = Shell(sComm, vbHide)
Do While FileLen(tmpFilePath) = 0
DoEvents
Loop
lDepth = 0
curDeeperFolder = sEmpty
Open tmpFilePath For Input Access Read As #1
Do While Not EOF(1)
Line Input #1, sLine
If sLine <> sEmpty Then
If InStr(1, sLine, "\") > 0 Then
mPaths = Split(sLine, "\")
If UBound(mPaths) > lDepth Then
lDepth = UBound(mPaths)
curDeeperFolder = sLine
End If
End If
End If
Loop
Close #1
Kill tmpFilePath
getDeeperPath = curDeeperFolder
Exit Function
Hell:
MsgBox "Error in getDeeperPath: " & Err.Description
End Function
Function GetTempDir() As String
Dim sRet As String, c As Long
sRet = String(cMaxPath, 0)
c = GetTempPath(cMaxPath, sRet)
'If c = 0 Then ApiRaise Err.LastDllError
GetTempDir = Left$(sRet, c)
End Function
Function GetTempFile(Optional Prefix As String, Optional PathName As String) As String
Dim sRet As String
If Prefix = sEmpty Then Prefix = sEmpty
If PathName = sEmpty Then PathName = GetTempDir
sRet = String(260, 0)
GetTempFileName PathName, Prefix, 0, sRet
'GetTempFile = GetFullPath(StrZToStr(sRet))
GetTempFile = StrZToStr(sRet)
End Function
' Strip junk at end from null-terminated string
Function StrZToStr(s As String) As String
StrZToStr = Left$(s, lstrlen(s))
End Function
ATENCIÓN: He añadido un detalle en la explicación del reto.
La forma que se me había ocurrido es similar a la de
seba123neo... Pero estoy convencido de que se puede hacer sin guardar todas las carpetas, se ahorraría muchísimo tiempo. Sigo pensando. :rolleyes:
Cita de: Elemental Code en 12 Enero 2013, 00:41 AM
Cometi el error de copypastear tu codigo en una CMD.
CUIDADO CON EL PESO DEL TXT!
(http://www.computerandyou.net/wp-content/uploads/2012/11/You-have-been-hacked.jpg)
:laugh:
DoEvents! :P
Yo tenia algo pensado como BackTracking, se demoraria muchisimo pero el codigo seria mas corto que todos xD
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
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 :xD.
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.
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 :laugh:
Cita de: seba123neo en 11 Enero 2013, 21:30 PM
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!¡.
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.
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
@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?
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.
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.
@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.