Pastable version of VB6 Registry Editing Class

<pre class='prettyprint' language='asp_vb.net'>Option Explicit

'Const HKEY_LOCAL_MACHINE = &amp;H80000002
'Const HKEY_CURRENT_USER = &amp;H80000001
Const REG_SZ = 1
Const FORMAT_MESSAGE_FROM_SYSTEM = &amp;H1000
Const LANG_ENGLISH = &amp;H9

Private Declare Function RegCloseKey Lib &quot;advapi32&quot; (ByVal hKey As Long) As Long

Private Declare Function RegOpenKeyEx Lib &quot;advapi32&quot; Alias &quot;RegOpenKeyExA&quot; ( _
    ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, _
    ByVal samDesired As Long, ByRef phkResult As Long) As Long

Private Declare Function RegSetValueEx Lib &quot;advapi32.dll&quot; Alias &quot;RegSetValueExA&quot; ( _
    ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, _
    ByVal dwType As Long, lpData As Any, ByVal cbData As Long) As Long

Private Declare Function RegSetValue&amp; Lib &quot;advapi32.dll&quot; _
Alias &quot;RegSetValueA&quot; _
(ByVal hKey As Long, _
ByVal lpSubKey As String, _
ByVal dwType As Long, _
ByVal lpData As String, _
ByVal cbData As Long)

Private Declare Function RegDeleteKey&amp; Lib &quot;advapi32.dll&quot; _
Alias &quot;RegDeleteKeyA&quot; _
(ByVal hKey As Long, _
ByVal lpSubKey As String)

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

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

Private Declare Function RegQueryValueEx Lib &quot;advapi32.dll&quot; Alias &quot;RegQueryValueExA&quot; _
(ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, _
lpType As Long, lpData As Any, lpcbData As Long) As Long

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

Private Declare Function RegOpenKey&amp; Lib &quot;advapi32.dll&quot; _
Alias &quot;RegOpenKeyA&quot; _
(ByVal hKey As Long, _
ByVal lpSubKey As String, _
phkResult As Long)

Private Declare Function RegQueryValue&amp; Lib &quot;advapi32.dll&quot; _
Alias &quot;RegQueryValueA&quot; _
(ByVal hKey As Long, _
ByVal lpSubKey As String, _
ByVal lpValue As String, _
lpcbValue As Long)

Private Declare Function RegCreateKey&amp; Lib &quot;advapi32.dll&quot; _
Alias &quot;RegCreateKeyA&quot; _
(ByVal hKey As Long, _
ByVal lpSubKey As String, _
phkResult As Long)

Private Declare Function RegSetValueExString Lib &quot;advapi32.dll&quot; Alias &quot;RegSetValueExA&quot; _
(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

Private Declare Function RegEnumKeyEx Lib &quot;advapi32.dll&quot; Alias &quot;RegEnumKeyExA&quot; _
                                        (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 RegEnumValue Lib &quot;advapi32.dll&quot; Alias &quot;RegEnumValueA&quot; _
                                        (ByVal hKey As Long, ByVal dwIndex As Long, _
                                        ByVal lpValueName As String, lpcbValueName As Long, _
                                        ByVal lpReserved As Long, lpType As Long, _
                                        lpData As Byte, lpcbData As Long) As Long

Private Declare Function RegQueryInfoKey Lib &quot;advapi32.dll&quot; Alias &quot;RegQueryInfoKeyA&quot; _
                                        (ByVal hKey As Long, ByVal lpClass As String, _
                                        lpcbClass As Long, ByVal 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 Type FILETIME
        dwLowDateTime As Long
        dwHighDateTime As Long
End Type

Const REG_BINARY = 3
Const REG_DWORD = 4
Const REG_OPTION_NON_VOLATILE = 0
Const SYNCHRONIZE = &amp;H100000
Const READ_CONTROL = &amp;H20000
Const STANDARD_RIGHTS_READ = (READ_CONTROL)
Const KEY_QUERY_VALUE = &amp;H1
Const KEY_ENUMERATE_SUB_KEYS = &amp;H8
Const KEY_NOTIFY = &amp;H10
Const KEY_WRITE = &amp;H20006
Const KEY_ALL_ACCESS = &amp;H2003F
Const KEY_READ = _
        ((STANDARD_RIGHTS_READ Or KEY_QUERY_VALUE Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY) And (Not SYNCHRONIZE))
Const ERROR_SUCCESS = 0&amp;

'local variable(s) to hold property value(s)
Private mvarRootKey As String 'local copy
'local variable(s) to hold property value(s)
Private mvarHKeyNode As Long 'local copy
Private mvarRegSZ As Long 'local copy

Private Declare Function RegDeleteValue Lib &quot;advapi32.dll&quot; Alias &quot;RegDeleteValueA&quot; ( _
    ByVal hKey As Long, ByVal lpValueName As String) As Long

Public Property Get HKEY_LOCAL_MACHINE()
    HKEY_LOCAL_MACHINE = &amp;H80000002
End Property

Public Property Get HKEY_CURRENT_USER()
    HKEY_CURRENT_USER = &amp;H80000001
End Property

Public Function GetKeyValue(KeyRoot As Long, KeyName As String, SubKeyRef As String, _
    ByRef KeyVal As Variant) As Boolean
    
    Dim i As Long
    Dim rc As Long
    Dim hKey As Long
    Dim KeyValType As Long
    Dim tmpVal As String
    Dim KeyValSize As Long
    
    rc = RegOpenKeyEx(KeyRoot, KeyName &amp; &quot;\&quot; &amp; SubKeyRef, 0, KEY_ALL_ACCESS, hKey)
    If (rc &lt;&gt; ERROR_SUCCESS) Then GoTo GetKeyError
    
    tmpVal = String$(1024, 0)
    KeyValSize = 1024
    
    rc = RegQueryValueEx(hKey, SubKeyRef, 0, KeyValType, tmpVal, KeyValSize)
    If (rc &lt;&gt; ERROR_SUCCESS) Then GoTo GetKeyError

If (Asc(Mid(tmpVal, KeyValSize, 1)) = 0) Then
        tmpVal = Left(tmpVal, KeyValSize - 1)
    Else
        tmpVal = Left(tmpVal, KeyValSize)
    End If

Select Case KeyValType
        Case REG_DWORD

For i = Len(tmpVal) To 1 Step -1
            KeyVal = KeyVal + Format(Hex(Asc(Mid(tmpVal, i, 1))), &quot;00&quot;)
        Next

KeyVal = Format$(&quot;&amp;h&quot; + KeyVal)
        Case REG_SZ
        KeyVal = tmpVal
    End Select

GetKeyValue = True
rc = RegCloseKey(hKey)
Exit Function

GetKeyError:
GetKeyValue = False
rc = RegCloseKey(hKey)
End Function

Public Function SetKeyValue(KeyRoot As Long, KeyName As String, lType As Long, _
                                SubKeyRef As String, KeyVal As Variant) As Boolean

Dim rc As Long
    Dim hKey As Long
    
    rc = RegOpenKeyEx(KeyRoot, KeyName, 0, KEY_ALL_ACCESS, hKey)

If (rc &lt;&gt; ERROR_SUCCESS) Then
        Call RegCreateKey(KeyRoot, KeyName, hKey)
    End If

Select Case lType
        Case REG_SZ
        rc = RegSetValueEx(hKey, SubKeyRef, 0&amp;, REG_SZ, ByVal CStr(KeyVal &amp; Chr$(0)), Len(KeyVal))
        Case REG_BINARY
        rc = RegSetValueEx(hKey, SubKeyRef, 0&amp;, REG_BINARY, ByVal CStr(KeyVal &amp; Chr$(0)), Len(KeyVal))
        Case REG_DWORD
        rc = RegSetValueEx(hKey, SubKeyRef, 0&amp;, REG_DWORD, CLng(KeyVal), 4)
    End Select

If (rc &lt;&gt; ERROR_SUCCESS) Then GoTo SetKeyError

SetKeyValue = True
rc = RegCloseKey(hKey)

Exit Function
SetKeyError:
KeyVal = &quot;&quot;
SetKeyValue = False
rc = RegCloseKey(hKey)
End Function

Public Function DeleteRegValue(KeyName As String, SubKeyRef As String) As Boolean

Dim rc As Long
    Dim hKey As Long
    rc = RegOpenKeyEx(HKEY_LOCAL_MACHINE, KeyName, 0, KEY_ALL_ACCESS, hKey)
    If (rc &lt;&gt; ERROR_SUCCESS) Then GoTo DeleteKeyError
    rc = RegDeleteValue(hKey, SubKeyRef)
    If (rc &lt;&gt; ERROR_SUCCESS) Then GoTo DeleteKeyError
    DeleteRegValue = True
    Exit Function
DeleteKeyError:
    DeleteRegValue = False
    
End Function

Public Function DeleteRegKey(KeyName As String) As Boolean

Dim rc As Long
    'All sub keys must be deleted for this t
    '     o work.
    'If you create key under your original k
    '     ey, you
    'need to delete it forst.
    rc = RegDeleteKey(HKEY_LOCAL_MACHINE, KeyName)
    DeleteRegKey = IIf(rc = ERROR_SUCCESS, True, False)
End Function

Public Sub EnumerateKeys(Key As String, ByRef cSubKeys As Collection)
    Err.Clear
    On Error GoTo HandleError
    
    Dim lHandle As Long, lCounter As Long
    Dim lpClass As String
    Dim lpcbClass As Long, lpcbSubKeys As Long
    Dim lpcbMaxSubKeyLen As Long, lpcbMaxClassLen As Long
    Dim lpcValues As Long, lpcbMaxValueNameLen As Long
    Dim lpcbMaxValueLen As Long, lpcbSecurityDesc As Long
    Dim lpftLastWriteTime As FILETIME
    
    Set cSubKeys = New Collection
    
    If RegOpenKey(mvarHKeyNode, mvarRootKey &amp; &quot;\&quot; &amp; Key, lHandle) = 0 Then
        lpcbClass = 255
        lpClass = String(lpcbClass, &quot; &quot;)
        
        If RegQueryInfoKey(lHandle, lpClass, lpcbClass, 0, lpcbSubKeys, lpcbMaxSubKeyLen, lpcbMaxClassLen, _
                            lpcValues, lpcbMaxValueNameLen, lpcbMaxValueLen, _
                            lpcbSecurityDesc, lpftLastWriteTime) = 0 Then
            
            Dim lpName As String
            Dim lpcbName As Long
            
            For lCounter = 0 To lpcbSubKeys - 1
                lpcbName = 255
                lpName = &quot;&quot;
                lpName = String(lpcbName, &quot; &quot;)
                
                RegEnumKeyEx lHandle, lCounter, lpName, lpcbName, 0, lpClass, _
                                                lpcbClass, lpftLastWriteTime
                If lpName &lt;&gt; &quot;&quot; Then
                    lpName = RTrim(LTrim(lpName))
                    lpName = Left(lpName, Len(lpName) - 1)
                    
                    cSubKeys.Add lpName, lpName
                Else
                    'msgbox &quot;RegEnumKeyEx Failed&quot;
                End If
            Next
        Else
            'msgbox &quot;RegQueryInfoKey Failed&quot;
        End If
    Else
        'msgbox &quot;RegOpenKey Failed&quot;
    End If
    
Exit Sub
HandleError:
End Sub

Public Sub EnumerateValues(Section As String, Key As String, ByRef cSubValues As Collection)
   Err.Clear
    On Error GoTo HandleError
    
    Dim lHandle As Long, lCounter As Long
    Dim lpClass As String
    Dim lpcbClass As Long, lpcbSubKeys As Long
    Dim lpcbMaxSubKeyLen As Long, lpcbMaxClassLen As Long
    Dim lpcValues As Long, lpcbMaxValueNameLen As Long
    Dim lpcbMaxValueLen As Long, lpcbSecurityDesc As Long
    Dim lpftLastWriteTime As FILETIME
    
    Set cSubValues = New Collection
    
    If RegOpenKey(mvarHKeyNode, mvarRootKey &amp; &quot;\&quot; &amp; Section &amp; &quot;\&quot; &amp; Key, lHandle) = 0 Then
        lpcbClass = 255
        lpClass = String(lpcbClass, &quot; &quot;)
        
        If RegQueryInfoKey(lHandle, lpClass, lpcbClass, 0, lpcbSubKeys, lpcbMaxSubKeyLen, lpcbMaxClassLen, _
                            lpcValues, lpcbMaxValueNameLen, lpcbMaxValueLen, _
                            lpcbSecurityDesc, lpftLastWriteTime) = 0 Then
            
            Dim lpName As String
            Dim lpcbName As Long
            Dim lpType As Long
            Dim lpData As Byte
            
            For lCounter = 0 To lpcValues - 1
                lpcbName = 255
                lpName = &quot;&quot;
                lpName = String(lpcbName, &quot; &quot;)
                
                RegEnumValue lHandle, lCounter, lpName, lpcbName, 0, lpType, lpData, 255
                
                If lpName &lt;&gt; &quot;&quot; Then
                    lpName = RTrim(LTrim(lpName))
                    lpName = Left(lpName, Len(lpName) - 1)
                    
                    cSubValues.Add lpName, lpName
                Else
                    'msgbox &quot;RegEnumKeyEx Failed&quot;
                End If
            Next
        Else
            'msgbox &quot;RegQueryInfoKey Failed&quot;
        End If
    Else
        'msgbox &quot;RegOpenKey Failed&quot;
    End If
    
Exit Sub
HandleError:
End Sub

'This function creates a single key that is under &quot;mvarRootKey\Section&quot;
'and sets the value of that key to KeyValue
Public Sub SaveSetting(Section As String, Key As String, KeyValue As String)
    Dim lHandle&amp;, lResult&amp;
    Dim strSubKey As String, lpBuffer As String
    Dim strError As String
    
    Err.Clear
    On Error GoTo HandleError
    
    If Section &lt;&gt; &quot;&quot; And Key &lt;&gt; &quot;&quot; And KeyValue &lt;&gt; &quot;&quot; Then
        strSubKey = mvarRootKey &amp; &quot;\&quot; &amp; Section
        
        lResult = RegCreateKey(mvarHKeyNode, strSubKey, lHandle)
        
        If lResult &lt;&gt; 0 Then
            strError = &quot;RegCreateKey failed&quot;
            GoTo HandleError
        Else
            SetValueString lHandle, Key, KeyValue
        End If
    End If
Exit Sub
HandleError:
    If strError = &quot;&quot; Then strError = Err.Description
    App.LogEvent &quot;Error ocurred in PPRegistryX.SaveSetting:  &quot; &amp; Chr(13) &amp; _
                    strError &amp; Chr(13) &amp; _
                    &quot;Section = &quot; &amp; Section &amp; Chr(13) &amp; _
                    &quot;Key = &quot; &amp; Key &amp; Chr(13) &amp; _
                    &quot;KeyValue = &quot; &amp; KeyValue &amp; Chr(13) &amp; _
                    &quot;lResult = &quot; &amp; lResult, vbLogEventTypeError
End Sub

Public Function GetSetting(Section As String, Key As String, Optional DefaultValue As String = &quot;&quot;) As String
    Dim lHandle&amp;, lResult&amp;, lSize&amp;, lType&amp;, cch&amp;
    Dim strValue As String, strError As String
    
    Err.Clear
    On Error GoTo HandleError
    
    If RegOpenKey(mvarHKeyNode, mvarRootKey &amp; &quot;\&quot; &amp; Section, lHandle) &lt;&gt; 0 Then
        'key doesn't exist return default value
        SaveSetting Section, Key, DefaultValue
        GetSetting = DefaultValue
    Else
        'key exists, return value
        ' Determine the size and type of data to be read
        
        lSize&amp; = RegQueryValueExNULL(lHandle&amp;, Key, 0&amp;, lType, 0&amp;, cch)
        
        If lSize = 0 Then
            strValue = String(cch, 0)
            lSize&amp; = RegQueryValueExString(lHandle&amp;, Key, 0&amp;, lType, strValue, cch)
        
            GetSetting = Left$(strValue, cch - 1)
        Else
            'value doesn't exist
            SaveSetting Section, Key, DefaultValue
            GetSetting = DefaultValue
        End If
    End If
Exit Function
HandleError:
    SaveSetting Section, Key, DefaultValue
    GetSetting = DefaultValue

If strError = &quot;&quot; Then strError = Err.Description
    App.LogEvent &quot;Error ocurred in PPRegistryX.GetSetting:  &quot; &amp; Chr(13) &amp; _
                    strError &amp; Chr(13) &amp; _
                    &quot;Section = &quot; &amp; Section &amp; Chr(13) &amp; _
                    &quot;Key = &quot; &amp; Key &amp; Chr(13) &amp; _
                    &quot;DefaultValue = &quot; &amp; DefaultValue &amp; Chr(13) &amp; _
                    &quot;lResult = &quot; &amp; lResult, vbLogEventTypeError
End Function

Public Property Get RegDWORD() As Long
'used when retrieving value of a property, on the right side of an assignment.
'Syntax: 'debug.print X.RegSZ
    RegDWORD = REG_DWORD
End Property

Public Property Let RegSZ(ByVal vData As Long)
'used when assigning a value to the property, on the left side of an assignment.
'Syntax: X.RegSZ = 5
    mvarRegSZ = vData
End Property

Public Property Get RegSZ() As Long
'used when retrieving value of a property, on the right side of an assignment.
'Syntax: 'debug.print X.RegSZ
    RegSZ = mvarRegSZ
End Property

Public Property Let HKeyNode(ByVal vData As Long)
'used when assigning a value to the property, on the left side of an assignment.
'Syntax: X.HKeyNode = 5
    mvarHKeyNode = vData
End Property

Public Property Get HKeyNode() As Long
'used when retrieving value of a property, on the right side of an assignment.
'Syntax: 'debug.print X.HKeyNode
    HKeyNode = mvarHKeyNode
End Property

Public Property Let RootKey(ByVal vData As String)
'used when assigning a value to the property, on the left side of an assignment.
'Syntax: X.RootKey = 5
    mvarRootKey = vData
End Property

Public Property Get RootKey() As String
'used when retrieving value of a property, on the right side of an assignment.
'Syntax: 'debug.print X.RootKey
    RootKey = mvarRootKey
End Property

Private Sub Class_Initialize()
    mvarHKeyNode = HKEY_LOCAL_MACHINE
    mvarRegSZ = REG_SZ
    mvarRootKey = &quot;Software&quot;
End Sub

Public Function SetValueString(ByVal hKey As Long, sValueName As String, vValue As Variant) As Long

Dim lValue As Long
    Dim sValue As String
    
    sValue = vValue &amp; Chr$(0)
    SetValueString = RegSetValueExString(hKey, sValueName, _
    0&amp;, mvarRegSZ, sValue, Len(sValue))

End Function

Public Function QueryValueEx(ByVal lhKey As Long, ByVal szValueName As String, vValue As Variant) As String
    Dim cch As Long, X
    Dim lrc As Long
    Dim lType As Long
    Dim lValue As Long, wValue(255) As Byte
    Dim sValue As String

On Error GoTo QueryValueExError

' Determine the size and type of data to be read
    lrc = RegQueryValueExNULL(lhKey, szValueName, 0&amp;, lType, 0&amp;, cch)
    If lrc &lt;&gt; 0 Then Error 5

sValue = String(cch, 0)
    lrc = RegQueryValueExString(lhKey, szValueName, 0&amp;, lType, sValue, cch)

If lrc = 0 Then
        vValue = Left$(sValue, cch - 1)
    Else
        vValue = Empty
    End If

QueryValueExExit:
    QueryValueEx = vValue
    Exit Function

QueryValueExError:
    Resume QueryValueExExit
End Function</pre>
<a href="http://www.refactormycode.com/codes/726-vb6-registry-editing-class" style="color:#fff" title="As seen on RefactorMyCode.com"><img alt="Small_logo" src="http://www.refactormycode.com/images/small_logo.gif" style="border:0" /></a>

Refactor :my => 'code'

Recent

Popular

Pastable version of VB6 Registry Editing Class