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\CurrentVersionLa 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 SubLa 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