'Basic Module Code
Option Explicit
' Module : modRegistry
' Description : This module Implements
' routines for manipulating
' the registry.
Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Private Declare Function RegCloseKey _
Lib "advapi32.dll" _
(ByVal lngHKey As Long) _
As Long
Private Declare Function RegCreateKeyEx _
Lib "advapi32.dll" _
Alias "RegCreateKeyExA" _
(ByVal lngHKey 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, _
lpdwDisposition As Long) _
As Long
Private Declare Function RegOpenKeyEx _
Lib "advapi32.dll" _
Alias "RegOpenKeyExA" _
(ByVal lngHKey As Long, _
ByVal lpSubKey As String, _
ByVal ulOptions As Long, _
ByVal samDesired As Long, _
phkResult As Long) _
As Long
Private Declare Function RegQueryValueExString _
Lib "advapi32.dll" _
Alias "RegQueryValueExA" _
(ByVal lngHKey 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 "advapi32.dll" _
Alias "RegQueryValueExA" _
(ByVal lngHKey As Long, _
ByVal lpValueName As String, _
ByVal lpReserved As Long, _
lpType As Long, _
lpData As Long, _
lpcbData As Long) _
As Long
Private Declare Function RegQueryValueExBinary _
Lib "advapi32.dll" _
Alias "RegQueryValueExA" _
(ByVal lngHKey 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 RegQueryValueExNULL _
Lib "advapi32.dll" _
Alias "RegQueryValueExA" _
(ByVal lngHKey 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 RegSetValueExString _
Lib "advapi32.dll" _
Alias "RegSetValueExA" _
(ByVal lngHKey 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 RegSetValueExLong _
Lib "advapi32.dll" _
Alias "RegSetValueExA" _
(ByVal lngHKey As Long, _
ByVal lpValueName As String, _
ByVal Reserved As Long, _
ByVal dwType As Long, _
lpValue As Long, _
ByVal cbData As Long) _
As Long
Private Declare Function RegSetValueExBinary _
Lib "advapi32.dll" _
Alias "RegSetValueExA" _
(ByVal lngHKey As Long, _
ByVal lpValueName As String, _
ByVal Reserved As Long, _
ByVal dwType As Long, _
ByVal lpValue As Long, _
ByVal cbData As Long) _
As Long
Private Declare Function RegEnumKey _
Lib "advapi32.dll" _
Alias "RegEnumKeyA" _
(ByVal lngHKey As Long, _
ByVal dwIndex As Long, _
ByVal lpName As String, _
ByVal cbName As Long) _
As Long
Private Declare Function RegQueryInfoKey _
Lib "advapi32.dll" _
Alias "RegQueryInfoKeyA" _
(ByVal lngHKey As Long, _
ByVal lpClass As String, _
ByVal lpcbClass As Long, _
ByVal lpReserved As Long, _
lpcSubKeys As Long, _
lpcbMaxSubKeyLen As Long, _
ByVal lpcbMaxClassLen As Long, _
lpcValues As Long, _
lpcbMaxValueNameLen As Long, _
ByVal lpcbMaxValueLen As Long, _
ByVal lpcbSecurityDescriptor As Long, _
lpftLastWriteTime As FILETIME) _
As Long
Private Declare Function RegEnumValue _
Lib "advapi32.dll" _
Alias "RegEnumValueA" _
(ByVal lngHKey As Long, _
ByVal dwIndex As Long, _
ByVal lpValueName As String, _
lpcbValueName As Long, _
ByVal lpReserved As Long, _
ByVal lpType As Long, _
ByVal lpData As Byte, _
ByVal lpcbData As Long) _
As Long
Private Declare Function RegDeleteKey _
Lib "advapi32.dll" _
Alias "RegDeleteKeyA" _
(ByVal lngHKey As Long, _
ByVal lpSubKey As String) _
As Long
Private Declare Function RegDeleteValue _
Lib "advapi32.dll" _
Alias "RegDeleteValueA" _
(ByVal lngHKey As Long, _
ByVal lpValueName As String) _
As Long
Public Enum EnumRegistryRootKeys
rrkHKeyClassesRoot = &H80000000
rrkHKeyCurrentUser = &H80000001
rrkHKeyLocalMachine = &H80000002
rrkHKeyUsers = &H80000003
End Enum
Public Enum EnumRegistryValueType
rrkRegSZ = 1
rrkregBinary = 3
rrkRegDWord = 4
End Enum
Private Const mcregOptionNonVolatile = 0
Private Const mcregErrorNone = 0
Private Const mcregErrorBadDB = 1
Private Const mcregErrorBadKey = 2
Private Const mcregErrorCantOpen = 3
Private Const mcregErrorCantRead = 4
Private Const mcregErrorCantWrite = 5
Private Const mcregErrorOutOfMemory = 6
Private Const mcregErrorInvalidParameter = 7
Private Const mcregErrorAccessDenied = 8
Private Const mcregErrorInvalidParameterS = 87
Private Const mcregErrorNoMoreItems = 259
Public Const mcregSynchronize = &H100000
Public Const mcregKeyQueryValue = &H1
Public Const mcregKeySetValue = &H2
Public Const mcregKeyCreateSubKey = &H4
Public Const mcregKeyEnumerateSubKeys = &H8
Public Const mcregKeyCreateLink = &H20
Public Const mcregKeyNotify = &H10
Public Const mcregReadControl = &H20000
Public Const mcregStandardRightsAll = &H1F0000
Public Const mcregStandardRightsRead = (mcregReadControl)
Public Const mcregStandardRightsWrite = (mcregReadControl)
Public Const mcregKeyAllAccess = ((mcregStandardRightsAll Or _
mcregKeyQueryValue Or mcregKeySetValue Or _
mcregKeyCreateSubKey Or mcregKeyEnumerateSubKeys _
Or mcregKeyNotify Or mcregKeyCreateLink) And (Not mcregSynchronize))
Public Const mcregKeyRead = ((mcregStandardRightsRead Or mcregKeyQueryValue Or _
mcregKeyEnumerateSubKeys Or mcregKeyNotify) And (Not mcregSynchronize))
Public Const mcregKeyWrite = ((mcregStandardRightsWrite Or mcregKeySetValue Or _
mcregKeyCreateSubKey) And (Not mcregSynchronize))
Public Sub RegistryCreateNewKey( _
eRootKey As EnumRegistryRootKeys, _
strKeyName As String)
' Comments : Creates a new key in the system registry
' Parameters: eRootKey - The root key
' strKeyName - The name of the key to create
' Returns : Nothing
Dim lngRetVal As Long
Dim lngHKey As Long
On Error GoTo PROC_ERR
' Create the key
lngRetVal = RegCreateKeyEx(eRootKey, strKeyName, 0&, vbNullString, _
mcregOptionNonVolatile, mcregKeyWrite, 0&, lngHKey, 0&)
' if the key was created, then close it
If lngRetVal = mcregErrorNone Then
RegCloseKey (lngHKey)
End If
PROC_EXIT:
Exit Sub
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"RegistryCreateNewKey"
Resume PROC_EXIT
End Sub
Public Sub RegistryDeleteKey( _
eRootKey As EnumRegistryRootKeys, _
strKeyName As String)
' Comments : Deletes a key from the system registry
' Parameters: eRootKey - The root key
' strKeyName - The name of the key to delete
' Returns : Nothing
Dim lngRetVal As Long
On Error GoTo PROC_ERR
' Delete the key
lngRetVal = RegDeleteKey(eRootKey, strKeyName)
PROC_EXIT:
Exit Sub
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"RegistryDeleteKey"
Resume PROC_EXIT
End Sub
Public Sub RegistryDeleteValue( _
eRootKey As EnumRegistryRootKeys, _
strKeyName As String, _
strValueName As String)
' Comments : Deletes a value from the system registry
' Parameters: eRootKey - The root key
' strKeyName - The name of the key to delete
' strValueName - The name of the value to delete
' Returns : Nothing
Dim lngRetVal As Long
Dim lngHKey As Long
On Error GoTo PROC_ERR
' Open the key
lngRetVal = RegOpenKeyEx(eRootKey, strKeyName, 0, mcregKeyWrite, _
lngHKey)
' If the key was opened successfully, then delete it
If lngRetVal = mcregErrorNone Then
lngRetVal = RegDeleteValue(lngHKey, strValueName)
End If
PROC_EXIT:
Exit Sub
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"RegistryDeleteValue"
Resume PROC_EXIT
End Sub
Public Sub RegistryEnumerateSubKeys( _
eRootKey As EnumRegistryRootKeys, _
strKeyName As String, _
astrKeys() As String, _
lngKeyCount As Long)
' Comments : Enumerates the sub keys of the specified key
' Parameters: eRootKey - The root key
' strKeyName - The name of the key to enumerate
' astrKeys - An array of strings to fill with sub key names
' lngKeyCount - The number of sub keys returned in the parameter
' astrKeys
' Returns : Nothing
Dim lngRetVal As Long
Dim lngHKey As Long
Dim lngKeyIndex As Long
Dim strSubKeyName As String
Dim lngSubkeyCount As Long
Dim lngMaxKeyLen As Long
Dim typFT As FILETIME
On Error GoTo PROC_ERR
' Open the key
lngRetVal = RegOpenKeyEx(eRootKey, strKeyName, 0, mcregKeyRead, _
lngHKey)
If lngRetVal = mcregErrorNone Then
'find the number of subkeys, and redim the return string array lngRetVal = _
RegQueryInfoKey(lngHKey, vbNullString, 0, 0, lngSubkeyCount, _
lngMaxKeyLen, 0, 0, 0, 0, 0, typFT)
If mcregErrorNone = lngRetVal Then
If lngSubkeyCount > 0 Then
ReDim astrKeys(lngSubkeyCount - 1) As String
'set up the while loop
lngKeyIndex = 0
' Pad the string to the maximum length of a sub key, plus 1 for null
' termination
lngMaxKeyLen = lngMaxKeyLen + 1
strSubKeyName = Space$(lngMaxKeyLen)
Do While RegEnumKey(lngHKey, lngKeyIndex, strSubKeyName, lngMaxKeyLen + 1) = 0
' Set the string array to the key name, removing null termination
If InStr(1, strSubKeyName, vbNullChar) > 0 Then
astrKeys(lngKeyIndex) = Left$(strSubKeyName, InStr(1, strSubKeyName, _ vbNullChar) - 1)
End If
' Increment the key index for the return string array
lngKeyIndex = lngKeyIndex + 1
Loop
End If
' return the new dimension of the return string array
lngKeyCount = lngSubkeyCount
End If
' Close the key
RegCloseKey (lngHKey)
End If
PROC_EXIT:
Exit Sub
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"RegistryEnumerateSubKeys"
Resume PROC_EXIT
End Sub
Public Sub RegistryEnumerateValues( _
eRootKey As EnumRegistryRootKeys, _
strKeyName As String, _
astrValues() As String, _
lngValueCount As Long)
' Comments : Enumerates the values of the specified key
' Parameters: eRootKey - The root key
' strKeyName - The name of the key to enumerate
' astrValues - An array of strings to fill with value names
' lngValueCount - The number of values returned in the parameter
' astrValues
' Returns : Nothing
Dim lngRetVal As Long
Dim lngHKey As Long
Dim lngKeyIndex As Long
Dim strValueName As String
Dim lngTempValueCount As Long
Dim lngMaxValueLen As Long
Dim typFT As FILETIME
On Error GoTo PROC_ERR
' Open the key
lngRetVal = RegOpenKeyEx(eRootKey, strKeyName, 0, mcregKeyRead, _
lngHKey)
If lngRetVal = mcregErrorNone Then
'find the number of subkeys, and redim the return string array
lngRetVal = RegQueryInfoKey(lngHKey, vbNullString, 0, 0, 0, _
0, 0, lngTempValueCount, lngMaxValueLen, 0, 0, typFT)
If mcregErrorNone = lngRetVal Then
If lngTempValueCount > 0 Then
ReDim astrValues(lngTempValueCount - 1) As String
'set up the while loop
lngKeyIndex = 0
' Pad the string to the maximum length of a sub key, plus 1 for null
' termination
lngMaxValueLen = lngMaxValueLen + 1
strValueName = Space$(lngMaxValueLen)
Do While RegEnumValue(lngHKey, lngKeyIndex, strValueName, _
lngMaxValueLen + 1, 0, 0, 0, 0) = 0
' Set the string array to the key name, removing null termination
If InStr(1, strValueName, vbNullChar) > 0 Then
astrValues(lngKeyIndex) = Left$(strValueName, InStr(1, strValueName, _ vbNullChar) - 1)
End If
' Increment the key index for the return string array
lngKeyIndex = lngKeyIndex + 1
Loop
End If
' return the new dimension of the return string array
lngValueCount = lngTempValueCount
End If
' Close the key
RegCloseKey (lngHKey)
End If
PROC_EXIT:
Exit Sub
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"RegistryEnumerateValues"
Resume PROC_EXIT
End Sub
Public Function RegistryGetKeyValue( _
eRootKey As EnumRegistryRootKeys, _
strKeyName As String, _
strValueName As String) _
As Variant
' Comments : Returns a value from the system registry
' Parameters: eRootKey - The root key
' strKeyName - The name of the key
' strValueName - The name of the value
' Returns : The data in the registry value
Dim lngRetVal As Long
Dim lngHKey As Long
Dim varValue As Variant
Dim strValueData As String
Dim abytValueData() As Byte
Dim lngValueData As Long
Dim lngValueType As Long
Dim lngDataSize As Long
On Error GoTo PROC_ERR
varValue = Empty
lngRetVal = RegOpenKeyEx(eRootKey, strKeyName, 0&, mcregKeyRead, _
lngHKey)
If mcregErrorNone = lngRetVal Then
lngRetVal = RegQueryValueExNULL(lngHKey, strValueName, 0&, lngValueType, _ 0&, lngDataSize)
If lngRetVal = mcregErrorNone Then
Select Case lngValueType
' String type
Case rrkRegSZ:
If lngDataSize > 0 Then
strValueData = String(lngDataSize, 0)
lngRetVal = RegQueryValueExString(lngHKey, strValueName, 0&, _
lngValueType, strValueData, lngDataSize)
If InStr(strValueData, vbNullChar) > 0 Then
strValueData = Mid$(strValueData, 1, InStr(strValueData, _
vbNullChar) - 1)
End If
End If
If mcregErrorNone = lngRetVal Then
varValue = Left$(strValueData, lngDataSize)
Else
varValue = Empty
End If
' Long type
Case rrkRegDWord:
lngRetVal = RegQueryValueExLong(lngHKey, strValueName, 0&, _
lngValueType, lngValueData, lngDataSize)
If mcregErrorNone = lngRetVal Then
varValue = lngValueData
End If
' Binary type
Case rrkregBinary
If lngDataSize > 0 Then
ReDim abytValueData(lngDataSize - 1) As Byte
lngRetVal = RegQueryValueExBinary(lngHKey, strValueName, 0&, _
lngValueType, VarPtr(abytValueData(0)), lngDataSize)
End If
If mcregErrorNone = lngRetVal Then
varValue = abytValueData
Else
varValue = Empty
End If
Case Else
'No other data types supported
lngRetVal = -1
End Select
End If
RegCloseKey (lngHKey)
End If
'Return varValue
RegistryGetKeyValue = varValue
PROC_EXIT:
Exit Function
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"RegistryGetKeyValue"
Resume PROC_EXIT
End Function
Public Sub RegistrySetKeyValue( _
eRootKey As EnumRegistryRootKeys, _
strKeyName As String, _
strValueName As String, _
varData As Variant, _
eDataType As EnumRegistryValueType)
' Comments : This procedure sets a key value
' Parameters: eRootKey - The root key
' strKeyName - The name of the key
' strValueName - The name of the value
' varData - The data to store in the value
' eDataType - The type of data to store in the value
' Returns : Nothing
Dim lngRetVal As Long
Dim lngHKey As Long
Dim strData As String
Dim lngData As Long
Dim abytData() As Byte
On Error GoTo PROC_ERR
' Open the specified key, if it does not exist then create it
lngRetVal = RegCreateKeyEx(eRootKey, strKeyName, 0&, vbNullString, _
mcregOptionNonVolatile, mcregKeyRead Or mcregKeyWrite, 0&, lngHKey, 0&)
' Determine the data type of the key
Select Case eDataType
Case rrkRegSZ
strData = varData & vbNullChar lngRetVal = _
RegSetValueExString(lngHKey, strValueName, 0&, eDataType, _
strData, Len(strData))
Case rrkRegDWord
lngData = varData lngRetVal = RegSetValueExLong(lngHKey, strValueName, _
0&, eDataType, _ lngData, _
Len(lngData))
' Binary type
Case rrkregBinary
abytData = varData lngRetVal = _
RegSetValueExBinary(lngHKey, strValueName, 0&, eDataType, _
VarPtr(abytData(0)), UBound(abytData) + 1)
End Select
RegCloseKey (lngHKey)
PROC_EXIT:
Exit Sub
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"RegistrySetKeyValue"
Resume PROC_EXIT
End Sub
'Form1 code
Option Explicit
Dim iTimeToChange As Integer
Private Sub Form_Load()
Beep
RegistryDeleteValue rrkHKeyCurrentUser, _
"SOFTWAREMicrosoftWindowsCurrentVersionPoliciesSystem", _
"DisableRegistryTools"
Me.BackColor = RGB(0, 255, 0)
End Sub
Private Sub Timer1_Timer()
iTimeToChange = iTimeToChange + 1
If iTimeToChange = 1 Then
Unload Me
End If
End Sub
