' Reading and Writing to the Registry
'
' Jon Vote, Idioma Software Inc.
'
' 02/2002
'
' 1) Create a new project. Form1 will be created by default.
' 2) Add a Frame to the Form.
' 3) Click on the Frame, and add an Option Button to the Form.
' 4) Make sure the Option Button is attached to the Frame.
' You should not be able to move it off of the Frame.
' 5) Click on the Option Button and select Edit|Copy from the Menu.
' 6) Click on the Frame again and select Edit|Paste from the Menu.
' 7) Answer Yes when asked if you wish to create a Control Array.
' 8) Repeat this process until you have six Option Buttons stacked
' on top of each other.
' 9) Set the Width of the Option Buttons to at least 2500 or so
' 10) Stack three Label, Textbox pairs below the Frame. The Labels should be
' to the left of the Textboxes. Don't use a Control Array this time.
' 11) Set the Textboxs' widths to about 5100 or so.
' 12) Add three Command Buttons (not Control Arrays) to the Form below the Frame.
' 13) Add a Module to the Project.
' 14) Paste the following code into the declarations section of Form1.
' --- Begin code for Form1
' Reading and Writing to the Windows Registry
'
' Jon Vote, Idioma Software Inc.
'
' 02/2002
'
' www.idioma-software.com
'
Option Explicit
Private Sub Command1_Click()
'Create Key
Dim strValue As String
strValue = Trim$(Text1.Text)
If strValue = "" Then
MsgBox "Please enter a value "
Text1.SetFocus
Else
CreateNewKey strValue, GetHKEY()
End If
End Sub
Private Sub Command2_Click()
Dim strKey As String
Dim strValue As String
Dim strSetting As String
strKey = Trim$(Text1.Text)
strValue = Trim$(Text2.Text)
strSetting = Trim$(Text3.Text)
If strKey & strValue & strSetting = "" Then
MsgBox "Please enter Key, Value and Settings"
Text1.SetFocus
Else
SetKeyValue strKey, strValue, strSetting, GetHKEY()
End If
End Sub
Private Sub Command3_Click()
Dim strKey As String
Dim strSetting As String
strKey = Trim$(Text1.Text)
strSetting = Trim$(Text2.Text)
If strKey & strSetting = "" Then
MsgBox "Please enter Key and Settings"
Text1.SetFocus
Else
MsgBox "The value in the registry is: " & QueryValue(strKey, strSetting, GetHKEY())
End If
End Sub
Private Sub Form_Load()
Me.Caption = "Registry Example"
Frame1.Caption = "HKEY_"
Option1(0).Caption = "HKEY_CLASSES_ROOT"
Option1(1).Caption = "HKEY_CURRENT_USER"
Option1(2).Caption = "HKEY_LOCAL_MACHINE"
Option1(3).Caption = "HKEY_USERS"
Option1(4).Caption = "HKEY_CURRENT_CONFIG"
Option1(5).Caption = "HKEY_DYN_DATA"
Option1(1).Value = True
Label1.Caption = "Key:"
Label2.Caption = "Value:"
Label3.Caption = "Setting:"
Text1.Text = "Software\VB and VBA Program Settings\Skycoder Registry Example"
Text2.Text = "Test Value"
Text3.Text = "Test Setting"
Command1.Caption = "CreateKey"
Command2.Caption = "SetKeyValue"
Command3.Caption = "QueryValue"
End Sub
Private Function GetHKEY() As Long
If Option1(0).Value Then
GetHKEY = HKEY_CLASSES_ROOT
ElseIf Option1(1).Value Then
GetHKEY = HKEY_CURRENT_USER
ElseIf Option1(2).Value Then
GetHKEY = HKEY_LOCAL_MACHINE
ElseIf Option1(3).Value Then
GetHKEY = HKEY_USERS
ElseIf Option1(4).Value Then
GetHKEY = HKEY_CURRENT_CONFIG
ElseIf Option1(5).Value Then
GetHKEY = HKEY_DYN_DATA
Else
MsgBox "Please select an option"
End If
End Function
' --- End code for Form1 ---
' 15) Paste the followin code into Module1:
' --- Begin code for Module1 ---
'Registry API
Option Explicit
Public Const REG_SZ As Long = 1
Public Const REG_DWORD As Long = 4
Public Const REG_EXPAND_SZ = 2
Public Const HKEY_CLASSES_ROOT = &H80000000
Public Const HKEY_CURRENT_USER = &H80000001
Public Const HKEY_LOCAL_MACHINE = &H80000002
Public Const HKEY_USERS = &H80000003
Public Const HKEY_CURRENT_CONFIG = &H80000005
Public Const HKEY_DYN_DATA = &H80000006
Public Const ERROR_NONE = 0
Public Const ERROR_BADDB = 1
Public Const ERROR_BADKEY = 2
Public Const ERROR_CANTOPEN = 3
Public Const ERROR_CANTREAD = 4
Public Const ERROR_CANTWRITE = 5
Public Const ERROR_OUTOFMEMORY = 6
Public Const ERROR_ARENA_TRASHED = 7
Public Const ERROR_ACCESS_DENIED = 8
Public Const ERROR_INVALID_PARAMETERS = 87
Public Const ERROR_NO_MORE_ITEMS = 259
Public Const KEY_QUERY_VALUE = &H1
Public Const KEY_SET_VALUE = &H2
Public Const KEY_ALL_ACCESS = &H3F
Public Const REG_OPTION_NON_VOLATILE = 0
Public Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Public 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
Public 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
Public 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
Public 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
Public 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
Public 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
Public 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 Sub CreateNewKey(strKey As String, lngHKey As Long)
Dim hNewKey As Long
Dim lngRC As Long
lngRC = RegCreateKeyEx(lngHKey, strKey, 0&, vbNullString, _
REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS, 0&, hNewKey, lngRC)
RegCloseKey (hNewKey)
End Sub
Public Sub SetKeyValue(ByVal strKey As String, ByVal strValue As String, _
strSetting As String, lngHKey As Long)
Dim lngRC As Long 'result of the SetValueEx function
Dim hNewKey As Long 'handle of open key
'Open the key
lngRC = RegOpenKeyEx(lngHKey, strKey, 0&, _
KEY_SET_VALUE, hNewKey)
'Put the value
lngRC = RegSetValueExString(hNewKey, _
strValue, 0&, REG_SZ, strSetting, Len(strSetting))
'Close the key
RegCloseKey (hNewKey)
End Sub
Public Function SetValueEx(ByVal hKey As Long, ByVal _
strValue As String, ByVal strValue As String) As Long
sValue = vValue & Chr$(0)
SetValueEx = RegSetValueExString(hKey, strValue, 0&, lType, sValue, Len(sValue))
End Function
Public Function QueryValue(strKey As String, _
strValue As String, lPredefinedKey As Long) As String
Dim lngRC As Long
Dim hKey As Long
Dim strSetting As String
'Get the key handle
lngRC = RegOpenKeyEx(lPredefinedKey, strKey, 0, _
KEY_QUERY_VALUE, hKey)
'Get the value
lngRC = QueryValueEx(hKey, strValue, strSetting)
RegCloseKey (hKey)
QueryValue = strValue
End Function
Public Function QueryValueEx(ByVal hKey As Long, _
ByVal strValue As String, ByRef strSetting As String) As Long
Dim lngRC As Long
Dim lngChData As Long
'Get the length, zero if error
lngRC = RegQueryValueExNULL(hKey, strValue, 0&, REG_SZ, 0&, lngChData)
If lngRC <> ERROR_NONE Then
Call PutError(lngRC)
QueryValueEx = lngRC
GoTo xt_QueryValueEx
Else
strSetting = Space$(lngChData)
lngRC = RegQueryValueExString(hKey, strValue, 0&, REG_SZ, _
strSetting, lngChData)
End If
If lngRC = ERROR_NONE Then
strSetting = Left$(strSetting, lngChData - 1)
Else
Call PutError(lngRC)
strSetting = ""
End If
xt_QueryValueEx:
QueryValueEx = lngRC
End Function
Public Function GetError(ByVal lngErrorCode As Long) As String
Select Case lngErrorCode
Case ERROR_BADDB
GetError = "Bad DB"
Case ERROR_BADKEY
GetError = "Bad Key"
Case ERROR_CANTOPEN
GetError = "Can't Open"
Case ERROR_CANTREAD
GetError = "Can't Read"
Case ERROR_CANTWRITE
GetError = "Can't Write"
Case ERROR_OUTOFMEMORY
GetError = "Out of Memory"
Case ERROR_ARENA_TRASHED
GetError = "Arena Trashed" 'Ooo that sounds like a bad one!
Case ERROR_ACCESS_DENIED
GetError = "Access Denied"
Case ERROR_INVALID_PARAMETERS
GetError = "Invalid Parameters"
Case ERROR_NO_MORE_ITEMS
GetError = "No more items"
Case Else
GetError = "Who knows what happened but it's bad!"
End Select
End Function
Public Sub PutError(ByVal lngError As Long)
Dim strMessage As String
strMessage = "Error occurred - " & GetError(lngError) & vbCrLf & vbCrLf
strMessage = strMessage & "Be sure to: " & vbCrLf
strMessage = strMessage & " 1) Create the key" & vbCrLf
strMessage = strMessage & " 2) Set the Key Value" & vbCrLf
strMessage = strMessage & " 3) Then you can query the value."
MsgBox strMessage
End Sub
' --- End code for Module1 ---