Listado de ficheros en un directorio - extensiones

hola, Miguel !

Tengo hace bastante timepo una macro que copie de este foro, para listar los archivos de un directorio
y me gustaria saber si hay algun parametro que me de el tipo de extension que tiene el archivo.
Es decir si termina en .xls - archivo de excel, .doc - archivo de word, etc. etc.

(si transtribes "la macro"... seria mas facil sugerir algun cambio o adaptacion) :-(( en via de mientras...

el siguiente ejemplo (que puedes adaptar para otras necesidades)...
1) toma la carpeta predeterminada que pongas en 'A1' (p.e. -> c:uta y\sub-carpeta)
2) pone en el rango 'A2:E2' los titulos para los atributos de los archivos
3) a partir de la fila 3, vacia los nombres de los archivos que se encuentren (y sus atributos)

si cualquier duda (o informacion adicional)... comentas ?
saludos,
hector.

' en un modulo de codigo 'normal' ==
Sub Lista_de_archivos()
Application.ScreenUpdating = False
Dim Carpeta As String: Carpeta = Range("a1"): Cells.Clear
Range("a2:e2") = Array("Ruta", "Nombre", "Tamaño", "Modificado", "Tipo")
Listar_archivos_en Carpeta, True
End Sub

Sub Listar_archivos_en(Carpeta As String, Completo As Boolean)
Dim Archivo, SubCarpeta, Fila As Long
Fila = Range("a65536").End(xlUp).Row + 1
With CreateObject("scripting.filesystemobject")
With .GetFolder(Carpeta)
For Each Archivo In .Files
With Archivo
Range("a" & Fila & ":e" & Fila) = Array( _
Application.Substitute(.Path, .Name, ""), .Name, .Size, .DateLastModified, .Type)
End With
Fila = Fila + 1
Next
If Completo Then
For Each SubCarpeta In .SubFolders
Listar_archivos_en SubCarpeta.Path, True
Next
End If
End With
End With
Range("a1:e1").EntireColumn.AutoFit
Range("a1") = Carpeta
Debug.Print ActiveSheet.UsedRange.Address
End Sub

Muy buenas:
La verdad es que si ayudaría bastante, y siempre lo decís, pero como sois
tan buenos vislumbráis lo que queremos decir con insinuarlo. Gracias con el
type era suficiente.
De todas formas adjunto la macro por si alguien lee el post y le puede
servir, ya la he modificado para incluir el tipo de fichero.

Muchas gracias.

Option Explicit

'32-bit API declarations
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
Public strExtensión As String

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
strExtensión = LCase(Application.InputBox(prompt:="Si desea que sólo se
listen los ficheros con una extensión determinada, introdúzcala sin el punto
(deje en blanco para que se listen todos los ficheros)", Type:=2))

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"
wksH.Range("F1") = "Tipo de Fichero"

lngContFila = 2

Application.ScreenUpdating = False

For Each tmpFichero In fCarpeta.Files
If strExtensión = "" Or LCase(fso.getextensionname(tmpFichero)) =
strExtensión Then
wksH.Cells(lngContFila, 1) = fCarpeta.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
wksH.Cells(lngContFila, 6) = tmpFichero.Type

lngContFila = lngContFila + 1
If lngContFila > 65535 Then
MsgBox prompt:="Demasiados ficheros.", Buttons:=vbCritical +
vbOKOnly, Title:="EscribirEnArchivos"
Exit Sub
End If
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:F1").HorizontalAlignment = xlCenter
.Range("A1:F1").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:F").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
If strExtensión = "" Or LCase(fso.getextensionname(tmpFichero))
= strExtensión Then
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
wksH.Cells(lngContFila, 6) = tmpFichero.Type

lngContFila = lngContFila + 1
If lngContFila > 65535 Then
Application.ScreenUpdating = True
MsgBox prompt:="Demasiados ficheros.",
Buttons:=vbCritical + vbOKOnly, Title:="EscribirEnArchivos"
Exit Sub
End If
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




"Héctor Miguel" escribió:

hola, Miguel !

> Tengo hace bastante timepo una macro que copie de este foro, para listar los archivos de un directorio
> y me gustaria saber si hay algun parametro que me de el tipo de extension que tiene el archivo.
> Es decir si termina en .xls - archivo de excel, .doc - archivo de word, etc. etc.

(si transtribes "la macro"... seria mas facil sugerir algun cambio o adaptacion) :-(( en via de mientras...

el siguiente ejemplo (que puedes adaptar para otras necesidades)...
1) toma la carpeta predeterminada que pongas en 'A1' (p.e. -> c:uta y\sub-carpeta)
2) pone en el rango 'A2:E2' los titulos para los atributos de los archivos
3) a partir de la fila 3, vacia los nombres de los archivos que se encuentren (y sus atributos)

si cualquier duda (o informacion adicional)... comentas ?
saludos,
hector.

' en un modulo de codigo 'normal' ==>
Sub Lista_de_archivos()
Application.ScreenUpdating = False
Dim Carpeta As String: Carpeta = Range("a1"): Cells.Clear
Range("a2:e2") = Array("Ruta", "Nombre", "Tamaño", "Modificado", "Tipo")
Listar_archivos_en Carpeta, True
End Sub

Sub Listar_archivos_en(Carpeta As String, Completo As Boolean)
Dim Archivo, SubCarpeta, Fila As Long
Fila = Range("a65536").End(xlUp).Row + 1
With CreateObject("scripting.filesystemobject")
With .GetFolder(Carpeta)
For Each Archivo In .Files
With Archivo
Range("a" & Fila & ":e" & Fila) = Array( _
Application.Substitute(.Path, .Name, ""), .Name, .Size, .DateLastModified, .Type)
End With
Fila = Fila + 1
Next
If Completo Then
For Each SubCarpeta In .SubFolders
Listar_archivos_en SubCarpeta.Path, True
Next
End If
End With
End With
Range("a1:e1").EntireColumn.AutoFit
Range("a1") = Carpeta
Debug.Print ActiveSheet.UsedRange.Address
End Sub


.