RegOp.cls #1

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "RegOp"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
 
' REgistry manipulation class
' Taken from: http://msdn.microsoft.com/library/default.asp?url=/library/en-us/dnovba01/html/RegistryMadeEasy.asp
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 RegistryOptions ' 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 RegistryOptions)
  ' 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
  End If
  err.Clear
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