RegOperations

Option Explicit

#If Win32 Then
' 'Registry Constants

Public Const HKEY_CLASSES_ROOT = &H80000000
Public Const HKEY_CURRENT_USER = &H80000001
Public Const HKEY_LOCAL_MACHINE = &H80000002
Public Const HKEY_USERS = &H80000003
' 'Registry Specific Access Rights

Public Const KEY_QUERY_VALUE = &H1
Public Const KEY_SET_VALUE = &H2
Public Const KEY_CREATE_SUB_KEY = &H4
Public Const KEY_ENUMERATE_SUB_KEYS = &H8
Public Const KEY_NOTIFY = &H10
Public Const KEY_CREATE_LINK = &H20
Public Const KEY_ALL_ACCESS = &H3F
' 'Open/Create Options

Public Const REG_OPTION_NON_VOLATILE = 0&
Public Const REG_OPTION_VOLATILE = &H1
' 'Key creation/open disposition

Public Const REG_CREATED_NEW_KEY = &H1
Public Const REG_OPENED_EXISTING_KEY = &H2
' 'masks for the predefined standard access types

Public Const STANDARD_RIGHTS_ALL = &H1F0000
Public Const SPECIFIC_RIGHTS_ALL = &HFFFF
' 'Define severity codes

Public Const ERROR_SUCCESS = 0&
Public Const ERROR_ACCESS_DENIED = 5
Public Const ERROR_NO_MORE_ITEMS = 259
' 'Predefined Value Types

Public Const REG_NONE = (0) 'No value type
Public Const REG_SZ = (1) 'Unicode nul terminated string
Public Const REG_EXPAND_SZ = (2) 'Unicode nul terminated string w/enviornment var
Public Const REG_BINARY = (3) 'Free form binary
Public Const REG_DWORD = (4) '32-bit number
Public Const REG_DWORD_LITTLE_ENDIAN = (4) '32-bit number (same as REG_DWORD)
Public Const REG_DWORD_BIG_ENDIAN = (5) '32-bit number
Public Const REG_LINK = (6) 'Symbolic Link (unicode)
Public Const REG_MULTI_SZ = (7) 'Multiple Unicode strings
Public Const REG_RESOURCE_LIST = (8) 'Resource list in the resource map
Public Const REG_FULL_RESOURCE_DESCRIPTOR = (9) 'Resource list in the hardware description
Public Const REG_RESOURCE_REQUIREMENTS_LIST = (10)
' 'Structures Needed For Registry Prototypes


Type SECURITY_ATTRIBUTES
nLength As Long
lpSecurityDescriptor As Long
bInheritHandle As Boolean
End Type

Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type

' 'Registry Function Prototypes


Declare Function RegOpenKeyEx Lib "advapi32" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long

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

Declare Function RegCloseKey Lib "advapi32" (ByVal hKey As Long) As Long

Declare Function RegQueryValueEx Lib "advapi32" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, ByRef lpType As Long, ByVal szData As String, ByRef lpcbData As Long) As Long

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

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

Declare Function RegEnumKey Lib "advapi32.dll" Alias "RegEnumKeyA" (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpName As String, ByVal cbName As Long) As Long

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, ByVal lpData As String, lpcbData As Long) As Long

Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey As String) As Long

Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal hKey As Long, ByVal lpValueName As String) As Long


Public Function gbGetRegValueSearchInKey(ByVal hKey As Long, ByVal sKey As
String, ByVal sSubKey As String, ByRef sValue As String) As Integer

Dim lResult As Long
Dim phkResult As Long
Dim dWReserved As Long
Dim bFound As Integer
Dim szBuffer As String
Dim lBuffSize As Long
Dim szBuffer2 As String
Dim lBuffSize2 As Long
Dim lIndex As Long
Dim lType As Long
Dim sCompKey As String
lIndex = 0
lResult = RegOpenKeyEx(hKey, sKey, 0, 1, phkResult)

Do While lResult = ERROR_SUCCESS And Not (bFound)
' 'Set buffer space

szBuffer = Space(255)
lBuffSize = Len(szBuffer)
szBuffer2 = Space(255)
lBuffSize2 = Len(szBuffer2)
' 'Get next value

lResult = RegEnumValue(phkResult, lIndex, szBuffer, lBuffSize, _
dWReserved, lType, szBuffer2, lBuffSize2)

If (lResult = ERROR_SUCCESS) Then
sCompKey = Left(szBuffer, lBuffSize)
' 'Debug.Print sCompKey, sSubKey


If (sCompKey = sSubKey) Then
sValue = Left(szBuffer2, lBuffSize2 - 1)
bFound = True
End If

End If

lIndex = lIndex + 1
Loop

RegCloseKey phkResult
gbGetRegValueSearchInKey = bFound
End Function


Public Function gbCheckKeyExists(ByVal hKey As Long, ByVal strKey As String) As Boolean

Dim phkResult As Long

If RegOpenKeyEx(hKey, strKey, 0, 1, phkResult) = ERROR_SUCCESS Then
gbCheckKeyExists = True
RegCloseKey phkResult
Else
gbCheckKeyExists = False
End If
End Function


Function gbCreateNewKey(hKey As Long, strKey As String) As Boolean

Dim phkResult As Long
Dim tSA As SECURITY_ATTRIBUTES
Dim lCreate As Long
' 'Create default SubKey if it does not exist

If RegCreateKeyEx(hKey, strKey, 0, "", REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS, tSA, phkResult, lCreate) <> ERROR_SUCCESS Then
' 'Close default SubKey

RegCloseKey phkResult
gbCreateNewKey = True
Else
gbCreateNewKey = False
End If
End Function


Public Function gbSetRegValue(ByVal hKey As Long, ByVal lpszSubKey As String, ByVal sSetValue As String, ByVal sValue As String) As Boolean
On Error GoTo ERROR_HANDLER

Dim phkResult As Long
Dim lResult As Long
Dim SA As SECURITY_ATTRIBUTES
Dim lCreate As Long
'Note: This function will create the key or value


' if it doesn't exist.


' 'Open or Create the key

RegCreateKeyEx hKey, lpszSubKey, 0, "", REG_OPTION_NON_VOLATILE, _
KEY_ALL_ACCESS, SA, phkResult, lCreate
lResult = RegSetValueEx(phkResult, sSetValue, 0, REG_SZ, sValue, _
CLng(Len(sValue) + 1))
' 'Close the key

RegCloseKey phkResult
' 'Return SetRegValue Result

gbSetRegValue = (lResult = ERROR_SUCCESS)
Exit Function
ERROR_HANDLER:
MsgBox "ERROR #" & Str$(Err) & " : " & Error & Chr(13) _
& "Please exit and try again."
gbSetRegValue = False
End Function

#End If



'****************************************************************

' Name: cRegistry

' Description:A neat class module to give access t

' o the registry. This class allows: get/set of regi

' stry entries, checking if keys exist in the regist

' ry, enumeration of entries within a section and en

' umeration of sub sections within a section.

' By: Steve McMahon

'

' Inputs:Here is sample code to get the location of the Common Files folder under Windows 95 shell:


Dim cR As New cRegistry
With cR
.ClassKey = HKEY_LOCAL_MACHINE
.SectionKey = "\SOFTWARE\Microsoft\Windows\CurrentVersion"
.ValueKey = "CommonFilesDir"
.Default = "?WHERE?"

If (.Value <> .Default) Then
MsgBox "Program files at: " & .Value, vbInformation
Else
MsgBox "Foobar- Failed to find.", vbExclamation
End If

' Returns:None

' Assumes:Save the source code into a file called cRegistry.cls, and name the class 'cRegistry'. Then follow the example code listed above.

' Side Effects:Currently, the class only returns string values from the registry. Because VB makes automatic ANSI to UNICODE conversions, querying or writing other types of values is not recommended, particulary binary values in the registry.

'

'Code provided by Planet Source Code(tm) 'as is', without

' warranties as to performance, fitness, merchantability,

' and any other warranty (whether expressed or implied).

'****************************************************************


Option Explicit
' ================================================

' =========

' ' Description:

' A nice class wrapper around the registry functio

' ns

' Allows searching,deletion,modification and addit

' ion

' ' of Keys or Values.

' '

' Sample code: finds the location of the Common Fi

' les

' ' directory on the user's machine:

' '

' 'Dim cR As New cRegistry

' 'With cR

' '.ClassKey = HKEY_LOCAL_MACHINE

'.SectionKey = "\SOFTWARE\Microsoft\Windows\Curren

' tVersion"

' '.ValueKey = "CommonFilesDir"

' ' .Default = "?WHERE?"

' 'If (.Value <> .Default) Then

' MsgBox "Program files at: " & .Value, vbInformat

' ion

' 'Else

' 'MsgBox "Foobar- Failed to find.", vbExclamation

' 'End If

' ' Class:cRegistry

' Author:Steve McMahon (steve-mcmahon@pa-consultin

' g.com)

' ' Date :21 Feb 1997

' '

' ================================================

' =========

' ' Store the current user settings:


Private m_hClassKey As Long
Private m_sSectionKey As String
Private m_sValueKey As String
Private m_sValue As String
Private m_sSetValue As String
Private m_sDefault As String

Property Get ClassKey() As Long

' The Registry Class to search in, e.g. HKEY_CLASS

' ES_ROOT, HKEY_CLASSES_LOCAL_MACHINE etc

ClassKey = m_hClassKey
End Property

Property Let ClassKey(ByVal lKey As Long)
' The Registry Class to search in, e.g. HKEY_CLASS

' ES_ROOT, HKEY_CLASSES_LOCAL_MACHINE etc

m_hClassKey = lKey
End Property

Property Get SectionKey() As String
' The "directory" to search in, e.g. "\SOFTWARE\Mi

' crosoft\Windows\CurrentVersion"

SectionKey = m_sSectionKey
End Property

Property Let SectionKey(ByVal sSectionKey As String)
' The "directory" to search in, e.g. "\SOFTWARE\Mi

' crosoft\Windows\CurrentVersion"

m_sSectionKey = sSectionKey
End Property

Property Get ValueKey() As String
' ' The value to look at,

' e.g. "" for default, "CommonFilesDir" for the key

' ' named CommonFilesDir

ValueKey = m_sValueKey
End Property

Property Let ValueKey(ByVal sValueKey As String)
' ' The value to look at,

' e.g. "" for default, "CommonFilesDir" for the ke

' y

' ' named CommonFilesDir

m_sValueKey = sValueKey
End Property

Property Get KeyExists() As Boolean
' ' Returns whether the "directory" set up in

' ' SectionKey exists within the current ClassKey

KeyExists = bCheckKeyExists( _
m_hClassKey, _
m_sSectionKey _
)
End Property

Property Get Default() As String
' ' Default to return if anything goes awry:

Default = m_sDefault
End Property

Property Let Default( _
ByVal sDefault As String _
)
' ' Default to return if anything goes awry:

m_sDefault = sDefault
End Property

Property Get Value() As String
Dim sValue As String
' ' Gets the value associated with the current

' ' ClassKey and Section

If (bGetRegValueSearchInKey( _
m_hClassKey, _
m_sSectionKey, _
m_sValueKey, _
sValue)) Then
Value = sValue
Else
' ' Return default

Value = m_sDefault
End If

End Property

Property Let Value( _
ByVal sValue As String _
)
' ' Sets the value associated with the current

' ' ClassKey and Section


If (bSetRegValue( _
m_hClassKey, _
m_sSectionKey, _
m_sValueKey, _
sValue)) Then
m_sValue = sValue
Else
Err.Raise 26001, App.EXEName & ".cRegistry", "Failed to set registry value Key: '" & m_hClassKey & "',Section: '" & m_sSectionKey & "',Key: '" & m_sValueKey & "' to value: '" & m_sValue & "'"
End If

End Property


Public Sub EnumerateValues( _

ByRef sKeys() As String, _
ByRef iKeyCount As Integer _
)
' ' Returns all the value names and values within a

' ' section into a string array.

' ' The string array dimensioned

' '(1,n) = Value Name

' '(2,n) = Value

Dim lResult As Long
Dim phkResult As Long
Dim dWReserved As Long
Dim szBuffer As String
Dim lBuffSize As Long
Dim szBuffer2 As String
Dim lBuffSize2 As Long
Dim lIndex As Long
Dim lType As Long
Dim sCompKey As String
iKeyCount = 0
Erase sKeys
lIndex = 0
lResult = RegOpenKeyEx(m_hClassKey, m_sSectionKey, 0, 1, phkResult)

Do While lResult = ERROR_SUCCESS
' 'Set buffer space

szBuffer = Space(255)
lBuffSize = Len(szBuffer)
szBuffer2 = Space(255)
lBuffSize2 = Len(szBuffer2)
' 'Get next value

lResult = RegEnumValue(phkResult, lIndex, szBuffer, lBuffSize, _
dWReserved, lType, szBuffer2, lBuffSize2)

If (lResult = ERROR_SUCCESS) Then
iKeyCount = iKeyCount + 1
ReDim Preserve sKeys(1 To 2, 1 To iKeyCount) As String
sKeys(1, iKeyCount) = Left(szBuffer, lBuffSize)
sKeys(2, iKeyCount) = Left$(szBuffer2, lBuffSize2)
End If

lIndex = lIndex + 1
Loop

RegCloseKey phkResult
End Sub


Public Sub EnumerateSections( _

ByRef sSect() As String, _
ByRef iSectCount As Integer _
)
' ' Returns the names of all the sub-sections

' ' (sub "directories") within the current section

' ' in a 1 dimensional array:

Dim lResult As Long
Dim phkResult As Long
Dim dWReserved As Long
Dim szBuffer As String
Dim lBuffSize As Long
Dim lIndex As Long
Dim lType As Long
Dim sCompKey As String
iSectCount = 0
Erase sSect
lIndex = 0
lResult = RegOpenKeyEx(m_hClassKey, m_sSectionKey, 0, 1, phkResult)

Do While lResult = ERROR_SUCCESS
' 'Set buffer space

szBuffer = Space(255)
lBuffSize = Len(szBuffer)
' 'Get next value

lResult = RegEnumKey(phkResult, lIndex, szBuffer, lBuffSize)

If (lResult = ERROR_SUCCESS) Then
iSectCount = iSectCount + 1
ReDim Preserve sSect(1 To iSectCount) As String
sSect(iSectCount) = Left(szBuffer, lBuffSize)
End If

lIndex = lIndex + 1
Loop

RegCloseKey phkResult
End Sub


Public Function CreateKey() As Boolean

' ' Create the current section

CreateKey = bCreateNewKey(m_hClassKey, m_sSectionKey)
End Function


Private Function bSetRegValue( _

ByVal hKey As Long, _
ByVal lpszSubKey As String, _
ByVal sSetValue As String, _
ByVal sValue As String _
) As Boolean
' ' Private function to set a registry value

On Error GoTo ERROR_HANDLER

Dim phkResult As Long
Dim lResult As Long
Dim SA As SECURITY_ATTRIBUTES
Dim lCreate As Long
'Note: This function will create the key or value


' if it doesn't exist.


' 'Open or Create the key

RegCreateKeyEx hKey, lpszSubKey, 0, "", REG_OPTION_NON_VOLATILE, _
KEY_ALL_ACCESS, SA, phkResult, lCreate
lResult = RegSetValueEx(phkResult, sSetValue, 0, REG_SZ, sValue, _
CLng(Len(sValue) + 1))
' 'Close the key

RegCloseKey phkResult
' 'Return SetRegValue Result

bSetRegValue = (lResult = ERROR_SUCCESS)
Exit Function
ERROR_HANDLER:
MsgBox "ERROR #" & Str$(Err) & " : " & Error & Chr(13) _
& "Please exit and try again."
bSetRegValue = False
End Function


Private Function bGetRegValueSearchInKey( _

ByVal hKey As Long, _
ByVal sKey As String, _
ByVal sSubKey As String, _
ByRef sValue As String _
) As Boolean
' ' Private function servicing get value

' ' calls.

Dim lResult As Long
Dim phkResult As Long
Dim dWReserved As Long
Dim bFound As Integer
Dim szBuffer As String
Dim lBuffSize As Long
Dim szBuffer2 As String
Dim lBuffSize2 As Long
Dim lIndex As Long
Dim lType As Long
Dim sCompKey As String
lIndex = 0
lResult = RegOpenKeyEx(hKey, sKey, 0, 1, phkResult)

Do While lResult = ERROR_SUCCESS And Not (bFound)
' 'Set buffer space

szBuffer = Space(255)
lBuffSize = Len(szBuffer)
szBuffer2 = Space(255)
lBuffSize2 = Len(szBuffer2)
' 'Get next value

lResult = RegEnumValue(phkResult, lIndex, szBuffer, lBuffSize, _
dWReserved, lType, szBuffer2, lBuffSize2)

If (lResult = ERROR_SUCCESS) Then
sCompKey = Left(szBuffer, lBuffSize)
' 'Debug.Print sCompKey, sSubKey


If (sCompKey = sSubKey) Then
sValue = Left(szBuffer2, lBuffSize2 - 1)
bFound = True
End If

End If

lIndex = lIndex + 1
Loop

RegCloseKey phkResult
bGetRegValueSearchInKey = bFound
End Function


Private Function bCheckKeyExists( _

ByVal hKey As Long, _
ByVal strKey As String _
) As Boolean
' ' Private function servicing CheckIfKeyExists

' ' call

Dim phkResult As Long

If RegOpenKeyEx(hKey, strKey, 0, 1, phkResult) = ERROR_SUCCESS Then
bCheckKeyExists = True
RegCloseKey phkResult
Else
bCheckKeyExists = False
End If

End Function


Private Function bCreateNewKey( _

hKey As Long, _
strKey As String _
) As Boolean
' ' Private function to create a new subkey if

' ' not already present.

Dim phkResult As Long
Dim tSA As SECURITY_ATTRIBUTES
Dim lCreate As Long
' 'Create default SubKey if it does not exist


If RegCreateKeyEx(hKey, strKey, 0, "", REG_OPTION_NON_VOLATILE, _
KEY_ALL_ACCESS, tSA, phkResult, lCreate) <> ERROR_SUCCESS Then
' 'Close default SubKey

RegCloseKey phkResult
bCreateNewKey = True
Else
bCreateNewKey = False
End If

End Function