Problem with Registry

[matt_man22]

Does anyone know why this sub to rename a key only copies one subkey? I can't figure out why it would only copy one subkey since it looks right. Thanks in advance.

code:

Option Explicit

Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type

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 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, lpSecurityAttributes As Any, phkResult As Long, lpdwDisposition As Long) As Long

Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey 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 RegEnumValue Lib "advapi32.dll" Alias "RegEnumValueA" (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 RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey As String) As Long

Private Const HKEY_CLASSES_ROOT = &H80000000
Private Const HKEY_CURRENT_CONFIG = &H80000005
Private Const HKEY_CURRENT_USER = &H80000001
Private Const HKEY_DYN_DATA = &H80000006
Private Const HKEY_LOCAL_MACHINE = &H80000002
Private Const HKEY_PERFORMANCE_DATA = &H80000004
Private Const HKEY_USERS = &H80000003


Private Const KEY_CREATE_LINK = &H20
Private Const KEY_CREATE_SUB_KEY = &H4
Private Const KEY_ENUMERATE_SUB_KEYS = &H8
Private Const KEY_EVENT = &H1
Private Const KEY_NOTIFY = &H10
Private Const KEY_QUERY_VALUE = &H1
Private Const KEY_SET_VALUE = &H2
Private Const SYNCHRONIZE = &H100000
Private Const STANDARD_RIGHTS_ALL = &H1F0000
Private Const 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))

Private Const REG_CREATED_NEW_KEY = &H1

Private lNewKey As Long

Public Sub RenameRegKey(ByVal sRegKey As String, ByVal SRegBase As String, ByVal sNewName As String, Optional ByVal lHive As Long = HKEY_LOCAL_MACHINE)
Dim lRegKey As Long
Dim lResult As Long

'Create the New Base Registry Key And Get the handle To the existing one
lNewKey = 0
If RegOpenKeyEx(lHive, sRegKey, 0&, KEY_ALL_ACCESS, lRegKey) Then Exit Sub
If RegCreateKeyEx(lHive, SRegBase & sNewName, 0, "", 0, KEY_ALL_ACCESS, ByVal 0&, lNewKey, lResult) Or (lResult <> REG_CREATED_NEW_KEY) Then
Call RegCloseKey(lRegKey)
Exit Sub
End If

'Copy all Keys In the Original Key structure To the New Key
DuplicateKeys lRegKey, lNewKey
DuplicateValues lRegKey, lNewKey

'Close Both the Old And New Keys
Call RegCloseKey(lRegKey)
Call RegCloseKey(lNewKey)

'Delete the Old Key
Call RegDeleteKey(lHive, sRegKey)
End Sub

Private Sub DuplicateKeys(ByVal lKey As Long, ByVal lKeyCopy As Long)
Dim lIndex As Long, lSubKey As Long, lSubKeyCopy As Long, lResult As Long
Dim sName As String, sClass As String
Dim tFILETIME As FILETIME

'Enumerate all SubKeys of the specified Key
sName = Space(255): sClass = Space(255)
lIndex = 0
While RegEnumKeyEx(lKey, lIndex, sName, 255, 0, sClass, 255, tFILETIME) = 0
sName = Left(sName, InStr(sName, Chr(0)) - 1)
If InStr(sClass, Chr(0)) Then
sClass = Left(sClass, InStr(sClass, Chr(0)) - 1)
End If
'Create a copy of this Subkey
If RegCreateKeyEx(lKeyCopy, sName, 0, sClass, 0, KEY_ALL_ACCESS, ByVal 0&, lSubKeyCopy, 0) = 0 Then
If RegOpenKeyEx(lKey, sName, 0, KEY_ALL_ACCESS, lSubKey) = 0 Then
'If there are SubKeys To this Key, Copy them too
Call DuplicateKeys(lSubKey, lSubKeyCopy)
'Copy all Values In this Key
Call DuplicateValues(lSubKey, lSubKeyCopy)
'Close this Key, Then delete the original
Call RegCloseKey(lSubKey)
Call RegDeleteKey(lKey, sName)
End If
Call RegCloseKey(lSubKeyCopy)
End If
sName = Space(255): sClass = Space(255)
lIndex = lIndex + 1
Wend
End Sub

Private Sub DuplicateValues(ByVal lKey As Long, ByVal lKeyCopy As Long)
Dim lIndex As Long, lLen As Long, lType As Long
Dim sName As String, aData() As Byte

'Enumerate all values For the specified key
sName = Space(255)
lIndex = 0
While RegEnumValue(lKey, lIndex, sName, 255, 0&, lType, ByVal 0&, lLen) = 0
ReDim aData(lLen - 1)
Call RegEnumValue(lKey, lIndex, sName, 255, 0&, lType, aData(0), lLen)
sName = Left(sName, InStr(sName, Chr(0)) - 1)
'Copy the value To the New Key structure
Call RegSetValueEx(lKeyCopy, sName, 0&, lType, aData(0), lLen)
sName = Space(255)
lIndex = lIndex + 1
Wend
End Sub

'By Aaron Young

[Nucleus]

To email Aaron Young, go here and enter his name.

http://www.vbforums.com/memberlist.php?s=&action=search

[matt_man22]

I was hoping someone could help me without having to e-mail him.

[matt_man22]

Anyone

[Aaron Young]

Mistake on my part, I'm incrementing the Index count when enumerating the Keys, but I'm also deleting them as I go which causes to enumeration to end prematurely giving some mixed results, this should work fine:

Option Explicit
 
Private Type FILETIME
        dwLowDateTime As Long
        dwHighDateTime As Long
End Type
 
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 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, lpSecurityAttributes As Any, phkResult As Long, lpdwDisposition As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey 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 RegEnumValue Lib "advapi32.dll" Alias "RegEnumValueA" (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 RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey As String) As Long
Private Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (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         ' Note that if you declare the lpData parameter as String, you must pass it By Value.
 
Private Const HKEY_CLASSES_ROOT = &H80000000
Private Const HKEY_CURRENT_CONFIG = &H80000005
Private Const HKEY_CURRENT_USER = &H80000001
Private Const HKEY_DYN_DATA = &H80000006
Private Const HKEY_LOCAL_MACHINE = &H80000002
Private Const HKEY_PERFORMANCE_DATA = &H80000004
Private Const HKEY_USERS = &H80000003
 
 
Private Const KEY_CREATE_LINK = &H20
Private Const KEY_CREATE_SUB_KEY = &H4
Private Const KEY_ENUMERATE_SUB_KEYS = &H8
Private Const KEY_EVENT = &H1
Private Const KEY_NOTIFY = &H10
Private Const KEY_QUERY_VALUE = &H1
Private Const KEY_SET_VALUE = &H2
Private Const SYNCHRONIZE = &H100000
Private Const STANDARD_RIGHTS_ALL = &H1F0000
Private Const 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))
 
Private Const REG_CREATED_NEW_KEY = &H1
 
Private lNewKey As Long
 
Public Sub RenameRegKey(ByVal sRegKey As String, ByVal sNewName As String, Optional ByVal lHive As Long = HKEY_LOCAL_MACHINE)
    Dim lRegKey As Long
    Dim lResult As Long
    
    'Create the new Base Registry Key and get the handle to the existing one
    lNewKey = 0
    If RegOpenKeyEx(lHive, sRegKey, 0&, KEY_ALL_ACCESS, lRegKey) Then Exit Sub
    If RegCreateKeyEx(lHive, Left(sRegKey, InStrRev(sRegKey, "\")) & sNewName, 0, "", 0, KEY_ALL_ACCESS, ByVal 0&, lNewKey, lResult) Or (lResult <> REG_CREATED_NEW_KEY) Then
        Call RegCloseKey(lRegKey)
        Exit Sub
    End If
    
    'Copy all Keys in the Original Key structure to the New Key
    DuplicateKeys lRegKey, lNewKey
    
    'Close Both the Old and New Keys
    Call RegCloseKey(lRegKey)
    Call RegCloseKey(lNewKey)
    
    'Delete the Old Key
    Call RegDeleteKey(lHive, sRegKey)
End Sub
 
Private Sub DuplicateKeys(ByVal lKey As Long, ByVal lKeyCopy As Long)
    Dim lIndex As Long, lSubKey As Long, lSubKeyCopy As Long, lResult As Long
    Dim sName As String, sClass As String
    Dim tFILETIME As FILETIME
    
    'Enumerate all SubKeys of the specified Key
    sName = Space(255): sClass = Space(255)
    lIndex = 0
    While RegEnumKeyEx(lKey, lIndex, sName, 255, 0, sClass, 255, tFILETIME) = 0
        sName = Left(sName, InStr(sName, Chr(0)) - 1)
        If InStr(sClass, Chr(0)) Then
            sClass = Left(sClass, InStr(sClass, Chr(0)) - 1)
        End If
        'Create a copy of this Subkey
        If RegCreateKeyEx(lKeyCopy, sName, 0, sClass, 0, KEY_ALL_ACCESS, ByVal 0&, lSubKeyCopy, 0) = 0 Then
            If RegOpenKeyEx(lKey, sName, 0, KEY_ALL_ACCESS, lSubKey) = 0 Then
                'If there are SubKeys to this Key, Copy them too
                Call DuplicateKeys(lSubKey, lSubKeyCopy)
                'Copy all Values in this Key
                Call DuplicateValues(lSubKey, lSubKeyCopy)
                'Close this Key, then delete the original
                Call RegCloseKey(lSubKey)
                Call RegDeleteKey(lKey, sName)
            End If
            Call RegCloseKey(lSubKeyCopy)
        End If
        sName = Space(255): sClass = Space(255)
    Wend
End Sub
 
Private Sub DuplicateValues(ByVal lKey As Long, ByVal lKeyCopy As Long)
    Dim lIndex As Long, lLen As Long, lType As Long
    Dim sName As String, aData() As Byte
    
    'Enumerate all values for the specified key
    sName = Space(255)
    lIndex = 0
    While RegEnumValue(lKey, lIndex, sName, 255, 0&, lType, ByVal 0&, lLen) = 0
        ReDim aData(lLen - 1)
        Call RegEnumValue(lKey, lIndex, sName, 255, 0&, lType, aData(0), lLen)
        sName = Left(sName, InStr(sName, Chr(0)) - 1)
        'Copy the value to the new Key structure
        Call RegSetValueEx(lKeyCopy, sName, 0&, lType, aData(0), lLen)
        sName = Space(255)
        lIndex = lIndex + 1
    Wend
End Sub

Sorry about that.