Reading and Writing Registry Values

Normally you should use [tt]SaveSetting[/tt] and [tt]GetSetting[/tt] to access the Windows Registry.

[tt]SaveSetting[/tt] and [tt]GetSetting[/tt] provide a safe and reliable way to store most of the values your application needs to run, window positions and database connect strings etc. Use [tt]SaveSetting[/tt] and [tt]GetSetting[/tt] whenever you can as it's easy to make a mess of your Registry.

There are, sometimes, occaisions when you need to be able to get to any value in the registry and perhaps write there as well. The module below will help you with that.

Copy the code into a VB module and look for the procedure [tt]TestRegModule()][/tt] for an example of how to use the module.

This module is well used and you shouldn't have many problems with it. But it is presented "as is" - it's your responsibility to write programs that run safely. BE CAREFUL when writing to the Registry.

Having said that - have fun and please let me know if you find any mistakes or problems with the code -- or if you would like to contribute by adding to the "unsupported" datatypes <s>

--start of module--[tt]
Option Explicit

'API Function and Constant Declarations
'--------------------------------------


'***Declare the value data types
Global Const REG_SZ As Long = 1 '***Registry string
Global Const REG_DWORD As Long = 4 '***Registry number (32-bit number)

'***Declare the keys that should exist.
'***Typically applications will put information under HKEY_CURRENT_USER
Global Const HKEY_CLASSES_ROOT = &H80000000
Global Const HKEY_CURRENT_USER = &H80000001
Global Const HKEY_LOCAL_MACHINE = &H80000002
Global Const HKEY_USERS = &H80000003

'***Errors
Global Const ERROR_NONE = 0
Global Const ERROR_BADDB = 1
Global Const ERROR_BADKEY = 2
Global Const ERROR_CANTOPEN = 3
Global Const ERROR_CANTREAD = 4
Global Const ERROR_CANTWRITE = 5
Global Const ERROR_OUTOFMEMORY = 6
Global Const ERROR_INVALID_PARAMETER = 7
Global Const ERROR_ACCESS_DENIED = 8
Global Const ERROR_INVALID_PARAMETERS = 87
Global Const ERROR_NO_MORE_ITEMS = 259

'***Gives all users full access to the key
Global Const KEY_ALL_ACCESS = &H3F

'***Creates a key that is persistent
Global Const REG_OPTION_NON_VOLATILE = 0

Global gstrAppVersion As String

'***Registry API declarations
Declare Function RegCloseKey Lib "advapi32.dll" ( _
ByVal hKey As Long _
) As Long

Declare Function RegCreateKeyEx Lib "advapi32.dll" Alias "RegCreateKeyExA" ( _
ByVal hKey As Long, _
ByVal lpSubKey As String, _
ByVal Reserved As Long, _
ByVal lpClass As String, _
ByVal dwOptions As Long, _
ByVal samDesired As Long, _
ByVal lpSecurityAttributes As Long, _
phkResult As Long, _
lpdwDisposition As Long _
) As Long

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

Declare Function RegQueryValueExString Lib "advapi32.dll" Alias "RegQueryValueExA" ( _
ByVal hKey As Long, _
ByVal lpValueName As String, _
ByVal lpReserved As Long, _
lpType As Long, _
ByVal lpData As String, _
lpcbData As Long _
) As Long

Declare Function RegQueryValueExLong Lib "advapi32.dll" Alias _
"RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As _
String, ByVal lpReserved As Long, lpType As Long, lpData As _
Long, lpcbData As Long) As Long

Declare Function RegQueryValueExNULL Lib "advapi32.dll" Alias _
"RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As _
String, ByVal lpReserved As Long, lpType As Long, ByVal lpData _
As Long, lpcbData As Long) As Long

Declare Function RegSetValueExString Lib "advapi32.dll" Alias _
"RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, _
ByVal Reserved As Long, ByVal dwType As Long, ByVal lpValue As _
String, ByVal cbData As Long) As Long

Declare Function RegSetValueExLong Lib "advapi32.dll" Alias _
"RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, _
ByVal Reserved As Long, ByVal dwType As Long, lpValue As Long, _
ByVal cbData As Long) As Long


Public Function SetValueEx( _
ByVal hKey As Long, _
sValueName As String, _
lType As Long, _
vValue As Variant _
) As Long

'*** Called By: SetKeyValue
'*** Description: Wrapper function around the registry API calls
'*** RegSetValueExString/Long. Determines if the value
'*** is a string or a long and calls the appropriate API.
'*** Return Value: Returns the API call's return value, which is its
'*** status (successful, error).

Dim lValue As Long
Dim sValue As String

Select Case lType
'***String
Case REG_SZ
sValue = vValue
SetValueEx = RegSetValueExString(hKey, sValueName, 0&, lType, sValue, Len(sValue))
'***32-bit number
Case REG_DWORD
lValue = vValue
SetValueEx = RegSetValueExLong(hKey, sValueName, 0&, lType, lValue, 4)
End Select

End Function

Private Function QueryValueEx( _
ByVal lhKey As Long, _
ByVal szValueName As String, _
vValue As Variant _
) As Long

'*** Called By: QueryValue
'*** Description: Wrapper function around the registry API calls to
'*** RegQueryValueExLong and RegQueryValueExString.
'*** Determines size and type of data to be read.
'*** Determines if the value is a string or a long
'*** and calls the appropriate API.
'*** Return Value: Returns the API call's return value, which is its
'*** status (successful, error). The parameter vValue
'*** contains the value queried.

Dim cch As Long
Dim lrc As Long
Dim lType As Long
Dim lValue As Long
Dim sValue As String

On Error GoTo QueryValueExError

' Determine the size and type of data to be read
lrc = RegQueryValueExNULL(lhKey, szValueName, 0&, lType, 0&, cch)

If lrc <> ERROR_NONE Then Error 5

Select Case lType
' For strings
Case REG_SZ:
sValue = String(cch, 0)
lrc = RegQueryValueExString(lhKey, szValueName, 0&, lType, sValue, cch)
If lrc = ERROR_NONE Then
If Mid(sValue, cch, 1) = Chr(0) Then
vValue = Left$(sValue, cch - 1) ' get rid of trailing AsciiZ
Else
vValue = Left$(sValue, cch)
End If
Else
vValue = Empty
End If
' For DWORDS
Case REG_DWORD:
lrc = RegQueryValueExLong(lhKey, szValueName, 0&, lType, lValue, cch)
If lrc = ERROR_NONE Then vValue = lValue
Case Else
'all other data types not supported
lrc = -1
End Select

QueryValueExExit:
QueryValueEx = lrc

Exit Function

QueryValueExError:
Resume QueryValueExExit ' Hmmmm
End Function

Public Sub CreateNewKey(sNewKeyName As String, lPredefinedKey As Long)
'***With this procedure a call of
'*** CreateNewKey "TestKey", HKEY_CURRENT_USER
'***will create a key called TestKey immediately under HKEY_CURRENT_USER.
'***Calling CreateNewKey like this
'*** CreateNewKey "TestKey\SubKey1\SubKey2", HKEY_CURRENT_USER
'***will create a three-nested keys beginning with TestKey immediately under
'***HKEY_CURRENT_USER, Subkey1 subordinate to TestKey, and SubKey3 under
'***SubKey2.

'*** Called by: your own code to create keys
'*** Description: Wrapper around the RegCreateKeyEx API call.

Dim hNewKey As Long 'handle to the new key
Dim lRetVal As Long 'result of the RegCreateKeyEx function

lRetVal = RegCreateKeyEx( _
lPredefinedKey, _
sNewKeyName, _
0&, _
vbNullString, _
REG_OPTION_NON_VOLATILE, _
KEY_ALL_ACCESS, _
0&, _
hNewKey, _
lRetVal _
)

RegCloseKey hNewKey

End Sub

Public Sub SetKeyValue( _
ByVal lpParentKey As Long, _
sKeyName As String, _
sValueName As String, _
vValueSetting As Variant, _
lValueType As Long _
)

'*** Called By: Your code when you want to set a KeyValue
'*** Description: Opens the key you want to set, calls the wrapper
'*** function SetValueEx, and closes key.
'*** ADD ERROR HANDLING!!

Dim lRetVal As Long 'result of the SetValueEx function
Dim hKey As Long 'handle of open key

'open the specified key
lRetVal = RegOpenKeyEx(lpParentKey, sKeyName, 0, KEY_ALL_ACCESS, hKey)
' write the value
lRetVal = SetValueEx(hKey, sValueName, lValueType, vValueSetting)
' close the key
RegCloseKey (hKey)

End Sub
Public Function QueryValue( _
ByVal lpParentKey As Long, _
sKeyName As String, _
sValueName As String _
) As Variant

'*** Called By: Your code when you want to set a read a KeyValue
'*** Description: Opens the key you want to set, calls the wrapper
'*** function QueryValueEx, closes key.
'*** Return Value: The value you are querying
'*** ADD ERROR HANDLING!!

Dim lRetVal As Long 'result of the API functions
Dim hKey As Long 'handle of opened key
Dim vValue As Variant 'setting of queried value

' open the key
lRetVal = RegOpenKeyEx(lpParentKey, sKeyName, 0, KEY_ALL_ACCESS, hKey)
' get the value
lRetVal = QueryValueEx(hKey, sValueName, vValue)
' close the key
RegCloseKey (hKey)

QueryValue = vValue

End Function

Public Sub TestRegModule()

'
' This procedure demonstrates the use of this module
' All code below here is demo code
'
CreateKeyDriver
Debug.Print "Created key Cosmic Example and TestVals"

SetStringValueDriver
Debug.Print "Created the TestStringVal"

SetNumberValueDriver
Debug.Print "Created the TestNumVal"

ReadValueDriver

End

End Sub

Sub CreateKeyDriver()

'
' demo code
'

'*** Calls the CreateNewKey procedure
'*** Description: Creates Cosmic Example key and TestVals subkey under
'*** HKEY_CURRENT_USER\Software\VB and VBA Program Settings
'*** If Software and/or VB and VBA Program Settings do not
'*** exist, they are created.
'*** Usage: Use this as an example of how you would use the CreateNewKey
'*** procedure.

Dim sNewKey As String
Dim lPredefinedKeyValue As Long

sNewKey = "Software\VB and VBA Program Settings\Cosmic Example\TestVals"
lPredefinedKeyValue = HKEY_CURRENT_USER

CreateNewKey sNewKey, lPredefinedKeyValue

End Sub

Sub SetStringValueDriver()

'
' demo code
'

'*** Calls the SetKeyValue procedure
'*** Description: Sets the value TestStringVal under the
'*** Cosmic Example\TestVals key and sets it to
'*** VB App Created. If it doesn't exist, it creates it.
'*** Usage: Use this as an example of how you would use the SetKeyValue
'*** procedure.

Dim sKey As String '***Key under which to create the value
Dim sValue As String '***Value name to set
Dim vSetting As Variant '***What to set the Value to
Dim sType As Long '***Value type -- string or number

sKey = "Software\VB and VBA Program Settings\Cosmic Example\TestVals"
sValue = "TestStringVal"
vSetting = "VB App Created"
sType = REG_SZ

SetKeyValue HKEY_CURRENT_USER, sKey, sValue, vSetting, sType

End Sub
Sub SetNumberValueDriver()

'
' demo code
'

'*** Calls the SetKeyValue procedure
'*** Description: Sets the value TestNumVal under the
'*** Cosmic Example\TestVals key and sets it to 5.
'*** If it doesn't exist, it creates it.
'*** Usage: Use this as an example of how you would use the SetKeyValue
'*** procedure.

Dim sKey As String '***Key under which to create the value
Dim sValue As String '***Value name to set
Dim vSetting As Variant '***Wht to set the Value to
Dim sType As Long '***Value type -- string or number

sKey = "Software\VB and VBA Program Settings\Cosmic Example\TestVals"
sValue = "TestNumVal"
vSetting = 5
sType = REG_DWORD

SetKeyValue HKEY_CURRENT_USER, sKey, sValue, vSetting, sType

End Sub
Sub ReadValueDriver()

'
' demo code
'

'*** Calls the QueryValue function
'*** Description: Reads the value TestNumVal and TestStringVal under
'*** the Cosmic Example\TestVals key.
'*** Usage: Use this as an example of how you would use the QueryValue
'*** procedure.

Dim sKey As String '***Key under which to create the value
Dim sValue As String '***Value name to set
Dim vSetting As Variant

sKey = "Software\VB and VBA Program Settings\Cosmic Example\TestVals"
sValue = "TestStringVal"

'***Read the String value
vSetting = QueryValue(HKEY_CURRENT_USER, sKey, sValue)
Debug.Print "TestStringVal is " & vSetting

sValue = "TestNumVal"
'***Read the number value
vSetting = QueryValue(HKEY_CURRENT_USER, sKey, sValue)
Debug.Print "TestNumVal is " & vSetting

End Sub
[/tt]