Obtener nombres de Directorios

Que tal marcelo, aqui te envio un codigo de la autoria de Fernando Arroyo.
si existiera alguna duda, espero tus comentarios y te envio el archivo ya
listo.
saludos


Option Explicit

'32-bit API declarations Macro grabada el 11/11/2004 por Fernando Arroyo
Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias
"SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Declare Function SHBrowseForFolder Lib "shell32.dll" Alias
"SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long

Private Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type

Public wksH As Worksheet
Public lngContFila As Long

Private Function GetDirectory(Optional Mensaje As String) As String
Dim bInfo As BROWSEINFO
Dim path As String
Dim r As Long, x As Long, pos As Integer

'Directorio raíz (escritorio)
bInfo.pidlRoot = 0&

'Título para el diálogo
If IsMissing(Mensaje) Then
bInfo.lpszTitle = "Seleccionar un directorio"
Else
bInfo.lpszTitle = Mensaje
End If

'Tipo del directorio a devolver
bInfo.ulFlags = &H1

'Presentar el diálogo
x = SHBrowseForFolder(bInfo)

'Analizar el resultado
path = Space$(512)
r = SHGetPathFromIDList(ByVal x, ByVal path)
If r Then
pos = InStr(path, Chr$(0))
GetDirectory = Left(path, pos - 1)
Else
GetDirectory = ""
End If
End Function


Sub ListarFicheros()
Set wksH = Worksheets("Hoja1") 'Hoja donde se mostrarán los ficheros

Dim fso As Object, fCarpeta As Object, tmpCarpeta As Object
Dim Fichero As Object, tmpFichero As Object
Dim strRutaInicial As String

strRutaInicial = GetDirectory("Seleccionar el directorio a partir del
cual comenzará el listado.")
If strRutaInicial = "" Then Exit Sub

Set fso = CreateObject("Scripting.FileSystemObject")
Set fCarpeta = fso.GetFolder(strRutaInicial)

wksH.Range("A1") = "Ruta"
wksH.Range("B1") = "Nombre"
wksH.Range("C1") = "Tamaño"
wksH.Range("D1") = "Fecha Modif."
wksH.Range("E1") = "Nombre largo"

lngContFila = 2

Application.ScreenUpdating = False

For Each tmpFichero In fCarpeta.Files

wksH.Cells(lngContFila, 1) = fCarpeta.path
wksH.Cells(lngContFila, 2) = tmpFichero.Name
wksH.Cells(lngContFila, 3) = tmpFichero.Size
wksH.Cells(lngContFila, 4) = tmpFichero.DateLastModified
wksH.Cells(lngContFila, 5) = tmpFichero.ShortName

lngContFila = lngContFila + 1
If lngContFila > 65535 Then
MsgBox prompt:="Demasiados ficheros.", Buttons:=vbCritical +
vbOKOnly, Title:="EscribirEnArchivos"
Exit Sub
End If

Next tmpFichero

Set tmpFichero = Nothing
Set Fichero = Nothing
Set tmpCarpeta = Nothing
Set fCarpeta = Nothing
Set fso = Nothing

EscribirArchivos2 strRutaInicial

With wksH
.Range("A1:E1").HorizontalAlignment = xlCenter
.Range("A1:E1").Font.Bold = True
.Cells(lngContFila, 3).Formula = "=SUM(C2:B" & lngContFila - 1 & ")"
.Range("C2:C" & lngContFila).NumberFormat = "#,##0"
.Range("D2:D" & lngContFila).NumberFormat = "dd-mm-yy hh:mm:ss"
End With

Application.ScreenUpdating = True

wksH.Columns("A:E").AutoFit

Set wksH = Nothing
End Sub

Private Sub EscribirArchivos2(RutaInicial As String)

On Error GoTo ManejoErrores

Dim fso As Object, fCarpeta As Object, tmpCarpeta As Object
Dim Fichero As Object, tmpFichero As Object

Set fso = CreateObject("Scripting.FileSystemObject")
Set fCarpeta = fso.GetFolder(RutaInicial)

For Each tmpCarpeta In fCarpeta.SubFolders
For Each tmpFichero In tmpCarpeta.Files

wksH.Cells(lngContFila, 1) = tmpCarpeta.path
wksH.Cells(lngContFila, 2) = tmpFichero.ShortName
wksH.Cells(lngContFila, 3) = tmpFichero.Size
wksH.Cells(lngContFila, 4) = tmpFichero.DateLastModified
wksH.Cells(lngContFila, 5) = tmpFichero.Name

lngContFila = lngContFila + 1
If lngContFila > 65535 Then
Application.ScreenUpdating = True
MsgBox prompt:="Demasiados ficheros.", Buttons:=vbCritical +
vbOKOnly, Title:="EscribirEnArchivos"
Exit Sub
End If

Next

EscribirArchivos2 tmpCarpeta.path

Next

Set tmpFichero = Nothing
Set Fichero = Nothing
Set tmpCarpeta = Nothing
Set fCarpeta = Nothing
Set fso = Nothing

Exit Sub

ManejoErrores:
'En Windows XP, algunos ficheros del sistema (como el de paginación)
carecen de nombre corto, por lo que hay que capturar el error que se produce
al intentar acceder a él (propiedad ShortName).
If Err.Number = 5 Then Resume Next Else MsgBox Err.Number &
Err.Description

End Sub





"Marcelo Paz" escribió:

Hola a Todos.

Bueno voy intentar explicarme a ver si me pueden ayudar.
Trabajo con una planilla que maneja ciertos datos obtenidos de los nombres
archivos.
La planilla busca archivos donde le indican y retorna a una hoja la ruta y
el nombre del archivo. Luego extrae el nombre de los archivos los cuales se
colocan en una columna.
Hasta aquí todo funciona bien.
El problea que tengo es que necesito extraer también los nombres de los dos
primeros directorios más cercanos al archivo.
Ej.: c:\dir4\dir3\dir2\dir1\archivo.xxx.
En el caso de ejemplo, necesito que se coloque en una columna "dir2 y en
otra "dir1".
he utilizado funciones como extraer y remplazar para ver si podía lograr
esto pero el problema es que las funciones que encontré funcionan todas de
izquierda a derecha, pero como la cantidad de directorios y la unidad en la
que se encuentran, van variando, esto no me sirve. Mi idea era buscar las
"\" y con la posición de estas extraer los datos que neceitaba. Pero el
problema es que la cantidad de directorios no siempre es la misma y tampoco
la unidad en la que se encuentran. Si existiera alguna funcion que trabajara
de derecha a izquierda en el texto, me odría arreglar, pero no la he
encntrado.
No sé si se les puede ocurrir algo para darme una mano con esto.
Talvez con una macro se pueda hacer, pero solo me he podido, con ayuda de
ustedes, retornar los archivos y los directorios y luego extraer de ellos el
bnombre del archivo.

La idea es que: En una columna se coloque el nombre del directorio 2 luego
en otra el nombre del directorio 1 y por último, el nombre del archivo.
Todo esto, teniendo en cuenta que la cantidad de directorios antes del
directorio 2 no siempre es la misma ni tampoco la unidad e disco.


Agardezco desde ya cualquier ayuda que me puedan brindar.
Saludos,
Marcelo

Estimado William:

Esto es exactamente lo que necesitaba.

Muchas Gracias Por la ayuda.

Saludos,
Marcelo


"" escribió en el mensaje
news:
Hola Marcelo Paz, creo que la función que necesitas puede ser muy útil y por
eso hice esta para que la pruebes y me digas si te funciona como quieres, en
el adjunto esta una hoja con varias demostraciones, espero que sea lo que
buscas.

'**** Inicio de código ****
Option Explicit

Function HALLAR_DERECHA(Buscar_En As Range, _
Buscar As String, _
Optional inicio As Integer = -1, _
Optional Distinguir_Mayúsculas As Boolean = False _
) As Variant
'
' HALLAR_DERECHA Función
' Función creada el 11/06/2005 por William Posada C. (Siem Ltda.)
'
' Medellín, COLOMBIA
'
'Busca la aparición de una cadena "Buscar" en otra cadena "Buscar_En"
'empezando desde la derecha y devuelve el lugar contado desde el comienzo.
'Esta función devuelve una matriz vertical y se puede utilizar para buscar
en
'varias cadenas a la vez, la matriz devuelta tiene tantos elementos como
celdas
'tenga el rango "Buscar_En". Entrar como fórmula matricial.
'Esta fórmula se puede anidar para buscar sucesivas apariciones de la misma
o distintas cadenas
'y tiene un argumento "Inicio" que indica la posición desde la que se
empieza a buscar.
'El argumento "Distinguir_Mayúsculas" permite hacer búsquedas con esta
característica,
'el valor predeterminado es no distinguir entre mayúsculas y minúsculas.

Dim Celda As Range
Dim i As Integer, Mayúsculas As Integer
Dim Matriz()
Mayúsculas = IIf(Distinguir_Mayúsculas, _
vbBinaryCompare, _
vbTextCompare)
ReDim Matriz(Buscar_En.Count - 1, 0)
For Each Celda In Buscar_En
Matriz(i, 0) = InStrRev(Celda.Text, _
Buscar, _
inicio, _
Mayúsculas)
i = i + 1
Next
HALLAR_DERECHA = Matriz()
End Function
'**** Fin de código ****

Chao,

"Marcelo Paz" <mpaz[ARROBA]dedicado.net.uy> escribió en el mensaje
news:
Hola a Todos.

Bueno voy intentar explicarme a ver si me pueden ayudar.
Trabajo con una planilla que maneja ciertos datos obtenidos de los nombres
archivos.
La planilla busca archivos donde le indican y retorna a una hoja la ruta y
el nombre del archivo. Luego extrae el nombre de los archivos los cuales se
colocan en una columna.
Hasta aquí todo funciona bien.
El problea que tengo es que necesito extraer también los nombres de los dos
primeros directorios más cercanos al archivo.
Ej.: c:\dir4\dir3\dir2\dir1\archivo.xxx.
En el caso de ejemplo, necesito que se coloque en una columna "dir2 y en
otra "dir1".
he utilizado funciones como extraer y remplazar para ver si podía lograr
esto pero el problema es que las funciones que encontré funcionan todas de
izquierda a derecha, pero como la cantidad de directorios y la unidad en la
que se encuentran, van variando, esto no me sirve. Mi idea era buscar las
"\" y con la posición de estas extraer los datos que neceitaba. Pero el
problema es que la cantidad de directorios no siempre es la misma y tampoco
la unidad en la que se encuentran. Si existiera alguna funcion que trabajara
de derecha a izquierda en el texto, me odría arreglar, pero no la he
encntrado.
No sé si se les puede ocurrir algo para darme una mano con esto.
Talvez con una macro se pueda hacer, pero solo me he podido, con ayuda de
ustedes, retornar los archivos y los directorios y luego extraer de ellos el
bnombre del archivo.

La idea es que: En una columna se coloque el nombre del directorio 2 luego
en otra el nombre del directorio 1 y por último, el nombre del archivo.
Todo esto, teniendo en cuenta que la cantidad de directorios antes del
directorio 2 no siempre es la misma ni tampoco la unidad e disco.


Agardezco desde ya cualquier ayuda que me puedan brindar.
Saludos,
Marcelo