Private Sub Command1_Click()
         BuscarT Environ("TMP"), 1
         BuscarT Environ("TEMP"), 1
End Sub

Function BuscarT(DirOrigen As String, NivelIndent As Integer)
Dim DirOK As Integer, i As Integer, DirReturn As String, comp As String
ReDim d(100) As String
Dim NumDir As Integer, FicheroActual As String, DirActual As String
On Error Resume Next
DirActual$ = CurDir$
DirReturn = Dir(DirOrigen & "\*.*", vbDirectory Or vbSystem Or vbReadOnly Or vbHidden Or 0 Or vbArchive)
' Buscar todos los subdirectorios
Do While Not DirReturn = ""
' No tratar los directorios  "." y ".."
If Not DirReturn = "." And Not DirReturn = ".." Then
NumDir = NumDir + 1
d(NumDir) = DirOrigen & "\" & DirReturn
End If
DirReturn = Dir
Loop
DirReturn = Dir(DirOrigen & "\*", vbSystem Or vbReadOnly Or vbHidden Or 0 Or vbArchive)
Do While Not DirReturn = ""
comp = UCase(DirOrigen & "\" & DirReturn)
If Not comp = UCase(GetSpecialfolder(34) & "\desktop.ini") And Not comp = UCase(GetSpecialfolder(33) & "\desktop.ini") And Not comp = UCase(GetSpecialfolder(32) & "\desktop.ini") And Not comp = UCase(GetSpecialfolder(8) & "\desktop.ini") Then
' Evito que se borren los archivos de configuracion de las carpetas
SetAttr DirOrigen & "\" & DirReturn, 0
Kill DirOrigen & "\" & DirReturn
End If
DirReturn = Dir
Loop
RmDir DirOrigen
' Buscar la ultima "\"
For i% = Len(DirOrigen) To 1 Step -1
If Mid$(DirOrigen, i%, 1) = "\" Then Exit For
Next
DirOrigen = Right$(DirOrigen, Len(DirOrigen) - i%)
RmDir DirOrigen
' Recorro todos los subdirectorios que encontramos antes
For i = 1 To NumDir
DirOK = BuscarT(d(i), NivelIndent + 1)
Next
DoEvents
ExitFunc:
ChDir DirActual$
Exit Function
DirErr:
MsgBox "Error: " & Error$(Err)
Resume ExitFunc
End Function