cOSFolders

Clase para obtener los distintos directorios del Sistema

Revisión del 13/Ago/98

Con esta clase se pueden obtener los distintos directorios de Windows, además de los "tradicionales" como el directorio de Windows y System, se puede saber el directorio de Archivos de Programa, la localización del Escritorio, Menú de Inicio, etc.

Las claves que se usan para obtener esta información se encuentra en el registro del Sistema.
Estas claves son:
HKEY_USERS\.Default\Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders
HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion

La forma de obtener los distintos directorios es usando el método (o función) GetFolder de esta clase; a este método hay que pasarle un parámetro que será bien un número (índice dentro de una colección con los valores) o bien una cadena con el nombre del directorio que queremos; los valores de estas cadenas son los nombres usados en el registro de Windows para nombrarlos.
Por ejemplo para obtener el directorio en el que está el Menú de Inicio habrá que usar como "cadena" Start Menu.

En el form de prueba, se usa un combo para contener los diferentes valores que se pueden usar para conseguir ese directorio.

Además de obtener los nombres de los directorios, esta clase tiene una función/método que devuelve un valor de una entrada del registro, (del tipo cadena, DWORD o Binary), no voy a explicar cómo usarla porque estoy preparando otra clase más genérica para manipular los datos del registro, por ahora sólo tengo la parte de obtener los valores, pero si todo va bien, también se podrán crear claves y (espero) cambiar los valores de las claves.

Aquí tienes los listados del form de prueba y los de la clase. Espero que te sea útil.

Si quieres los listados, aquí los tienes: (OSFolders.zip 5.55 KB)

El formulario:
'------------------------------------------------------------------
'                                                       (13/Ago/98)
'Prueba de uso de la clase para devolver los directorios del S.O.
'
'©Guillermo 'guille' Som, 1998
'------------------------------------------------------------------
Option Explicit

Dim tOSF As cOSFolders


Private Sub cmdMostrar_Click()
    Dim sKey As String
    Dim sValue As String
    Dim i As Long
    Dim sData As String
    
    Label1(2) = ""
    i = Combo1.ListIndex
    sKey = Combo1.List(i)
    sData = tOSF.GetFolder(sKey)
    Label1(2) = sData
End Sub

Private Sub Combo1_Click()
    cmdMostrar_Click
End Sub

Private Sub Form_Load()
    Set tOSF = New cOSFolders
    Dim col As New Collection
    Dim i As Long
    
    'Devolver sólo las claves de los directorios
    Set col = tOSF.ShellFolders(bSoloClaves:=True)
    With Combo1
        .Clear
        For i = 1 To col.Count
            .AddItem col(i)
        Next
        If .ListCount Then
            .ListIndex = 0
        End If
    End With
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Set tOSF = Nothing
End Sub

La Clase:
'
'------------------------------------------------------------------
'cOSFolders                                             (13/Ago/98)
'Clase para obtener valores del Registro del Sistema
'(versión reducida pra obtener los directorios del sistema)
'
'La información para crear las funciones están tomadas de ejemplos
'y valores obtenidos en el código del Setup1.vbp
'y de artículos incluidos en los CDs del MSDN Library.
'
'=== De algún sitio tenía que sacar la información... ===
'
'©Guillermo 'guille' Som, 1998
'email: [email protected] / [email protected]
'
'Funciones/Métodos de la clase:
'   GetReg          devolverá el valor de la clave indicada
'   GetFolder       devuelve el path del nombre-clave indicado
'   ShellFolders    devuelve una colección con los nombres de
'                   los directorios disponibles (claves)
'------------------------------------------------------------------
Option Explicit

Dim colShellFolders As Collection
Dim colShellFoldersKey As Collection

Private Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" _
    (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Private Declare Function GetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryA" _
    (ByVal lpBuffer As String, ByVal nSize As Long) As Long

' Registry manipulation API's (32-bit)

'Claves del Registro
Public Enum eHKEY
    HKEY_CLASSES_ROOT = &H80000000
    HKEY_CURRENT_USER = &H80000001
    HKEY_LOCAL_MACHINE = &H80000002
    HKEY_USERS = &H80000003
End Enum
'
Private Enum eHKEYError
    ERROR_SUCCESS = 0               'Todo correcto, sin error
    ERROR_MORE_DATA = 234&          'More data is available
    ERROR_NO_MORE_ITEMS = 259&      'No more data is available
End Enum
'
'Los tipos de datos posibles
Private Enum eHKEYDataType
    REG_NONE = 0&               'No value type
    REG_SZ = 1&                 'Unicode null terminated string
    REG_BINARY = 3              'Free form binary
    REG_DWORD = 4               '32-bit number
End Enum
'
Private Enum eREGSAM
    KEY_QUERY_VALUE = &H1
End Enum

Private Type FILETIME
    dwLowDateTime As Long
    dwHighDateTime As Long
End Type

Private Declare Function RegQueryInfoKey Lib "advapi32.dll" Alias "RegQueryInfoKeyA" _
    (ByVal hKey As Long, ByVal lpClass As String, lpcbClass As Long, _
    lpReserved As Long, lpcSubKeys As Long, lpcbMaxSubKeyLen As Long, _
    lpcbMaxClassLen As Long, lpcValues As Long, lpcbMaxValueNameLen As Long, _
    lpcbMaxValueLen As Long, lpcbSecurityDescriptor As Long, _
    lpftLastWriteTime As FILETIME) As Long
Private Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" _
    (ByVal hKey As Long, ByVal lpSubKey As String, _
    ByVal ulOptions As Long, ByVal samDesired As Long, _
    phkResult As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" _
    (ByVal hKey As Long) As Long
Private Declare Function RegEnumValue Lib "advapi32.dll" Alias "RegEnumValueA" _
    (ByVal hKey As Long, ByVal dwIndex As Long, _
    ByVal lpValueName As String, lpcbValueName As Long, _
    lpReserved As Long, lpType As Long, lpData As Any, _
    lpcbData As Long) As Long
Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" _
    (ByVal hKey As Long, ByVal lpszValueName As String, _
    ByVal dwReserved As Long, lpdwType As Long, _
    lpbData As Any, cbData As Long) As Long


Public Function GetReg(ByVal sKey As String, Optional ByVal sValue As String = "", Optional ByVal hKey As eHKEY = HKEY_CURRENT_USER, Optional ByVal bAsString As Boolean = False) As Variant
    'Obtener un valor de una entrada del registro
    '
    'Parámetros de entrada:
    '   sKey        SubClave del registro
    '               Se puede especificar el nombre de la clave raiz
    '               que se convertirá al valor adecuado
    '   sValue      Nombre de la entrada que queremos obtener
    '   hKey        Clave principal del registro
    '   bAsString   Mostrarlo como una cadena, al estilo de RegEdit
    'Devuelve:
    '   el contenido de esa clave o un valor vacío
    '
    Dim ret As Long
    Dim hKey2 As Long
    Dim rDT As eHKEYDataType
    Dim retDT As eHKEYDataType
    Dim lSize As Long
    Dim sData As String
    Dim aData() As Byte
    Dim lDWord As Long
    Dim i As Long
    Dim sTmp As String
    
    'Nos aseguramos que hKey tenga el valor correcto
    Select Case hKey
    Case HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_LOCAL_MACHINE, HKEY_USERS
        'nada que hacer, todo correcto
    Case Else
        'Asignamos el valor por defecto
        hKey = HKEY_CLASSES_ROOT
    End Select
    
    hKey = ParseKey(sKey, hKey)
    
    'Valores por defecto
    ReDim aData(0)
    lDWord = 0
    sData = ""
    
    'Abrir la clave indicada
    ret = RegOpenKeyEx(hKey, sKey, 0&, KEY_QUERY_VALUE, hKey2)
    
    'Si todo va bien (se ha podido abrir la clave)
    If ret = ERROR_SUCCESS Then
        'Leer esa entrada y obtener el tipo de dato, longitud, etc.
        ret = RegQueryValueEx(hKey2, sValue, 0&, retDT, 0&, lSize)
        'Si es un valor binario
        If retDT = REG_BINARY Then
            If lSize Then
                ReDim aData(lSize)
                'Leer los datos binarios
                ret = RegQueryValueEx(hKey2, sValue, 0&, rDT, aData(0), lSize)
            End If
        ElseIf retDT = REG_DWORD Then
            ret = RegQueryValueEx(hKey2, sValue, 0&, rDT, lDWord, lSize)
        ElseIf retDT = REG_SZ Then
            If lSize Then
                sData = String$(lSize - 1, Chr$(0))
                'Leer la cadena
                '(el ByVal es porque está declarada como Any)---v
                ret = RegQueryValueEx(hKey2, sValue, 0&, rDT, ByVal sData, lSize)
            End If
        End If
        'Cerrar la clave abierta
        RegCloseKey hKey2
    End If
    'Devolver el valor leído
    If retDT = REG_BINARY Then
        If bAsString Then
            'Al estilo de como se muestra con RegEdit
            For i = 0 To UBound(aData) - 1
                sTmp = sTmp & Hex$(aData(i)) & " "
            Next
            GetReg = sTmp
        Else
            GetReg = aData
        End If
    ElseIf retDT = REG_DWORD Then
        If bAsString Then
            'Al estilo de como se muestra con RegEdit
            GetReg = "0x" & Format$(Hex$(lDWord), "00000000") & " (" & lDWord & ")"
        Else
            GetReg = lDWord
        End If
    ElseIf retDT = REG_SZ Then
        GetReg = sData
    End If
End Function

Private Function ParseKey(sKey As String, Optional ByVal hKey As eHKEY = HKEY_CURRENT_USER) As eHKEY
    Dim i As Long
    Dim sRootKey As String
    
    'Comprobar si se indica la clave principal en sKey
    i = InStr(sKey, "HKEY_")
    If i Then
        i = InStr(sKey, "\")
        If i Then
            sRootKey = Left$(sKey, i - 1)
            sKey = Mid$(sKey, i + 1)
        Else
            sRootKey = sKey
            sKey = ""
        End If
        If Len(sRootKey) Then
            Select Case sRootKey
            Case "HKEY_CLASSES_ROOT"
                hKey = HKEY_CLASSES_ROOT
            Case "HKEY_CURRENT_USER"
                hKey = HKEY_CURRENT_USER
            Case "HKEY_LOCAL_MACHINE"
                hKey = HKEY_LOCAL_MACHINE
            Case "HKEY_USERS"
                hKey = HKEY_USERS
            Case Else
                hKey = HKEY_CLASSES_ROOT
            End Select
        End If
    End If
    ParseKey = hKey
End Function

Private Function EnumValueString(ByVal hKey As Long, ByVal dwIndex As Long, _
    lpValueName As String, lpcbValueName As Long, _
    lpReserved As Long, lpType As Long, lpData As String, _
    lpcbData As Long) As Long

    EnumValueString = RegEnumValue(hKey, dwIndex, _
                            lpValueName, lpcbValueName, _
                            lpReserved, lpType, ByVal lpData, _
                            lpcbData)

End Function

Private Function EnumValue(ByVal hKey As Long, ByVal dwIndex As Long, _
    lpValueName As String, lpcbValueName As Long, _
    lpReserved As Long, lpType As Long, lpData As Byte, _
    lpcbData As Long) As Long

    EnumValue = RegEnumValue(hKey, dwIndex, _
                            lpValueName, lpcbValueName, _
                            lpReserved, lpType, lpData, _
                            lpcbData)
End Function

Private Function QueryInfoKey(ByVal hKey As Long, lpcbMaxValueNameLen As Long) As Long
    Dim lpftLastWriteTime As FILETIME
    
    QueryInfoKey = RegQueryInfoKey(hKey, 0&, 0&, 0&, 0&, 0&, 0&, 0&, _
                    lpcbMaxValueNameLen, 0&, 0&, lpftLastWriteTime)
End Function

Public Function ShellFolders(Optional bSoloClaves As Boolean = False) As Variant
    'Devolverá las claves de la clave Shell Folders
    Dim hKey As eHKEY
    Dim Entry As String
    Dim phkResult As Long
    Dim maxBufLen As Long
    Dim L As Long
    Dim buf As String
    Dim buflen As Long
    Dim lRet As Long
    Dim retDT As eHKEYDataType
    Dim i As Long
    Dim sValue As String
    Dim iCount As Long
    
    'Borrar el contenido de la colección
    Set colShellFolders = Nothing
    Set colShellFolders = New Collection
    Set colShellFoldersKey = Nothing
    Set colShellFoldersKey = New Collection
    
    '==============================================================
    '
    '=== NOTA CACHONDA === por lo incomprensible...
    ' Es curioso, pero si utilizo estas intrucciones aquí
    ' el bucle For iCount=0 to 1 no acaba nunca
    '
    '==============================================================
    '
    'Para el directorio de windows
    'buf = "WindowsDir"
    'colShellFoldersKey.Add buf, buf
    'colShellFolders.Add "Windows", buf
    '
    'Para el directorio de System
    'buf = "SystemDir"
    'colShellFoldersKey.Add buf, buf
    'colShellFolders.Add "System", buf
    '
    '==============================================================
    
    For iCount = 0 To 1
        'Enumerar el contenido de Shell Folders
        If iCount = 0 Then
            hKey = HKEY_USERS
            Entry = ".Default\Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders"
        Else
            hKey = HKEY_LOCAL_MACHINE
            Entry = "Software\Microsoft\Windows\CurrentVersion"
        End If
        If RegOpenKeyEx(hKey, Entry, 0&, KEY_QUERY_VALUE, phkResult) = ERROR_SUCCESS Then
            lRet = QueryInfoKey(phkResult, maxBufLen)
            L = -1
            Do
                L = L + 1
                buf = String$(maxBufLen + 1, 0)
                buflen = Len(buf)
                'Para enumerar los valores y las claves
                lRet = EnumValue(phkResult, L, buf, buflen, 0&, retDT, 0&, i)
                If retDT = REG_SZ Then
                    sValue = String$(i - 1, 0)
                    buf = String$(maxBufLen + 1, 0)
                    buflen = Len(buf)
                    lRet = EnumValueString(phkResult, L, buf, buflen, 0&, retDT, sValue, i)
                    buf = Left$(buf, buflen)
                    If InStr(buf, Chr$(0)) Then
                        buflen = InStr(buf, Chr$(0)) - 1
                        buf = Left$(buf, buflen)
                    End If

                    If Len(buf) Then
                        If iCount = 0 Then
                            colShellFoldersKey.Add buf, buf
                            colShellFolders.Add "HKEY_USERS\" & Entry, buf
                        Else
                            If InStr(sValue, ":\") Then
                                colShellFoldersKey.Add buf, buf
                                colShellFolders.Add "HKEY_LOCAL_MACHINE\" & Entry, buf
                            End If
                        End If
                    End If
                End If
                If lRet = ERROR_NO_MORE_ITEMS Then
                    Exit Do
                End If
            Loop
            lRet = RegCloseKey(phkResult)
        End If
    Next
    
    'Obtener el directorio de windows
    buf = String$(300, Chr$(0))
    lRet = GetWindowsDirectory(buf, Len(buf))
    sValue = Left$(buf, lRet)
    buf = "WindowsDir"
    colShellFoldersKey.Add buf, buf
    colShellFolders.Add sValue, buf
    
    'Obtener el directorio de System
    buf = String$(300, Chr$(0))
    lRet = GetSystemDirectory(buf, Len(buf))
    sValue = Left$(buf, lRet)
    buf = "SystemDir"
    colShellFoldersKey.Add buf, buf
    colShellFolders.Add sValue, buf
    
    If bSoloClaves Then
        Set ShellFolders = colShellFoldersKey
    Else
        Set ShellFolders = colShellFolders
    End If
    
End Function

Private Sub Class_Initialize()
    Set colShellFolders = New Collection
    Set colShellFoldersKey = New Collection
End Sub

Private Sub Class_Terminate()
    Set colShellFolders = Nothing
    Set colShellFoldersKey = Nothing
End Sub

Public Function GetFolder(ByVal vIndex As Variant) As String
    'Devuelve el directorio de la clave indicada
    Dim sKey As String
    Dim sData As String
    Dim lRet As Long
    
    If colShellFolders.Count = 0 Then
        Call ShellFolders
    End If
    
    On Local Error Resume Next
    sKey = colShellFolders(vIndex)
    sData = colShellFoldersKey(vIndex)
    If sData = "WindowsDir" Then
        'Devolver el directorio de windows
        GetFolder = sKey
    ElseIf sData = "SystemDir" Then
        'Devolver el directorio de System
        GetFolder = sKey
    Else
        GetFolder = GetReg(sKey, sData)
    End If
    If Err Then
        GetFolder = ""
    End If
    Err = 0
    On Local Error GoTo 0
End Function