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
