Listar Ficheros

Hola que tal,.. bastante ayuda me han dado en estos dias,.. tengo un codigo
que es de Fernando Arroyo, pro me esta saliendo algo mal,.. "Se ha producido
el error '429' en tiempo de ejecucion: el componente ActiveX no puede crear
el objeto"

Haber si me pueden ayudar, no he visto a Fernando en respuesta por aqui de
algun foro, aquizas se encuentre ausente, peor tengo la seguridad de que un
amigo de aqui o de los Master me ayudara,.. gracias y hasta pronto.

saludos
- aqui estampo el codigo
Public wksH As Worksheet

Public lngContFila As Long



Sub Llamar()

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 = "C:\Datos\Excel" 'Ruta que se procesará



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



For Each tmpFichero In fCarpeta.Files



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



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



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



Set wksH = Nothing

End Sub



Public 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

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