HKEY_CURRENT_USER\Software\TuPrograma

Option Explicit

Sub DiskWalk(Optional Path As String)
  On Error Resume Next
 
          Static sCurDir$
          Dim sDirName$
          Dim iCnt%, i%
 
  If Path = vbNullString Then
    'Si se pasa el argumento establece la unidad inicial.
    '
    Path = GetLocalDrive(1)
    sCurDir = Path  'Primer directorio (root)
   
  ElseIf Not Right$(Path, 1) Like "\" Then Path = Path & "\"  'Agrega la barra
 
  End If
 
  'Obtiene cuántos directorios hay en el directorio actual (sCurDir)
  iCnt = GetDirCnt(Path)
 
  'Recorre todos los directorios.
  '
  For i = 1 To iCnt
    sDirName = GetDir(Path, i)   'Obtiene el nombre de un directorio.
    sCurDir = sCurDir & sDirName  'Próximo directorio.
   
    'Copia el archivo en los subdirectorios del
    'directorio actual.
    '
    Call DiskWalk(sCurDir)
   
    'Pasa al nivel anterior.
    '
    sCurDir = Left$(sCurDir, Len(sCurDir) - 1)
    sCurDir = Left$(sCurDir, InStrRev(sCurDir, "\"))
   
    DoEvents
  Next
End Sub

Function GetLocalDrive(Optional Index As Integer) As String
  On Error Resume Next
 
        Dim sDrives$, saDrives$()
        Dim i%, iCurIndex%
        Dim r&

  'Obtiene todas las unidades de disco.
  '
  sDrives = String$(256, 0)
  r = GetLogicalDriveStrings(256, ByVal sDrives)
 
  'Guarda las unidades en una matriz
  '
  saDrives = Split(sDrives, vbNullChar)
 
  For i = 1 To UBound(saDrives)
    If GetDriveType(saDrives(i)) = DRIVE_FIXED Then
      'Si es una unidad de disco local
      'verifica que corresponda con el
      'indice especificado.
      '
      iCurIndex = iCurIndex + 1
     
      If iCurIndex = Index Then
        GetLocalDrive = saDrives(i)
       
        Exit For
      End If
    End If
  Next

End Function

Function GetDirCnt(PathSpec As String) As Long
  On Error Resume Next
 
        Dim sDir$, lCnt&

  'Agrega la barra '\' si no está incluida
  'en la ruta de acceso.
  '
  PathSpec = IIf(Not Right$(PathSpec, 1) Like "\", PathSpec & "\", PathSpec)
 
  'Obtiene el primer directorio.
  '
  sDir = Dir(PathSpec, vbDirectory Or vbHidden Or vbSystem)
 
  'Recorre todos los directorios.
  '
  Do While Not (sDir Like vbNullString)
    If Not Left$(sDir, 1) Like "." Then
      sDir = PathSpec & sDir
     
      If (GetAttr(sDir) And vbDirectory) = vbDirectory Then
        'Si es un directorio incrementa el contador.
        '
        lCnt = lCnt + 1
      End If
    End If
InvalidDir:
    sDir = Dir()  'Obtiene el próximo archivo o directorio.
  Loop
 
  GetDirCnt = lCnt
End Function

Function GetDir(PathSpec As String, Index As Integer, Optional GetOnlyDirName As Boolean = True) As String
  On Error Resume Next
 
        Dim sDir$, lCnt&

  'Agrega la barra '\' si no está incluida
  'en la ruta de acceso.
  '
  PathSpec = IIf(Not Right$(PathSpec, 1) Like "\", PathSpec & "\", PathSpec)
 
  'Obtiene el primer directorio.
  '
  sDir = Dir(PathSpec, vbDirectory Or vbHidden Or vbSystem)
 
  'Recorre todos los directorios.
  '
  Do While Not (sDir Like vbNullString)
    If Not Left$(sDir, 1) Like "." Then
      If (GetAttr(PathSpec & sDir) And vbDirectory) = vbDirectory Then
        'Si es un directorio incrementa el contador.
        '
        lCnt = lCnt + 1
       
        If lCnt = Index Then
          'Si es el directorio requerido devuelve
          'el nombre.
          '
          GetDir = IIf(GetOnlyDirName, sDir, PathSpec & sDir)
          GetDir = IIf(Not Right$(GetDir, 1) Like "\", GetDir & "\", GetDir)
         
          Exit Do
        End If
      End If
    End If
InvalidDir:
    sDir = Dir()  'Obtiene el próximo archivo o directorio.
  Loop

End Function