Thank you for your help on this but since it is not my code I am not sure how
to implement this. I have included all the code that is in the RegOp class.
If you could help me with the changes that are necessary I would appreciate
it.
Option Explicit
DefStr S
DefLng H-I, L, N
DefVar V
DefBool B
Private Type OSVERSIONINFO
dwOSVersionInfoSize As Long
dwMajorVersion As Long
dwMinorVersion As Long
dwBuildNumber As Long
dwPlatformId As Long
szCSDVersion As String * 128
End Type
Private Type SECURITY_ATTRIBUTES
nLength As Long
lpSecurityDescriptor As Long
bInheritHandle As Long
End Type
' RegCreateKeyEx creates the specified key. If the key
' already exists, the function opens it. The phkResult
' parameter receives the key handle.
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 SECURITY_ATTRIBUTES, _
phkResult As Long, lpdwDisposition As Long) As Long
'RegCloseKey releases a handle to the specified key.
'(Key handles should not be left open any longer than
'necessary.)
Private Declare Function RegCloseKey Lib "advapi32.dll" ( _
ByVal hCurKey As Long) As Long
' RegQueryInfoKey retrieves information about the specified
'key, such as the number of subkeys and values, the length
'of the longest value and key name, and the size of the
'longest data component among the key's values.
Private Declare Function RegQueryInfoKey _
Lib "advapi32.dll" Alias "RegQueryInfoKeyA" ( _
ByVal hCurKey As Long, ByVal lpClass As String, _
lpcbClass As Long, ByVal lpReserved As Long, _
lpcSubKeys As Long, lpcbMaxSubKeyLen As Long, _
lpcbMaxClassLen As Long, lpcValues As Long, _
lpcbMaxValueNameLen As Long, lpcbMaxValueLen As Long, _
lpcbSecurityDescriptor As Long, _
lpftLastWriteTime As Long) As Long
'RegEnumKeyEx enumerates subkeys of the specified open
'key. Retrieves the name (and its length) of each subkey.
Private Declare Function RegEnumKeyEx Lib "advapi32.dll" _
Alias "RegEnumKeyExA" (ByVal hCurKey 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 Long) As Long
'RegEnumValue enumerates the values for the specified open
'key. Retrieves the name (and its length) of each value,
'and the type, content and size of the data.
Private Declare Function RegEnumValue Lib "advapi32.dll" _
Alias "RegEnumValueA" (ByVal hCurKey As Long, _
ByVal dwIndex As Long, ByVal lpValueName As String, _
lpcbValueName As Long, ByVal lpReserved As Long, _
lpType As Long, lpData As Any, lpcbData As Long) As Long
'RegQueryValueEx retrieves the type, content and data for
' a specified value name. Note that if you declare the
' lpData parameter as String, you must pass it By Value.
Private Declare Function RegQueryValueEx _
Lib "advapi32.dll" Alias "RegQueryValueExA" ( _
ByVal hCurKey As Long, ByVal lpValueName As String, _
ByVal lpReserved As Long, lpType As Long, _
lpData As Any, lpcbData As Long) As Long
'RegSetValueEx sets the data and type of a specified
' value under a key.
Private Declare Function RegSetValueEx Lib "advapi32.dll" _
Alias "RegSetValueExA" (ByVal hCurKey As Long, ByVal _
lpValueName As String, ByVal Reserved As Long, _
ByVal dwType As Long, lpData As Any, _
ByVal cbData As Long) As Long
'RegDeleteValue removes a named value from specified key.
Private Declare Function RegDeleteValue _
Lib "advapi32.dll" Alias "RegDeleteValueA" ( _
ByVal hCurKey As Long, ByVal lpValueName As String) _
As Long
'RegDeleteKey deletes a subkey. Under Win 95/98, also
'deletes all subkeys and values. Under Windows NT/2000,
'the subkey to be deleted must not have subkeys. The class
'attempts to use SHDeleteKey (see below) before using
'RegDeleteKey.
Private Declare Function RegDeleteKey Lib "advapi32.dll" _
Alias "RegDeleteKeyA" (ByVal hKey As Long, _
ByVal lpSubKey As String) As Long
'SHDeleteKey deletes a subkey and all its descendants.
'Under Windows NT 4.0, Internet Explorer 4.0 or later
'is required.
Private Declare Function SHDeleteKey Lib "Shlwapi" _
Alias "SHDeleteKeyA" (ByVal hKey As Long, _
ByVal lpSubKey As String) As Long
Private Declare Function LoadLibrary Lib "kernel32" _
Alias "LoadLibraryA" (ByVal lpLibFileName As String) _
As Long
Private Declare Function FreeLibrary Lib "kernel32" ( _
ByVal hLibModule As Long) As Long
Private Declare Function ExpandEnvStrings Lib "kernel32" _
Alias "ExpandEnvironmentStringsA" ( _
ByVal lpSrc As String, ByVal lpDst As String, _
ByVal nSize As Long) As Long
Private Declare Function GetVersionEx Lib "kernel32" _
Alias "GetVersionExA" ( _
lpVersionInformation As OSVERSIONINFO) As Long
Private Const REG_SZ = 1
Private Const REG_EXPAND_SZ = 2
Private Const REG_DWORD = 4
Private Const REG_DWORD_LITTLE_ENDIAN = REG_DWORD
Private Const REG_MULTI_SZ = 7
' The following values are only relevant under WinNT/2K,
' and are ignored by Win9x.
Private Const STANDARD_RIGHTS_READ = &H20000
Private Const STANDARD_RIGHTS_WRITE = &H20000
Private Const STANDARD_RIGHTS_ALL = &H1F0000
Private Const KEY_CREATE_LINK = &H20
Private Const KEY_QUERY_VALUE = &H1
Private Const KEY_ENUMERATE_SUB_KEYS = &H8
Private Const KEY_NOTIFY = &H10
Private Const KEY_SET_VALUE = &H2
Private Const KEY_CREATE_SUB_KEY = &H4
Private Const SYNCHRONIZE = &H100000
' Access right to query and enumerate values.
Private Const KEY_READ = ((STANDARD_RIGHTS_READ Or _
KEY_QUERY_VALUE Or KEY_ENUMERATE_SUB_KEYS Or _
KEY_NOTIFY) And (Not SYNCHRONIZE))
'Access right to create values and keys.
Private Const KEY_WRITE = ((STANDARD_RIGHTS_WRITE Or _
KEY_SET_VALUE Or KEY_CREATE_SUB_KEY) And _
(Not SYNCHRONIZE))
'Access right to create/delete values and keys.
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 lRequiredAccess
Private lPreviousAccess
'Return values for all registry functions.
Private Const ERROR_SUCCESS = 0
'Property variables.
Private lRoot 'default is HKEY_LOCAL_MACHINE
Private lOptions
Private strKeyName
Private strValueName
Private vData
'Variables set in GetKeyHandle.
Private hCurKey
Private nSubKeys
Private nValues
Private lMaxSubKeyLen
Private lMaxValueNameLen
Private lMaxValueLen
Private bIsWinNT
'Public Enum RegOptions ' variable: lOptions
' StoreNumbersAsStrings = 1
' ReturnMultiStringsAsArrays = 2
' ExpandEnvironmentStrings = 4
' ShowErrorMessages = 8
'End Enum
'Public Enum RegRoot ' variable: lRoot
' HKEY_CLASSES_ROOT = &H80000000
' HKEY_CURRENT_USER = &H80000001 ' default
' HKEY_LOCAL_MACHINE = &H80000002
'End Enum
'Message constants.
Private Const ERROR_NO_KEY As String = _
"No Key name specified!"
Private Const ERROR_NO_HANDLE = _
"Could not open Registry Key!"
Private Const ERR_MSG_NO_OVERWRITE As String = _
"Existing value has unsupported data type " & _
"and will not be overwritten"
Private Const RETURN_UNSUPPORTED As String = _
"(unsupported data format)"
Private ValueList As Object
Property Let Root(lProp As RegRoot)
' Don't accept an invalid Root value.
Select Case lProp
Case HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, _
HKEY_LOCAL_MACHINE
' All is well.
Case Else
lRoot = HKEY_CURRENT_USER
End Select
If lProp <> lRoot Then
lRoot = lProp
If Len(strKeyName) Then
GetKeyHandle lRoot, strKeyName
End If
End If
lRoot = lProp
End Property
Property Let Key(strProp)
' Don't accept an empty key name.
If Len(strProp) = 0 Then Exit Property
If Len(strKeyName) = 0 Then ' first time
strKeyName = strProp
ElseIf StrComp(strProp, strKeyName, _
vbTextCompare) <> 0 Then
strKeyName = strProp
GetKeyHandle lRoot, strKeyName
Else
End If
End Property
Property Let Options(lProp As RegOptions)
' Don't accept an invalid Options value.
Select Case lProp
Case 0 To 15: lOptions = lProp
Case Else:
End Select
End Property
Property Let Value(Optional ValueName As String, vValue)
If IsEmpty(vValue) Then
Exit Property
Else
vData = vValue
End If
If bIsWinNT Then lRequiredAccess = KEY_WRITE Or KEY_READ
If PropertiesOK Then
' First see if this is an existing value, and,
' if so, what data type we have here.
Dim strBuffer, lBuffer, lType
If RegQueryValueEx(hCurKey, ValueName, 0, lType, _
ByVal strBuffer, lBuffer) = ERROR_SUCCESS Then
' Make sure our new value is the same data type.
Select Case lType
Case REG_SZ, REG_EXPAND_SZ ' existing string
vData = CStr(vData)
Case REG_DWORD, REG_DWORD_LITTLE_ENDIAN
' existing long
vData = CLng(vData)
Case REG_MULTI_SZ ' existing array
vData = CVar(vData)
Case Else
ShowErrMsg ERR_MSG_NO_OVERWRITE
Exit Property
End Select
End If
If (lOptions And StoreNumbersAsStrings) Then
If IsNumeric(vData) Then vData = CStr(vData)
End If
' If nameless "(default)" value:
If Len(ValueName) = 0 Then vData = CStr(vData)
' Look at the data type of vData, and store it
' in the appropriate registry format.
If VarType(vData) And vbArray Then ' 8192
Dim sTemp As String
' REG_MULTI_SZ values must end with 2 null characters.
sTemp = Join(vData, vbNullChar) & String$(2, 0)
Call RegSetValueEx(hCurKey, ValueName, 0, _
REG_MULTI_SZ, ByVal sTemp, Len(sTemp))
Else
Select Case VarType(vData)
Case vbInteger, vbLong
Call RegSetValueEx(hCurKey, ValueName, 0, _
REG_DWORD, CLng(vData), 4)
Case vbString
If ContainsEnvString(CStr(vData)) Then
Call RegSetValueEx(hCurKey, ValueName, 0, _
REG_EXPAND_SZ, ByVal CStr(vData), _
Len(vData) + 1)
Else
Call RegSetValueEx(hCurKey, ValueName, 0, _
REG_SZ, ByVal CStr(vData), Len(vData) + 1)
End If
Case Else ' Store any other data type as string.
Call RegSetValueEx(hCurKey, ValueName, 0, _
REG_SZ, ByVal CStr(vData), Len(vData) + 1)
End Select
End If
' Update Value Count.
Call RegQueryInfoKey(hCurKey, vbNullString, 0, 0, 0, _
0, 0, nValues, 0, 0, 0, 0)
' Clear the values database.
ValueList.RemoveAll
End If
End Property
Property Get Value(Optional ValueName As String) As Variant
With ValueList
If .Count = 0 Then FillDataList
If .Exists(ValueName) Then Value = .Item(ValueName)
End With
End Property
Property Get AllValues() As Variant
If bIsWinNT Then lRequiredAccess = KEY_READ
If PropertiesOK Then
If nValues = 0 Then Exit Property
With ValueList
If .Count = 0 Then FillDataList
If .Count Then
Dim i, vKeys, vItems
vKeys = .Keys
vItems = .items
ReDim vTemp(.Count - 1, 1)
For i = 0 To .Count - 1
vTemp(i, 0) = vKeys(i)
vTemp(i, 1) = vItems(i)
Next
AllValues = vTemp
End If
End With
End If
End Property
Property Get AllKeys() As Variant
If bIsWinNT Then lRequiredAccess = KEY_READ
If PropertiesOK Then
If nSubKeys = 0 Then Exit Property
Dim i: ReDim vTemp(nSubKeys - 1)
For i = 0 To nSubKeys - 1
strKeyName = String$(lMaxSubKeyLen + 1, 0)
If RegEnumKeyEx(hCurKey, i, strKeyName, _
lMaxSubKeyLen + 1, 0, vbNullString, 0, 0) = _
ERROR_SUCCESS Then
vTemp(i) = TrimNull(strKeyName)
End If
Next
AllKeys = vTemp
End If
End Property
Function DeleteValue(Optional ValueName As String) _
As Boolean
If bIsWinNT Then lRequiredAccess = KEY_ALL_ACCESS
If PropertiesOK Then
DeleteValue = (RegDeleteValue(hCurKey, ValueName) = _
ERROR_SUCCESS)
If DeleteValue Then
Call RegQueryInfoKey(hCurKey, vbNullString, 0, 0, _
0, 0, 0, nValues, 0, 0, 0, 0)
ValueList.RemoveAll
End If
End If
End Function
Function DeleteKey() As Boolean
If Len(strKeyName) = 0 Then
ShowErrMsg ERROR_NO_KEY
Exit Function
End If
Dim n, strLastKey
n = InStrRev(strKeyName, "\")
If n > 0 And n < Len(strKeyName) Then
strLastKey = Mid$(strKeyName, n + 1)
strKeyName = Left$(strKeyName, n - 1)
If bIsWinNT Then lRequiredAccess = KEY_ALL_ACCESS
Call GetKeyHandle(lRoot, strKeyName)
If hCurKey = 0 Then Exit Function
If ShlwapiInstalled Then
' This should always work.
DeleteKey = (SHDeleteKey(hCurKey, strLastKey) = _
ERROR_SUCCESS)
Else
' This will only work under Win95/98.
DeleteKey = (RegDeleteKey(hCurKey, strLastKey) = _
ERROR_SUCCESS)
End If
If DeleteKey Then
Call RegQueryInfoKey(hCurKey, vbNullString, 0, 0, _
nSubKeys, 0, 0, 0, 0, 0, 0, 0)
ValueList.RemoveAll
End If
End If
End Function
Property Get ValueCount() As Long
If PropertiesOK Then ValueCount = nValues
End Property
Property Get KeyCount() As Long
If PropertiesOK Then KeyCount = nSubKeys
End Property
Private Function PropertiesOK() As Boolean
If Len(strKeyName) = 0 Then
ShowErrMsg ERROR_NO_KEY
Exit Function
End If
If lPreviousAccess Then
If lRequiredAccess <> lPreviousAccess Then _
CloseCurrentKey
End If
If hCurKey = 0 Then Call GetKeyHandle(lRoot, strKeyName)
If hCurKey = 0 Then
ShowErrMsg ERROR_NO_HANDLE
Exit Function
End If
PropertiesOK = True
End Function
Private Sub Class_Initialize()
lRoot = HKEY_CURRENT_USER
bIsWinNT = IsWinNT
If bIsWinNT Then lRequiredAccess = KEY_READ
On Error Resume Next
Set ValueList = CreateObject("Scripting.Dictionary")
If IsObject(ValueList) Then
ValueList.CompareMode = vbTextCompare
Else
End
End If
End Sub
Private Sub Class_Terminate()
CloseCurrentKey
Set ValueList = Nothing
End Sub
Private Sub CloseCurrentKey()
If hCurKey Then
Call RegCloseKey(hCurKey)
hCurKey = 0
End If
End Sub
Private Sub GetKeyHandle(lKey, strKey)
CloseCurrentKey
If lKey = 0 Then lKey = HKEY_CURRENT_USER
Dim SA As SECURITY_ATTRIBUTES
Call RegCreateKeyEx(lKey, strKey, 0, vbNull, 0, _
lRequiredAccess, SA, hCurKey, 0)
If hCurKey Then
Call RegQueryInfoKey(hCurKey, vbNullString, 0, 0, _
nSubKeys, lMaxSubKeyLen, 0, nValues, _
lMaxValueNameLen, lMaxValueLen, 0, 0)
ValueList.RemoveAll
lPreviousAccess = lRequiredAccess
End If
End Sub
Private Function TrimNull(ByVal strIn) As String
TrimNull = Left$(strIn, InStr(strIn, vbNullChar) - 1)
End Function
Private Function TrimDoubleNull(ByVal strIn) As String
If Len(strIn) Then _
TrimDoubleNull = _
Left$(strIn, InStr(strIn, String$(2, 0)) - 1)
End Function
Private Function ExpandString(strIn) As String
Dim nChars, strBuff, nBuffSize
nBuffSize = 1024
strBuff = String$(nBuffSize, 0)
nChars = ExpandEnvStrings(strIn, strBuff, nBuffSize)
If nChars Then ExpandString = Left$(strBuff, nChars - 1)
End Function
Private Function ShlwapiInstalled() As Boolean
Dim hLib As Long
hLib = LoadLibrary("Shlwapi")
If hLib Then
ShlwapiInstalled = True
FreeLibrary hLib
End If
End Function
Private Function ContainsEnvString(ByVal strTest) _
As Boolean
Const PCT As String = "%"
' See if there is a percent sign.
Dim n As Long:
n = InStr(strTest, PCT)
If n = 0 Then Exit Function
' See if there is a second percent sign.
If n = InStrRev(strTest, PCT) Then Exit Function
' Now we have a potential environment string.
Dim Env As String, EnvSplit() As String
Dim i As Long
For i = 1 To 100
Env = Environ(i)
If Len(Env) Then
EnvSplit = Split(Env, "=")
If InStr(1, strTest, PCT & EnvSplit(0) & PCT, _
vbTextCompare) Then
ContainsEnvString = True
Exit For
End If
Else
Exit For
End If
Next
End Function
Private Sub ShowErrMsg(strMsg)
If (lOptions And ShowErrorMessages) Then
MsgBox strMsg, vbExclamation, "Registry Error"
Else
Debug.Print strMsg
End If
End Sub
Private Function IsWinNT()
' Returns True if the OS is Windows NT/2000.
Const VER_PLATFORM_WIN32_NT As Long = 2
Dim osvi As OSVERSIONINFO
osvi.dwOSVersionInfoSize = Len(osvi)
GetVersionEx osvi
IsWinNT = (osvi.dwPlatformId = VER_PLATFORM_WIN32_NT)
End Function
Private Sub FillDataList(Optional Key As String)
If Len(Key) Then strKeyName = Key
If Len(strKeyName) = 0 Then _
ShowErrMsg ERROR_NO_KEY: Exit Sub
If bIsWinNT Then lRequiredAccess = KEY_READ
If PropertiesOK Then
If nValues = 0 Then Exit Sub
ValueList.RemoveAll
Dim i, lValuename, lType, lBuffer, strValue, strBuffer
For i = 0 To nValues - 1
lValuename = lMaxValueNameLen + 1
strValue = String$(lValuename, 0)
lBuffer = lMaxValueLen + 1
strBuffer = String$(lBuffer, 0)
If RegEnumValue(hCurKey, i, strValue, lValuename, _
0, lType, ByVal strBuffer, lBuffer) = _
ERROR_SUCCESS Then
strValue = TrimNull(strValue)
Select Case lType
Case REG_SZ
ValueList(strValue) = TrimNull(strBuffer)
Case REG_EXPAND_SZ
If (lOptions And ExpandEnvironmentStrings) Then
ValueList(strValue) = _
ExpandString(TrimNull(strBuffer))
Else
ValueList(strValue) = TrimNull(strBuffer)
End If
Case REG_MULTI_SZ
If (lOptions And _
ReturnMultiStringsAsArrays) Then
ValueList(strValue) = Split( _
TrimDoubleNull(strBuffer), vbNullChar)
Else
ValueList(strValue) = _
TrimDoubleNull(strBuffer)
End If
Case REG_DWORD, REG_DWORD_LITTLE_ENDIAN
Dim nBuffer
If RegEnumValue(hCurKey, i, strValue, _
Len(strValue) + 1, 0, REG_DWORD, nBuffer, _
4) = ERROR_SUCCESS Then
ValueList(strValue) = nBuffer
End If
Case Else
ValueList(strValue) = RETURN_UNSUPPORTED
End Select
End If
Next
End If
End Sub
