Links a las nuevas revisiones:
Pulsa aqui si quieres ver la revisión del 14/Oct/98 (2)
Este link te llevará a la revisión del 12/Jun/99 (3)
Este otro te llevará a la revisión del 22/Jun/2000 (4)
Este es el correspondiente a la revisión del 28/Dic/2001 (5)
Lo prometido es deuda.
Esta es la clase completa para manipulación del registro, además de poder obtener los diferentes directorios del sistema.Entre otras cosas, lo que puedes hacer con esta clase es:
- Leer un valor de una clave del registro de cualquier tipo: cadena, binario o numérico.
- Asignar un valor a una clave.
- Borrar un valor de una clave.
- Borrar una clave.
- Asociar una extensión con un programa.
- Añadir opciones a una extensión existente.
- Borrar una extensión (desasociar la extensión)
- Obtener cualquier directorio del sistema (Menú de inicio, Windows, archivos de programa, etc.)
MUY IMPORTANTE: Cualquier manipulación errónea del registro no es un juego... a pesar de que he hecho mis comprobaciones, no me hago responsable del funcionamiento de esta clase y menos aún de las consecuencias catastróficas que pueda producir por un uso no "adecuado".
El que avisa...
A la fecha de publicación, (02:50 del 18/Ago/98), sólo he puesto el listado de la clase, pero incluyo un form de prueba.
Las pruebas de lectura y asociación/borrado de extensiones las he probado en Windows 95 español y Windows 98 inglés USA.
No he hecho ninguna prueba con Windows NT, (aún no lo tengo instalado).Cuando tenga más tiempo, explicaré con más detalle cómo se usan las funciones, pero he creido interesante publicar la clase y los ejemplos antes de tener listo "el comecoco", ya que son muchos los interesados en una clase de este tipo.
Si quieres los listados completos, pulsa este link. (QueryReg.zip 13.9 KB)
Nota: Este ya no está disponible, bájate el último, (el link está arriba) sí estarás más al día.La clase: ' '------------------------------------------------------------------ 'cQueryReg (13/Ago/98) 'Clase para obtener valores del Registro del Sistema ' 'Con las funciones de crear/borrar claves/valores: (18/Ago/98) ' '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] ' 'La función / método GetReg devolverá el valor adecuado, 'si se ha encontrado la clave especificada en el registro. ' 'Las funciones GetRegXXX se usarán para asegurarnos que el valor 'devuelto es del tipo especificado. 'Por ejemplo: ' si se usa GetRegString y el valor de la clave indicada ' no es del tipo cadena, se devolverá una cadena vacía '======================================================================== '=== NOTA: Las he dejado para poder ver cómo se usarían según el tipo === '======================================================================== '------------------------------------------------------------------ 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 ' HKEY_CURRENT_CONFIG = &H80000005 HKEY_DYN_DATA = &H80000006 End Enum ' Public Enum eHKEYError ERROR_SUCCESS = 0 'Todo correcto, sin error ERROR_FILE_NOT_FOUND = 2& 'este error ocurre cuando se abre 'una clave y no existe ERROR_ACCESS_DENIED = 5& ERROR_MORE_DATA = 234& 'More data is available ERROR_NO_MORE_ITEMS = 259& 'No more data is available ERROR_BADKEY = 1010& 'Se produce cuando se intenta acceder 'a una clave que no está abierta End Enum ' 'Los tipos de datos posibles, algunos sólo para Windows NT Public 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 ' Standard rights, used later below Const SYNCHRONIZE = &H100000 Const READ_CONTROL = &H20000 Const STANDARD_RIGHTS_ALL = &H1F0000 Const STANDARD_RIGHTS_REQUIRED = &HF0000 Const STANDARD_RIGHTS_EXECUTE = (READ_CONTROL) Const STANDARD_RIGHTS_READ = (READ_CONTROL) Const STANDARD_RIGHTS_WRITE = (READ_CONTROL) 'Security Access Mask Public Enum eREGSAM 'Permission to: KEY_QUERY_VALUE = &H1 ' query subkey data KEY_SET_VALUE = &H2 ' set subkey data KEY_CREATE_SUB_KEY = &H4 ' create subkeys KEY_ENUMERATE_SUB_KEYS = &H8 ' enumerate subkeys KEY_NOTIFY = &H10 ' for change notification KEY_CREATE_LINK = &H20 ' create a symbolic link 'KEY_READ Combination of: ' KEY_QUERY_VALUE, KEY_ENUMERATE_SUB_KEYS, and ' KEY_NOTIFY access. KEY_READ = ((STANDARD_RIGHTS_READ Or KEY_QUERY_VALUE Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY) And (Not SYNCHRONIZE)) 'KEY_WRITE Combination of: ' KEY_SET_VALUE and KEY_CREATE_SUB_KEY access. KEY_WRITE = ((STANDARD_RIGHTS_WRITE Or KEY_SET_VALUE Or KEY_CREATE_SUB_KEY) And (Not SYNCHRONIZE)) 'Permission for read access KEY_EXECUTE = ((KEY_READ) And (Not SYNCHRONIZE)) 'KEY_ALL_ACCESS Combination of: ' KEY_QUERY_VALUE, KEY_SET_VALUE, KEY_CREATE_SUB_KEY, ' KEY_ENUMERATE_SUB_KEYS, KEY_NOTIFY and KEY_CREATE_LINK access. KEY_ALL_ACCESS = ((STANDARD_RIGHTS_ALL Or KEY_QUERY_VALUE Or KEY_SET_VALUE Or KEY_CREATE_SUB_KEY Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY Or KEY_CREATE_LINK) And (Not SYNCHRONIZE)) 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 RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" _ (ByVal hKey As Long, ByVal lpszSubKey As String, _ phkResult As Long) As Long ' 'Windows 95: ' The RegDeleteKey function deletes a subkey and all its descendants. 'Windows NT: ' The RegDeleteKey function deletes the specified subkey. ' The subkey to be deleted must not have subkeys. ' Private Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" _ (ByVal hKey As Long, ByVal lpszSubKey As String) As Long Private Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" _ (ByVal hKey As Long, ByVal szValueName As String) As Long Private Declare Function RegEnumKey Lib "advapi32.dll" Alias "RegEnumKeyA" _ (ByVal hKey As Long, ByVal iSubKey As Long, _ ByVal lpszName As String, ByVal cchName As Long) As Long Private Declare Function RegEnumKeyEx Lib "advapi32.dll" Alias "RegEnumKeyExA" _ (ByVal hKey As Long, ByVal dwIndex As Long, _ ByVal lpName As String, lpcbName As Long, _ ByVal lpReserved As Long, ByVal lpClass As String, _ lpcbClass As Long, lpftLastWriteTime As FILETIME) As Long Private Declare Function RegQueryValue Lib "advapi32.dll" Alias "RegQueryValueA" _ (ByVal hKey As Long, ByVal lpSubKey As String, _ ByVal lpValue As String, lpcbValue 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 'The RegSetValue function sets the data for the default or unnamed 'value of a specified registry key. The data must be a text string. Private Declare Function RegSetValue Lib "advapi32.dll" Alias "RegSetValueA" _ (ByVal hKey As Long, ByVal lpSubKey As String, _ ByVal dwType As Long, ByVal lpData As String, _ ByVal cbData As Long) As Long ' 'The RegSetValueEx function sets the data and type of a 'specified value under a registry key. ' 'lpValueName: 'Pointer to a string containing the name of the value to set. 'If a value with this name is not already present in the key, 'the function adds it to the key. 'If lpValueName is NULL or an empty string, "", the function sets 'the type and data for the key's unnamed or default value. ' 'On Windows 95, the type of a key's default value is always REG_SZ, 'so the dwType parameter must specify REG_SZ for an unnamed value. 'On Windows 98, an unnamed value can be of any type. ' Private Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" _ (ByVal hKey As Long, ByVal lpszValueName As String, _ ByVal dwReserved As Long, ByVal fdwType As Long, _ lpbData As Any, ByVal cbData As Long) As Long ' 'Este código está 'copiado' de un ejemplo de David Janson 'Sólo es necesario para Windows NT, ya que win95 permite borrar todas 'las subclaves ' 'También hay que usarla en windows 98 ' ' ' this gets a bit tricky since you can't delete a key that has subkeys. ' We have to do this recursively. This code ignores errors (such as security ' problems) when they occur. ' Private Function DeleteKeyNT(hParentKey As Long, szKey As String) As Long Dim hKey As Long Dim lRet As eHKEYError Dim cSubKeys As Long Dim cbMaxSubKeyLen As Long Dim cbSubKeyLen As Long Dim dwIndex As Long Dim ft As FILETIME Dim szTempSubKey As String Dim szSubKey As String ' open the key to look for subkeys lRet = RegOpenKeyEx(hParentKey, szKey, 0, KEY_ALL_ACCESS, hKey) If Not lRet = ERROR_SUCCESS Then DeleteKeyNT = lRet Exit Function End If lRet = RegQueryInfoKey(hKey, ByVal 0&, ByVal 0&, 0, cSubKeys, cbMaxSubKeyLen, _ ByVal 0&, ByVal 0&, ByVal 0&, ByVal 0&, ByVal 0&, ft) If Not lRet = ERROR_SUCCESS Then DeleteKeyNT = lRet Call RegCloseKey(hKey) Exit Function End If ' if there are subkeys, then recursively delete them If cSubKeys > 0 Then dwIndex = cSubKeys - 1 ' start at the end cbMaxSubKeyLen = cbMaxSubKeyLen + 1 ' +1 for the null terminator szTempSubKey = String(cbMaxSubKeyLen, "*") ' buffer to get name back in Do cbSubKeyLen = cbMaxSubKeyLen lRet = RegEnumKeyEx(hKey, dwIndex, szTempSubKey, cbSubKeyLen, 0, ByVal 0&, 0, ft) If lRet = ERROR_SUCCESS Then szSubKey = Left(szTempSubKey, cbSubKeyLen) Call DeleteKeyNT(hKey, szSubKey) End If dwIndex = dwIndex - 1 ' enumerate backwards Loop While dwIndex >= 0 End If ' done enumerating subkeys. Close this key and delete it Call RegCloseKey(hKey) lRet = RegDeleteKey(hParentKey, szKey) DeleteKeyNT = lRet End Function 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. ' Si en sKey se incluye, no es necesario especificarla ' bAsString Mostrarlo como una cadena, al estilo de RegEdit 'Devuelve: ' el contenido de esa clave o un valor vacío ' Dim lRet 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 hKey = ParseKey(sKey, hKey) 'Valores por defecto ReDim aData(0) lDWord = 0 sData = "" 'Abrir la clave indicada lRet = RegOpenKeyEx(hKey, sKey, 0&, KEY_QUERY_VALUE, hKey2) 'Si todo va bien (se ha podido abrir la clave) If lRet = ERROR_SUCCESS Then 'Leer esa entrada y obtener el tipo de dato, longitud, etc. lRet = 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 lRet = RegQueryValueEx(hKey2, sValue, 0&, rDT, aData(0), lSize) End If ElseIf retDT = REG_DWORD Then lRet = 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 lRet = 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 'Busca una entrada en el registro Public Function QueryRegBase(ByVal sValue As String, Optional ByVal hKey As eHKEY = HKEY_CLASSES_ROOT) As String 'Devuelve el valor de la entrada del registro 'Esta función se usará para los valores por defecto ' Dim sBuf As String Dim buflen As Long '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 'On Local Error Resume Next sBuf = String$(300, Chr$(0)) buflen = Len(sBuf) 'Buscar la entrada especificada y devolver el valor asignado If RegQueryValue(hKey, sValue, sBuf, buflen) = ERROR_SUCCESS Then If buflen > 1 Then 'El formato devuelto es ASCIIZ, así que quitar el último caracter QueryRegBase = Left$(sBuf, buflen - 1) Else QueryRegBase = "" End If Else QueryRegBase = "" End If 'On Local Error GoTo 0 End Function Private Function ParseKey(sKey As String, Optional ByVal hKey As eHKEY = HKEY_CURRENT_USER) As eHKEY 'Esta función se usa internamente (privada) para convertir una cadena 'en la correspondiente clave raiz. 'El segundo parámetro es para poder usarlo en caso que se pase como 'parámetro, pero normalmente será totalmente opcional. ' 'En sKey se devolverá el valor de la clave una vez quitada la clave 'principal. ' 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 'Por si se usan abreviaturas de las claves ElseIf Left$(sKey, 5) = "HKCR\" Then sRootKey = "HKEY_CLASSES_ROOT" sKey = Mid$(sKey, 6) ElseIf Left$(sKey, 5) = "HKCU\" Then sRootKey = "HKEY_CURRENT_USER" sKey = Mid$(sKey, 6) ElseIf Left$(sKey, 5) = "HKLM\" Then sRootKey = "HKEY_LOCAL_MACHINE" sKey = Mid$(sKey, 6) ElseIf Left$(sKey, 4) = "HKU\" Then sRootKey = "HKEY_USERS" sKey = Mid$(sKey, 5) ElseIf Left$(sKey, 5) = "HKCC\" Then sRootKey = "HKEY_CURRENT_CONFIG" sKey = Mid$(sKey, 6) ElseIf Left$(sKey, 5) = "HKDD\" Then sRootKey = "HKEY_DYN_DATA" sKey = Mid$(sKey, 6) Else 'Nos aseguramos que kKey tenga el valor correcto Select Case hKey Case HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_CURRENT_CONFIG, HKEY_DYN_DATA 'nada que hacer, todo correcto Case Else 'Asignamos el valor por defecto hKey = HKEY_CLASSES_ROOT End Select End If 'Si se ha indicado el nombre de la clave raiz 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 "HKEY_CURRENT_CONFIG" hKey = HKEY_CURRENT_CONFIG Case "HKEY_DYN_DATA" hKey = HKEY_DYN_DATA Case Else hKey = HKEY_CLASSES_ROOT End Select End If ParseKey = hKey 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 ' '============================================================== 'On Local Error Resume Next 'Err = 0 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 OpenKeyEx(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 'Err = 0 If Len(buf) Then If iCount = 0 Then colShellFoldersKey.Add buf, buf 'colShellFolders.Add "HKEY_USERS\" & Entry & "\" & buf, buf colShellFolders.Add "HKEY_USERS\" & Entry, buf Else If InStr(sValue, ":\") Then colShellFoldersKey.Add buf, buf 'colShellFolders.Add "HKEY_LOCAL_MACHINE\" & Entry & "\" & 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 = CloseKey(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 ' '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 If bSoloClaves Then Set ShellFolders = colShellFoldersKey Else Set ShellFolders = colShellFolders End If 'Err = 0 'On Local Error GoTo 0 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 'Obtener el directorio de windows 'sKey = String$(300, Chr$(0)) 'lRet = GetWindowsDirectory(sKey, Len(sKey)) 'GetFolder = Left$(sKey, lRet) GetFolder = sKey ElseIf sData = "SystemDir" Then 'Obtener el directorio de System 'sKey = String$(300, Chr$(0)) 'lRet = GetSystemDirectory(sKey, Len(sKey)) 'GetFolder = Left$(sKey, lRet) GetFolder = sKey Else GetFolder = GetReg(sKey, sData) End If If Err Then GetFolder = "" End If Err = 0 On Local Error GoTo 0 End Function Public Sub AsociarExt(ByVal sExt As String, _ Optional ByVal sExe As String = "", _ Optional ByVal sCommand As String = "open", _ Optional ByVal bDefault As Boolean = True, _ Optional ByVal sProgId As String = "", _ Optional ByVal sDescription As String = "") '---------------------------------------------------------------------- 'Asociar una extensión con un programa 'También sirve para añadir comandos a extensiones existentes ' 'Parámetros: ' sExt Extensión a asociar ' sExe Path completo del programa ' sProgId Nombre de la clave asociada ' sDescription Descripción de la extensión ' sCommand Clave a crear, por defecto es Abrir (open) ' bDefault Si la clave indicada es la que se usará por defecto ' '---------------------------------------------------------------------- 'Para probar: 'tQR.AsociarExt ".cIt", "C:\Vb5_L\Cut-It\Cut-It.exe", "open", False, "gsCutIt", "Cut-It (trocear y unir archivos)" 'tQR.AsociarExt ".cIt", "C:\Windows\Notepad.exe", "&Editar", True, "gsCutIt", "Cut-It (trocear y unir archivos)" ' 'Sólo se quitará el valor por defecto si se asigna a otra clave. 'tQR.AsociarExt ".cIt", "", "open", True, "gsCutIt", "Cut-It (trocear y unir archivos)" 'tQR.AsociarExt ".cIt", "", "&Editar", True, "gsCutIt", "Cut-It (trocear y unir archivos)" '---------------------------------------------------------------------- Dim sDef As String Dim hKey As Long Dim phkResult As Long Dim lRet As eHKEYError Dim sValue As String Dim sKey As String Dim sAccess As String 'Quitar los espacios sExt = Trim$(sExt) sExe = Trim$(sExe) sCommand = Trim$(sCommand) sProgId = Trim$(sProgId) sDescription = Trim$(sDescription) 'Si no se especifica el punto If InStr(sExt, ".") = 0 Then sExt = "." & sExt End If 'Comprobar el tipo de ejecutable, si no se especifica la extensión 'se añade .exe If Len(sExe) Then If InStr(sExe, ".") = 0 Then sExe = sExe & ".exe" End If sExe = sExe & " " End If 'Si no se especifica el ProgId If Len(sProgId) = 0 Then sProgId = "progID" & sExt End If 'Si no se especifica la descripción If Len(sDescription) = 0 Then sDescription = "Descripción de " & sProgId End If sAccess = sCommand 'Comprobar si tiene el símbolo & y quitarlo del commando lRet = InStr(sAccess, "&") If lRet Then sCommand = Left$(sAccess, lRet - 1) & Mid$(sAccess, lRet + 1) End If ' On Local Error GoTo AsociarExtErr sValue = sProgId sProgId = QueryRegBase(sExt) If Len(sProgId) = 0 Then 'Registrar la extensión sKey = sExt sProgId = sValue lRet = RegSetValue(HKEY_CLASSES_ROOT, sKey, REG_SZ, sValue, Len(sValue)) ' sKey = sProgId sValue = sDescription lRet = RegSetValue(HKEY_CLASSES_ROOT, sKey, REG_SZ, sValue, Len(sValue)) End If sProgId = QueryRegBase(sExt) If Len(sProgId) Then 'Nombre de la clave para esta extensión sDef = "Software\Classes\" & sProgId & "\shell" 'usar HKEY_LOCAL_MACHINE, ya que HKEY_CLASSES_ROOT es una copia de: 'HKEY_LOCAL_MACHINE\Software\Classes hKey = HKEY_LOCAL_MACHINE 'Crear la clave del registro, si ya existe, simplemente la abre. 'Nota: Esta función permite crear varios niveles lRet = RegCreateKey(hKey, sDef, phkResult) If lRet = ERROR_SUCCESS Then 'Si no hay error, la clave está creada y/o abierta ' 'Si no es "open" If sCommand <> "open" Then sKey = sCommand sValue = sAccess lRet = RegSetValue(phkResult, sKey, REG_SZ, sValue, Len(sValue)) ' If Len(sExe) Then sKey = sCommand & "\command" sValue = sExe & Chr$(34) & "%1" & Chr$(34) lRet = RegSetValue(phkResult, sKey, REG_SZ, sValue, Len(sValue)) End If Else 'Abrir (open) If Len(sExe) Then sKey = "\open\command" sValue = sExe & Chr$(34) & "%1" & Chr$(34) 'Si no se especifica sKey, se asigna a la clave abierta lRet = RegSetValue(phkResult, sKey, REG_SZ, sValue, Len(sValue)) End If End If If bDefault Then 'Poner este prograna por defecto (asignarlo a Shell) 'Si no se especifica sKey, se asigna a la clave abierta sKey = "" sValue = sCommand 'sProgId lRet = RegSetValue(phkResult, sKey, REG_SZ, sValue, Len(sValue)) End If ' 'Cerrar la clave abierta lRet = RegCloseKey(phkResult) End If End If End Sub Public Sub DesasociarExt(ByVal sExt As String) 'Para desasociar la extensión indicada ' Dim sProgId As String Dim lRet As eHKEYError 'Si no se especifica el punto If InStr(sExt, ".") = 0 Then sExt = "." & sExt End If sProgId = QueryRegBase(sExt) 'Si la extensión está registrada... If Len(sProgId) Then 'Esto sólo funciona en Windows 95 'lRet = DeleteKeyWin95(HKEY_CLASSES_ROOT, sExt) 'If lRet = ERROR_SUCCESS Then ' Call DeleteKeyWin95(HKEY_CLASSES_ROOT, sProgId) 'End If 'Esto funciona en Windows 98 y Windows NT Call DeleteKeyNT(HKEY_CLASSES_ROOT, sExt) Call DeleteKeyNT(HKEY_CLASSES_ROOT, sProgId) End If End Sub Public Function SetReg(ByVal sKey As String, ByVal sName As String, Optional ByVal vValue As Variant, _ Optional ByVal hKey As eHKEY = HKEY_CURRENT_USER, _ Optional ByVal RegDataType As eHKEYDataType = REG_SZ, _ Optional ByVal bCreateKey As Boolean = True) As eHKEYError 'Asignar un valor en el registro ' 'Parámetros: ' sKey Clave a la que se asignará el valor ' sName Nombre de la entrada a asignar el valor ' vValue Valor a asignar, el tipo se debe corresponder con el ' tipo indicado en el parámetro RegDataType ' hKey Clave principal del registro. ' Si en sKey se incluye, no es necesario especificarla ' RegDataType Tipo de dato a asignar ' bCreateKey Si no existe la clave, crearla ' 'Devolverá un valor del tipo: eHKEYError ' Dim lRet As Long Dim hKey2 As Long Dim cbData As Long Dim aData() As Byte Dim sData As String Dim lData As Long 'Convertimos la clave indicada en un valor correcto, 'para el caso que se indique la clave raiz en sKey hKey = ParseKey(sKey, hKey) 'Abrir la clave indicada lRet = RegOpenKeyEx(hKey, sKey, 0&, KEY_WRITE, hKey2) 'Si da error, comprobar si se crea la clave If lRet <> ERROR_SUCCESS Then If bCreateKey Then lRet = RegCreateKey(hKey, sKey, hKey2) End If End If 'Si se produce error, salir If lRet <> ERROR_SUCCESS Then SetReg = lRet Exit Function End If 'Asignar el valor ' Select Case RegDataType Case REG_BINARY aData = vValue cbData = UBound(aData) lRet = RegSetValueEx(hKey2, sName, 0&, RegDataType, aData(0), cbData) Case REG_DWORD cbData = 4 lData = CLng(vValue) lRet = RegSetValueEx(hKey2, sName, 0&, RegDataType, lData, cbData) Case REG_SZ sData = CStr(vValue) If Len(sData) = 0 Then sData = "" End If cbData = Len(sData) + 1 'Hay que usar ByVal porque está declarado como Any---v lRet = RegSetValueEx(hKey2, sName, 0&, RegDataType, ByVal sData, cbData) End Select lRet = RegCloseKey(hKey2) SetReg = lRet End Function Public Function DeleteKey(ByVal sKey As String, Optional ByVal sValue As String = "", Optional ByVal hKey As eHKEY = HKEY_CURRENT_USER) As eHKEYError 'Borrar la clave especificada del registro 'o el valor especificado ' '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 borrar. ' Si no se especifica, se borrará la clave. ' hKey Clave principal del registro. ' Si en sKey se incluye, no es necesario especificarla 'Devuelve: ' el código devuelto por la operación realizada ' Dim lRet As eHKEYError Dim hKey2 As Long '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) 'Si no se especifica sValue, se borra la clave If Len(sValue) = 0 Then DeleteKey = DeleteKeyNT(hKey, sKey) Exit Function End If 'Borrar el valor indicado lRet = RegOpenKeyEx(hKey, sKey, 0&, KEY_WRITE, hKey2) If lRet = ERROR_SUCCESS Then lRet = RegDeleteValue(hKey2, sValue) Call RegCloseKey(hKey2) End If DeleteKey = lRet End Function