Dim nResult As Long 'Rückgabe der Funktionen
On Error GoTo ErrHandler
nResult = OpenProcessToken(GetCurrentProcess, TOKEN_ADJUST_PRIVLEGES Or TOKEN_QUERY, m_hToken)
If nResult = 0 Then
Err.Raise SITUATION_BASE + 1, , "Opening process token failed."
End If
nResult = LookupPrivilegeValue(vbNullString, SE_RESTORE_NAME, m_RestoreLuid)
If nResult = 0 Then
Err.Raise SITUATION_BASE + 2, , "Looking up restore privilege failed."
End If
nResult = LookupPrivilegeValue(vbNullString, SE_BACKUP_NAME, m_BackupLuid)
If nResult = 0 Then
Err.Raise SITUATION_BASE + 3, , "Looking up backup privilege failed."
End If
m_TP.PrivilegeCount = 2
m_TP.Privileges(0).pLuid = m_RestoreLuid
m_TP.Privileges(0).Attributes = SE_PRIVILEGE_ENABLED
m_TP.Privileges(1).pLuid = m_BackupLuid
m_TP.Privileges(1).Attributes = SE_PRIVILEGE_ENABLED
nResult = AdjustTokenPrivileges(m_hToken, vbFalse, m_TP, Len(m_TP), 0&, 0&)
If nResult = 0 Then
Err.Raise SITUATION_BASE + 4, , "Adjusting new privileges failed."
End If
Exit Sub
ErrHandler:
If InStr(1, Err.Source, ":") = 0 Then Err.Source = "CCSysRegistry:setBackupAndRestorePriviliges"
Err.Raise Err.Number
End Sub
Private Sub resetBackupAndRestorePriviliges()
Dim nResult As Long 'Rückgabe der Funktionen
On Error GoTo ErrHandler
nResult = AdjustTokenPrivileges(m_hToken, vbTrue, m_TP, Len(m_TP), 0&, 0&)
If nResult = 0 Then
Err.Raise SITUATION_BASE + 5, , "Resetting new privileges failed."
End If
Exit Sub
ErrHandler:
If InStr(1, Err.Source, ":") = 0 Then Err.Source = "CCSysRegistry:resetBackupAndRestorePriviliges"
Err.Raise Err.Number
End Sub
Private Function getErrorMessage(ByVal nMessageID As Long) As String
Dim sError As String * 256 'Fehlertext
Dim nResult As Long 'Rückgabe
Dim nSize As Long 'L?nge von sError
On Error GoTo ErrHandler
If nMessageID = 0 Then
Err.Raise SITUATION_BASE + 7, , "'0' is a invalid message ID."
End If
nSize = 256
nResult = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, 0&, nMessageID, 0&, sError, nSize, 0&)
If nResult = 0 Then
Err.Raise SITUATION_BASE + 8, , "Message '" & nMessageID & "' could not be found in System Message Table."
Else
getErrorMessage = Left(sError, nResult - 1)
End If
Exit Function
ErrHandler:
If InStr(1, Err.Source, ":") = 0 Then Err.Source = "CCSysRegistry:getErrorMessage"
Err.Raise Err.Number
End Function
______________________Module1___________________________________
Private Const ERROR_SUCCESS = 0
Private Const ERROR_FILE_NOT_FOUND = 2
Private Const ERROR_ACCESS_DENIED = 5
Private Const FORMAT_MESSAGE_FROM_SYSTEM = &H1000
Private Type LUID
LowPart As Long
HighPart As Long
End Type
Private Type LUID_AND_ATTRIBUTES
pLuid As LUID
Attributes As Long
End Type
Private Type TOKEN_PRIVILEGES
PrivilegeCount As Long
Privileges(1) As LUID_AND_ATTRIBUTES
End Type
Private Const HKEY_CLASSES_ROOT = &H80000000
Private Const HKEY_CURRENT_USER = &H80000001
Private Const HKEY_LOCAL_MACHINE = &H80000002
Private Const HKEY_USERS = &H80000003
Private Const HKEY_CURRENT_CONFIG = &H80000005
Private Const HKEY_DYN_DATA = &H80000006
Public Enum enumHKEY
enumHKEY_CLASSES_ROOT = HKEY_CLASSES_ROOT
enumHKEY_CURRENT_USER = HKEY_CURRENT_USER
enumHKEY_LOCAL_MACHINE = HKEY_LOCAL_MACHINE
enumHKEY_USERS = HKEY_USERS
enumHKEY_CURRENT_CONFIG = HKEY_CURRENT_CONFIG
enumHKEY_DYN_DATA = HKEY_DYN_DATA
End Enum
Private Const STANDARD_RIGHTS_ALL = &H1F0000
Private Const STANDARD_RIGHTS_READ = &H20000
Private Const KEY_QUERY_VALUE = 1
Private Const KEY_ENUMERATE_SUB_KEYS = 8
Private Const KEY_NOTIFY = &H10&
Private Const SYNCHRONIZE = &H100000
Private Const KEY_CREATE_LINK = &H20
Private Const KEY_CREATE_SUB_KEY = 4
Private Const KEY_SET_VALUE = 2
Private Const KEY_READ = (STANDARD_RIGHTS_READ Or KEY_QUERY_VALUE)
Private Const KEY_WRITE = ((STANDARD_RIGHTS_ALL Or KEY_SET_VALUE) And (Not SYNCHRONIZE))
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_FORCE_RESTORE = &H8
Private Const TOKEN_ADJUST_PRIVLEGES = &H20
Private Const TOKEN_QUERY = &H8
Private Const SE_PRIVILEGE_ENABLED = &H2
Private Const SE_RESTORE_NAME = "SeRestorePrivilege"
Private Const SE_BACKUP_NAME = "SeBackupPrivilege"
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
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, ByRef 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, ByVal lpSecurityAttributes As Long, phkResult As Long, ByVal lpdwDisposition As Long) As Long
Private Declare Function FormatMessage Lib "kernel32" Alias "FormatMessageA" (ByVal dwFlags As Long, ByVal lpSource As Long, ByVal dwMessageId As Long, ByVal dwLanguageId As Long, ByVal lpBuffer As String, nSize As Long, Arguments As Long) As Long
Private Declare Function RegRestoreKey Lib "advapi32.dll" Alias "RegRestoreKeyA" (ByVal hKey As Long, ByVal lpFile As String, ByVal dwFlags As Long) As Long
Private Declare Function RegSaveKey Lib "advapi32.dll" Alias "RegSaveKeyA" (ByVal hKey As Long, ByVal lpFile As String, ByVal lpSecurityAttributes As Long) As Long
Private Declare Function GetCurrentProcess Lib "kernel32" () As Long
Private Declare Function OpenProcessToken Lib "advapi32.dll" (ByVal ProcessHandle As Long, ByVal DesiredAccess As Long, TokenHandle As Long) As Long
Private Declare Function LookupPrivilegeValue Lib "advapi32.dll" Alias "LookupPrivilegeValueA" (ByVal lpSystemName As String, ByVal lpName As String, lpLuid As LUID) As Long
Private Declare Function AdjustTokenPrivileges Lib "advapi32.dll" (ByVal TokenHandle As Long, ByVal DisableAllPrivileges As Long, NewState As TOKEN_PRIVILEGES, ByVal BufferLength As Long, ByVal PreviousState As Long, ByVal ReturnLength As Long) As Long
Private m_hToken As Long 'Prozess-Token
Private m_TP As TOKEN_PRIVILEGES 'Prozessprivilegien-Struktur
Private m_RestoreLuid As LUID 'Restore-Privileg
Private m_BackupLuid As LUID 'Backup-Privileg
Private Const SITUATION_BASE As Long = 13800 'klassenspezifische Fehlerbasis
Public Sub renameKey(ByVal nHKEY As enumHKEY, ByVal sKeySource As String, ByVal sKeyDestination As String)
Dim hKeySource As Long 'Key-Handle der Quellstruktur
Dim hKeyDestination As Long 'Key-Handle der Zielstruktur
Dim nResult As Long 'Rückgabe der Funktionen
Dim sFile As String 'Name der Reg-Datei
Dim nNull As Long
On Error GoTo ErrHandler
setBackupAndRestorePriviliges
sFile = "C:\RegTemp.txt"
nResult = RegOpenKeyEx(nHKEY, sKeySource, 0&, KEY_ALL_ACCESS, hKeySource)
If nResult = ERROR_SUCCESS Then
If Len(Dir(sFile)) > 0 Then
Kill sFile
End If
nResult = RegSaveKey(hKeySource, sFile, 0&)
If nResult = ERROR_SUCCESS Then
nResult = RegOpenKeyEx(nHKEY, sKeyDestination, 0&, KEY_ALL_ACCESS, hKeyDestination)
If nResult = ERROR_FILE_NOT_FOUND Then
nResult = RegCreateKeyEx(nHKEY, sKeyDestination, 0&, vbNullString, 0&, KEY_ALL_ACCESS, 0&, hKeyDestination, 0&)
If nResult <> ERROR_SUCCESS Then
Err.Raise nResult, , getErrorMessage(nResult)
End If
End If
nResult = RegRestoreKey(hKeyDestination, sFile, REG_FORCE_RESTORE)
If nResult <> ERROR_SUCCESS Then
Err.Raise nResult, , getErrorMessage(nResult)
End If
RegCloseKey hKeyDestination
Else
Err.Raise nResult, , getErrorMessage(nResult)
End If
RegCloseKey hKeySource
If Len(Dir(sFile)) > 0 Then
Kill sFile
End If
End If
resetBackupAndRestorePriviliges
Exit Sub
ErrHandler:
RegCloseKey hKeySource
RegCloseKey hKeyDestination
If InStr(1, Err.Source, ":") = 0 Then Err.Source = "CCSysRegistry:renameKey"
Err.Raise Err.Number
End Sub
Private Declare Function RegCloseKey Lib "advapi32" (ByVal hKey As Long) As Long
Private Declare Function RegCreateKeyEx Lib "advapi32" 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, ByRef lpSecurityAttributes As SECURITY_ATTRIBUTES, ByRef phkResult As Long, ByRef lpdwDisposition As Long) As Long
Private Declare Function RegOpenKeyEx Lib "advapi32" Alias "RegOpenKeyExA" (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 RegQueryValueEx Lib "advapi32" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, ByRef lpType As Long, ByVal lpData As String, ByRef lpcbData As Long) As Long
Private Declare Function RegSetValueEx Lib "advapi32" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, ByVal lpData As String, ByVal cbData As Long) As Long