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 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 RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" _
(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 RegSetValueEx Lib "advapi32" Alias "RegSetValueExA" _
(ByVal hKey As Long, _
ByVal lpValueName As String, _
ByVal Reserved As Long, _
ByVal dwType As Long, _
ByVal szData As String, _
ByVal cbData As Long) As Long
Public Enum RegTypes
RegNone = 0
RegSZ = 1
RegExpandSz = 2
RegBinary = 3
RegDword = 4
RegDwordLittleEndian = 4
RegDwordBigEndian = 5
RegLink = 6
RegMultiSz = 7
RegResourceList = 8
RegFullResourceDesc = 9
End Enum
Private Const HKEY_CLASSES_ROOT As Long = &H80000000
Private Const HKEY_CURRENT_USER As Long = &H80000001
Private Const HKEY_LOCAL_MACHINE As Long = &H80000002
Private Const HKEY_USERS As Long = &H80000003
Private Const HKEY_PERFORMANCE_DATA As Long = &H80000004
Private Const HKEY_CURRENT_CONFIG As Long = &H80000005
Private Const HKEY_DYN_DATA As Long = &H80000006
Private Const KEY_ALL_ACCESS As Long = &HF003F
Private Const KEY_WRITE As Long = &H20006
Private Const KEY_READ As Long = &H20019
Private Const KEY_QUERY_VALUE As Long = &H1
Private Const KEY_ENUMERATE_SUB_KEYS As Long = &H8
Private Const KEY_CREATE_SUB_KEY As Long = &H4
'Registry Redirector Subsystem
'http://msdn.microsoft.com/en-us/library/windows/desktop/aa384129(v=vs.85).aspx
Private Const KEY_WOW64_64KEY As Long = &H100 'Access a 64-bit key from either a 32-bit or 64-bit application.
Private Const KEY_WOW64_32KEY As Long = &H200 'Access a 32-bit key from either a 32-bit or 64-bit application.
'Can be used by:
' - RegCreateKeyEx
' - RegDeleteKeyEx
' - RegOpenKeyEx
Private Sub Command1_Click()
'Записываем новый ...
Dim badRoot$, Ret_1&, Ret_2&
badRoot = "HKEY_LOCAL_MACHINE\SOFTWARE\Classes\CLSID\" & badCLSID & "\TypeLib"
'Записываем ключ в 32-битных ветвях
Ret_1 = WriteKey(badRoot, "", Key2099, False)
'Записываем ключ в 64-битных ветвях
Ret_2 = WriteKey(badRoot, "", Key2099, True)
MsgBox "32-битная ветка - " & IIf(Ret_1, "Успех.", "Ошибка.") & vbCrLf & _
"64-битная ветка - " & IIf(Ret_2, "Успех.", "Ошибка.")
end sub
'Самоэлевация прав программы
Private Sub Form_Initialize()
'Exit Sub 'Временно, пока не скомпилирую проект
With CreateObject("WScript.Shell")
On Error Resume Next
.RegWrite "HKLM\isElevated", "", "REG_SZ"
If Err <> 0 Then
CreateObject("Shell.Application").ShellExecute App.Path & "\" & App.EXEName & ".exe", "1", "", "runas", 1
End
Else
.RegDelete "HKLM\isElevated"
End If
End With
End Sub
Private Function GetHKey(ByVal HKeyName As String) As Long 'Получить хендл улья
Dim pos As Long
pos = InStr(HKeyName, "\")
If pos <> 0 Then HKeyName = Left$(HKeyName, pos - 1)
Select Case UCase(HKeyName)
Case "HKEY_CLASSES_ROOT", "HKCR"
GetHKey = HKEY_CLASSES_ROOT
Case "HKEY_CURRENT_USER", "HKCU"
GetHKey = HKEY_CURRENT_USER
Case "HKEY_LOCAL_MACHINE", "HKLM"
GetHKey = HKEY_LOCAL_MACHINE
Case "HKEY_USERS", "HKU", "HKUS"
GetHKey = HKEY_USERS
Case "HKEY_PERFORMANCE_DATA"
GetHKey = HKEY_PERFORMANCE_DATA
Case "HKEY_CURRENT_CONFIG", "HKCC"
GetHKey = HKEY_CURRENT_CONFIG
Case "HKEY_DYN_DATA"
GetHKey = HKEY_DYN_DATA
End Select
End Function
Private Function WriteKey(rPath$, ParamName, ParamValue, Optional is64Node As Boolean = False)
'Функция записывает значение в реестр.
'Возвращает результат выполнения API-функции RegSetValueEx
'Умеет использовать Registry Redirector SybSystem (в 64 или 32-битную ветку записывать данные)
Dim Ret_1&, Ret_2&, sSubKey$, Hive$, hSubKey&, regAccess&
Hive = Split(rPath, "\")(0)
sSubKey = IIf(Len(Hive) = Len(rPath), "", Replace(rPath, Hive & "\", ""))
If is64Node Then
regAccess = KEY_QUERY_VALUE Or KEY_WRITE Or KEY_WOW64_64KEY
Else
regAccess = KEY_QUERY_VALUE Or KEY_WRITE Or KEY_WOW64_32KEY
End If
Ret_1 = RegOpenKeyEx(GetHKey(Hive), sSubKey, 0&, regAccess, hSubKey)
Ret_2 = RegSetValueEx(hSubKey, ParamName, 0, RegTypes.RegSZ, ParamValue, Len(ParamValue) + 1)
RegCloseKey hSubKey
WriteKey = Ret_2
End Function
