Advertisement
Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- VERSION 1.0 CLASS
- BEGIN
- MultiUse = -1 'True
- Persistable = 0 'NotPersistable
- DataBindingBehavior = 0 'vbNone
- DataSourceBehavior = 0 'vbNone
- MTSTransactionMode = 0 'NotAnMTSObject
- END
- Attribute VB_Name = "clsRegistry"
- Attribute VB_GlobalNameSpace = False
- Attribute VB_Creatable = True
- Attribute VB_PredeclaredId = False
- Attribute VB_Exposed = False
- Option Explicit
- '__________________________________________________________
- ' Class: clsRegistry
- ' Author: JA
- '__________________________________________________________
- 'Registry Specific Access Rights
- Private Const KEY_QUERY_VALUE = &H1
- Private Const KEY_SET_VALUE = &H2
- Private Const KEY_CREATE_SUB_KEY = &H4
- Private Const KEY_ENUMERATE_SUB_KEYS = &H8
- Private Const KEY_NOTIFY = &H10
- Private Const KEY_CREATE_LINK = &H20
- Private Const KEY_ALL_ACCESS = &H3F
- 'Open/Create Options
- Private Const REG_OPTION_NON_VOLATILE = 0&
- Private Const REG_OPTION_VOLATILE = &H1
- 'Key creation/open disposition
- Private Const REG_CREATED_NEW_KEY = &H1
- Private Const REG_OPENED_EXISTING_KEY = &H2
- 'masks for the predefined standard access types
- Private Const STANDARD_RIGHTS_ALL = &H1F0000
- Private Const SPECIFIC_RIGHTS_ALL = &HFFFF
- 'Define severity codes
- Private Const ERROR_SUCCESS = 0&
- Private Const ERROR_ACCESS_DENIED = 5
- Private Const ERROR_INVALID_DATA = 13&
- Private Const ERROR_MORE_DATA = 234 ' dderror
- Private Const ERROR_NO_MORE_ITEMS = 259
- 'Structures Needed For Registry Prototypes
- Private Type SECURITY_ATTRIBUTES
- nLength As Long
- lpSecurityDescriptor As Long
- bInheritHandle As Boolean
- End Type
- Private Type FILETIME
- dwLowDateTime As Long
- dwHighDateTime As Long
- End Type
- 'Registry Function Prototypes
- Private 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
- Private Declare Function RegSetValueExStr _
- 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
- Private Declare Function RegSetValueExLong _
- Lib "advapi32" _
- Alias "RegSetValueExA" _
- (ByVal HKEY As Long, _
- ByVal lpValueName As String, _
- ByVal Reserved As Long, _
- ByVal dwType As Long, _
- szData As Long, _
- ByVal cbData As Long _
- ) As Long
- Private Declare Function RegSetValueExByte _
- Lib "advapi32" _
- Alias "RegSetValueExA" _
- (ByVal HKEY As Long, _
- ByVal lpValueName As String, _
- ByVal Reserved As Long, _
- ByVal dwType As Long, _
- szData As Byte, _
- ByVal cbData As Long _
- ) As Long
- Private Declare Function RegCloseKey _
- Lib "advapi32" _
- (ByVal HKEY As Long _
- ) As Long
- Private Declare Function RegQueryValueExStr _
- 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
- Private Declare Function RegQueryValueExLong _
- Lib "advapi32" _
- Alias "RegQueryValueExA" _
- (ByVal HKEY As Long, _
- ByVal lpValueName As String, _
- ByVal lpReserved As Long, _
- ByRef lpType As Long, _
- szData As Long, _
- ByRef lpcbData As Long _
- ) As Long
- Private Declare Function RegQueryValueExByte _
- Lib "advapi32" _
- Alias "RegQueryValueExA" _
- (ByVal HKEY As Long, _
- ByVal lpValueName As String, _
- ByVal lpReserved As Long, _
- ByRef lpType As Long, _
- szData As Byte, _
- ByRef lpcbData As Long _
- ) As Long
- Private 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
- 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 RegEnumKey _
- Lib "advapi32.dll" _
- Alias "RegEnumKeyA" _
- (ByVal HKEY As Long, _
- ByVal dwIndex As Long, _
- ByVal lpName As String, _
- ByVal cbName As Long _
- ) As Long
- Private 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, _
- ByVal lpType As Long, _
- ByVal lpData As Long, _
- ByVal lpcbData As Long _
- ) As Long
- Private Declare Function RegEnumValueLong _
- 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, _
- lpData As Long, _
- lpcbData As Long _
- ) As Long
- Private Declare Function RegEnumValueStr _
- 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
- Private Declare Function RegEnumValueByte _
- 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, _
- lpData As Byte, _
- lpcbData As Long _
- ) As Long
- Private Declare Function RegQueryInfoKey _
- Lib "advapi32.dll" _
- Alias "RegQueryInfoKeyA" _
- (ByVal HKEY 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 Any _
- ) As Long
- Private Declare Function RegDeleteKey _
- Lib "advapi32.dll" _
- Alias "RegDeleteKeyA" _
- (ByVal HKEY As Long, _
- ByVal lpSubKey As String _
- ) As Long
- Private Declare Function RegDeleteValue _
- Lib "advapi32.dll" _
- Alias "RegDeleteValueA" _
- (ByVal HKEY As Long, _
- ByVal lpValueName As String _
- ) As Long
- ' Other declares:
- Private Declare Sub CopyMemory _
- Lib "kernel32" _
- Alias "RtlMoveMemory" _
- (lpvDest As Any, _
- lpvSource As Any, _
- ByVal cbCopy As Long _
- )
- Private Declare Function ExpandEnvironmentStrings _
- Lib "kernel32" _
- Alias "ExpandEnvironmentStringsA" _
- (ByVal lpSrc As String, _
- ByVal lpDst As String, _
- ByVal nSize As Long _
- ) As Long
- Public Enum ERegistryClassConstants
- HKEY_CLASSES_ROOT = &H80000000
- HKEY_CURRENT_USER = &H80000001
- HKEY_LOCAL_MACHINE = &H80000002
- HKEY_USERS = &H80000003
- End Enum
- 'Predefined Value Types
- Public Enum ERegistryValueTypes
- REG_NONE = (0) 'No value type
- REG_SZ = (1) 'Unicode nul terminated string
- REG_EXPAND_SZ = (2) 'Unicode nul terminated string w/enviornment var
- REG_BINARY = (3) 'Free form binary
- REG_DWORD = (4) '32-bit number
- REG_DWORD_LITTLE_ENDIAN = (4) '32-bit number (same as REG_DWORD)
- REG_DWORD_BIG_ENDIAN = (5) '32-bit number
- REG_LINK = (6) 'Symbolic Link (unicode)
- REG_MULTI_SZ = (7) 'Multiple Unicode strings
- REG_RESOURCE_LIST = (8) 'Resource list in the resource map
- REG_FULL_RESOURCE_DESCRIPTOR = (9) 'Resource list in the hardware description
- REG_RESOURCE_REQUIREMENTS_LIST = (10)
- End Enum
- Private m_hClassKey As Long
- Private m_sSectionKey As String
- Private m_sValueKey As String
- Private m_vValue As Variant
- Private m_sSetValue As String
- Private m_vDefault As Variant
- Private m_eValueType As ERegistryValueTypes
- Public Property Get ClassKey( _
- ) As ERegistryClassConstants
- ClassKey = m_hClassKey
- End Property
- Public Property Let ClassKey(ByVal eKey As ERegistryClassConstants)
- m_hClassKey = eKey
- End Property
- Public Sub CreateAdditionalEXEAssociations(ByVal sClassName As String, _
- ParamArray vItems() As Variant _
- )
- On Error Resume Next
- Dim iItems As Long
- Dim iItem As Long
- iItems = UBound(vItems) + 1
- If (iItems Mod 3) <> 0 Or (Err.Number <> 0) Then
- Err.Raise vbObjectError + 1048 + 26004, _
- App.EXEName & ".clsRegistry", _
- "Invalid parameter list passed to CreateAdditionalEXEAssociations - expected Name/Text/Command"
- Else
- ' Check if it exists:
- SectionKey = sClassName
- If Not (KeyExists) Then
- Err.Raise vbObjectError + 1048 + 26005, _
- App.EXEName & ".clsRegistry", _
- "Error - attempt to create additional associations before class defined."
- Else
- For iItem = 0 To iItems - 1 Step 3
- ValueType = REG_SZ
- SectionKey = sClassName & "\shell\" & vItems(iItem)
- ValueKey = ""
- pSetClassValue vItems(iItem + 1)
- SectionKey = sClassName & "\shell\" & vItems(iItem) & "\command"
- ValueKey = ""
- pSetClassValue vItems(iItem + 2)
- Next iItem
- End If
- End If
- End Sub
- Public Sub CreateEXEAssociation( _
- ByVal sExePath As String, _
- ByVal sClassName As String, _
- ByVal sClassDescription As String, _
- ByVal sAssociation As String, _
- Optional ByVal sOpenMenuText As String = "&Open", _
- Optional ByVal bSupportPrint As Boolean = False, _
- Optional ByVal sPrintMenuText As String = "&Print", _
- Optional ByVal bSupportNew As Boolean = False, _
- Optional ByVal sNewMenuText As String = "&New", _
- Optional ByVal bSupportInstall As Boolean = False, _
- Optional ByVal sInstallMenuText As String = "", _
- Optional ByVal lDefaultIconIndex As Long = -1)
- ' Check if path is wrapped in quotes:
- sExePath = Trim$(sExePath)
- If (Left$(sExePath, 1) <> """") Then sExePath = """" & sExePath
- If (Right$(sExePath, 1) <> """") Then sExePath = sExePath & """"
- ' Create the .File to Class association:
- SectionKey = "." & sAssociation
- ValueType = REG_SZ
- ValueKey = ""
- pSetClassValue sClassName
- ' Create the Class shell open command:
- SectionKey = sClassName
- pSetClassValue sClassDescription
- SectionKey = sClassName & "\shell\open"
- If (sOpenMenuText = "") Then sOpenMenuText = "&Open"
- ValueKey = ""
- pSetClassValue sOpenMenuText
- SectionKey = sClassName & "\shell\open\command"
- ValueKey = ""
- pSetClassValue sExePath & " ""%1"""
- If (bSupportPrint) Then
- SectionKey = sClassName & "\shell\print"
- If (sPrintMenuText = "") Then sPrintMenuText = "&Print"
- ValueKey = ""
- pSetClassValue sPrintMenuText
- SectionKey = sClassName & "\shell\print\command"
- ValueKey = ""
- pSetClassValue sExePath & " /p ""%1"""
- End If
- If (bSupportInstall) Then
- If (sInstallMenuText = "") Then sInstallMenuText = "&Install " & sAssociation
- SectionKey = sClassName & "\shell\add"
- ValueKey = ""
- pSetClassValue sInstallMenuText
- SectionKey = sClassName & "\shell\add\command"
- ValueKey = ""
- pSetClassValue sExePath & " /a ""%1"""
- End If
- If (bSupportNew) Then
- SectionKey = sClassName & "\shell\new"
- ValueKey = ""
- If (sNewMenuText = "") Then sNewMenuText = "&New"
- pSetClassValue sNewMenuText
- SectionKey = sClassName & "\shell\new\command"
- ValueKey = ""
- pSetClassValue sExePath & " /n ""%1"""
- End If
- If lDefaultIconIndex > -1 Then
- SectionKey = sClassName & "\DefaultIcon"
- ValueKey = ""
- pSetClassValue sExePath & "," & CStr(lDefaultIconIndex)
- End If
- End Sub
- Public Function CreateKey( _
- ) As Boolean
- Dim tSA As SECURITY_ATTRIBUTES
- Dim HKEY As Long
- Dim lCreate As Long
- Dim e As Long
- 'Open or Create the key
- e = RegCreateKeyEx(m_hClassKey, m_sSectionKey, 0, "", REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS, tSA, HKEY, lCreate)
- If e Then
- Err.Raise 26001, App.EXEName & ".clsRegistry", "Failed to create registry Key: '" & m_sSectionKey
- Else
- CreateKey = (e = ERROR_SUCCESS)
- 'Close the key
- RegCloseKey HKEY
- End If
- End Function
- Public Property Get Default( _
- ) As Variant
- Default = m_vDefault
- End Property
- Public Property Let Default(ByVal vDefault As Variant)
- m_vDefault = vDefault
- End Property
- Public Function DeleteKey( _
- ) As Boolean
- Dim e As Long
- e = RegDeleteKey(m_hClassKey, m_sSectionKey)
- If e Then
- 'Err.Raise 26001, App.EXEName & ".clsRegistry", "Failed to delete registry Key: '" & m_hClassKey & "',Section: '" & m_sSectionKey
- Else
- DeleteKey = (e = ERROR_SUCCESS)
- End If
- End Function
- Public Function DeleteValue( _
- ) As Boolean
- Dim e As Long
- Dim HKEY As Long
- e = RegOpenKeyEx(m_hClassKey, m_sSectionKey, 0, KEY_ALL_ACCESS, HKEY)
- If e Then
- 'Err.Raise 26001, App.EXEName & ".clsRegistry", "Failed to open key '" & m_hClassKey & "',Section: '" & m_sSectionKey & "' for delete access"
- Else
- e = RegDeleteValue(HKEY, m_sValueKey)
- If e Then
- 'Err.Raise 26001, App.EXEName & ".clsRegistry", "Failed to delete registry Key: '" & m_hClassKey & "',Section: '" & m_sSectionKey & "',Key: '" & m_sValueKey
- Else
- DeleteValue = (e = ERROR_SUCCESS)
- End If
- End If
- End Function
- Public Function EnumerateSections(ByRef sSect() As String, _
- ByRef iSectCount As Long _
- ) As Boolean
- On Error GoTo EnumerateSectionsError
- Dim lResult As Long
- Dim HKEY 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
- Dim iPos As Long
- iSectCount = 0
- Erase sSect
- lIndex = 0
- lResult = RegOpenKeyEx(m_hClassKey, m_sSectionKey, 0, KEY_ENUMERATE_SUB_KEYS, HKEY)
- Do While lResult = ERROR_SUCCESS
- 'Set buffer space
- szBuffer = String$(255, 0)
- lBuffSize = Len(szBuffer)
- 'Get next value
- lResult = RegEnumKey(HKEY, lIndex, szBuffer, lBuffSize)
- If (lResult = ERROR_SUCCESS) Then
- iSectCount = iSectCount + 1
- ReDim Preserve sSect(1 To iSectCount) As String
- iPos = InStr(szBuffer, Chr$(0))
- If (iPos > 0) Then
- sSect(iSectCount) = Left(szBuffer, iPos - 1)
- Else
- sSect(iSectCount) = Left(szBuffer, lBuffSize)
- End If
- End If
- lIndex = lIndex + 1
- Loop
- If (HKEY <> 0) Then RegCloseKey HKEY
- EnumerateSections = True
- Exit Function
- EnumerateSectionsError:
- If (HKEY <> 0) Then
- RegCloseKey HKEY
- End If
- Err.Raise vbObjectError + 1048 + 26002, _
- App.EXEName & ".clsRegistry", _
- Err.Description
- Exit Function
- End Function
- Public Function EnumerateValues(ByRef sKeyNames() As String, _
- ByRef iKeyCount As Long _
- ) As Boolean
- Dim lResult As Long
- Dim HKEY As Long
- Dim sName As String
- Dim lNameSize As Long
- Dim sData As String
- Dim lIndex As Long
- Dim cJunk As Long
- Dim cNameMax As Long
- Dim ft As Currency
- ' Log "EnterEnumerateValues"
- iKeyCount = 0
- Erase sKeyNames()
- lIndex = 0
- lResult = RegOpenKeyEx(m_hClassKey, m_sSectionKey, 0, KEY_QUERY_VALUE, HKEY)
- If (lResult = ERROR_SUCCESS) Then
- ' Log "OpenedKey:" & m_hClassKey & "," & m_sSectionKey
- lResult = RegQueryInfoKey(HKEY, "", cJunk, 0, _
- cJunk, cJunk, cJunk, cJunk, _
- cNameMax, cJunk, cJunk, ft)
- Do While lResult = ERROR_SUCCESS
- 'Set buffer space
- lNameSize = cNameMax + 1
- sName = String$(lNameSize, 0)
- If (lNameSize = 0) Then lNameSize = 1
- ' Log "Requesting Next Value"
- 'Get value name:
- lResult = RegEnumValue(HKEY, lIndex, sName, lNameSize, 0&, 0&, 0&, 0&)
- ' Log "RegEnumValue returned:" & lResult
- If (lResult = ERROR_SUCCESS) Then
- ' Although in theory you can also retrieve the actual
- ' value and type here, I found it always (ultimately) resulted in
- ' a GPF, on Win95 and NT. Why? Can anyone help?
- sName = Left$(sName, lNameSize)
- ' Log "Enumerated value:" & sName
- iKeyCount = iKeyCount + 1
- ReDim Preserve sKeyNames(1 To iKeyCount) As String
- sKeyNames(iKeyCount) = sName
- End If
- lIndex = lIndex + 1
- Loop
- End If
- If (HKEY <> 0) Then RegCloseKey HKEY
- ' Log "Exit Enumerate Values"
- EnumerateValues = True
- Exit Function
- EnumerateValuesError:
- If (HKEY <> 0) Then
- RegCloseKey HKEY
- End If
- Err.Raise vbObjectError + 1048 + 26003, _
- App.EXEName & ".clsRegistry", _
- Err.Description
- Exit Function
- End Function
- Private Function ExpandEnvStr(sData As String _
- ) As String
- Dim c As Long
- Dim s As String
- ' Get the length
- s = "" ' Needed to get around Windows 95 limitation
- c = ExpandEnvironmentStrings(sData, s, c)
- ' Expand the string
- s = String$(c - 1, 0)
- c = ExpandEnvironmentStrings(sData, s, c)
- ExpandEnvStr = s
- End Function
- 'KeyExists = bCheckKeyExists(m_hClassKey, m_sSectionKey)
- Public Property Get KeyExists( _
- ) As Boolean
- Dim HKEY As Long
- If RegOpenKeyEx(m_hClassKey, m_sSectionKey, 0, 1, HKEY) = ERROR_SUCCESS Then
- KeyExists = True
- RegCloseKey HKEY
- Else
- KeyExists = False
- End If
- End Property
- Private Sub pSetClassValue(ByVal sValue As String)
- Dim sSection As String
- ClassKey = HKEY_CLASSES_ROOT
- Value = sValue
- sSection = SectionKey
- ClassKey = HKEY_LOCAL_MACHINE
- SectionKey = "SOFTWARE\Classes\" & sSection
- Value = sValue
- SectionKey = sSection
- End Sub
- Public Property Get SectionKey( _
- ) As String
- SectionKey = m_sSectionKey
- End Property
- Public Property Let SectionKey(ByVal sSectionKey As String)
- m_sSectionKey = sSectionKey
- End Property
- Private Function SwapEndian(ByVal dw As Long _
- ) As Long
- CopyMemory ByVal VarPtr(SwapEndian) + 3, dw, 1
- CopyMemory ByVal VarPtr(SwapEndian) + 2, ByVal VarPtr(dw) + 1, 1
- CopyMemory ByVal VarPtr(SwapEndian) + 1, ByVal VarPtr(dw) + 2, 1
- CopyMemory SwapEndian, ByVal VarPtr(dw) + 3, 1
- End Function
- Public Property Get Value( _
- ) As Variant
- Dim vValue As Variant
- Dim cData As Long
- Dim sData As String
- Dim ordType As Long
- Dim e As Long
- Dim HKEY As Long
- Dim iData As Long
- Dim dwData As Long
- Dim abData() As Byte
- e = RegOpenKeyEx(m_hClassKey, m_sSectionKey, 0, KEY_QUERY_VALUE, HKEY)
- 'Debug.Print "e = RegOpenKeyEx(" & m_hClassKey & "," & m_sSectionKey & ", 0, KEY_QUERY_VALUE, HKEY)"
- 'ApiRaiseIf e
- e = RegQueryValueExLong(HKEY, m_sValueKey, 0&, ordType, 0&, cData)
- If e And e <> ERROR_MORE_DATA Then
- Value = m_vDefault
- Exit Property
- End If
- m_eValueType = ordType
- Select Case ordType
- Case REG_DWORD, REG_DWORD_LITTLE_ENDIAN
- e = RegQueryValueExLong(HKEY, m_sValueKey, 0&, ordType, iData, cData)
- vValue = CLng(iData)
- Case REG_DWORD_BIG_ENDIAN ' Unlikely, but you never know
- e = RegQueryValueExLong(HKEY, m_sValueKey, 0&, ordType, dwData, cData)
- vValue = SwapEndian(dwData)
- Case REG_SZ, REG_MULTI_SZ ' Same thing to Visual Basic
- sData = String$(cData - 1, 0)
- e = RegQueryValueExStr(HKEY, m_sValueKey, 0&, ordType, sData, cData)
- vValue = sData
- Case REG_EXPAND_SZ
- sData = String$(cData - 1, 0)
- e = RegQueryValueExStr(HKEY, m_sValueKey, 0&, ordType, sData, cData)
- vValue = ExpandEnvStr(sData)
- ' Catch REG_BINARY and anything else
- Case Else
- ReDim abData(cData)
- e = RegQueryValueExByte(HKEY, m_sValueKey, 0&, ordType, abData(0), cData)
- vValue = abData
- End Select
- Value = vValue
- End Property
- Public Property Let Value(ByVal vValue As Variant)
- Dim ordType As Long
- Dim c As Long
- Dim HKEY As Long
- Dim e As Long
- Dim lCreate As Long
- Dim tSA As SECURITY_ATTRIBUTES
- Dim ab() As Byte
- Dim i As Long
- Dim s As String
- Dim iPos As Long
- 'Open or Create the key
- e = RegCreateKeyEx(m_hClassKey, m_sSectionKey, 0, "", REG_OPTION_NON_VOLATILE, _
- KEY_ALL_ACCESS, tSA, HKEY, lCreate)
- If e Then
- Err.Raise 26001, _
- App.EXEName & ".clsRegistry", _
- "Failed to set registry value Key: '" & m_hClassKey & _
- "',Section: '" & m_sSectionKey & _
- "',Key: '" & m_sValueKey & _
- "' to value: '" & m_vValue & "'"
- Else
- Select Case m_eValueType
- Case REG_BINARY
- If (VarType(vValue) = vbArray + vbByte) Then
- ab = vValue
- ordType = REG_BINARY
- c = UBound(ab) - LBound(ab) - 1
- e = RegSetValueExByte(HKEY, m_sValueKey, 0&, ordType, ab(0), c)
- Else
- Err.Raise 26001
- End If
- Case REG_DWORD, REG_DWORD_BIG_ENDIAN, REG_DWORD_LITTLE_ENDIAN
- If (VarType(vValue) = vbInteger) Or (VarType(vValue) = vbLong) Then
- i = vValue
- ordType = REG_DWORD
- e = RegSetValueExLong(HKEY, m_sValueKey, 0&, ordType, i, 4)
- End If
- Case REG_SZ, REG_EXPAND_SZ
- s = vValue
- ordType = REG_SZ
- ' Assume anything with two non-adjacent percents is expanded string
- iPos = InStr(s, "%")
- If iPos Then If InStr(iPos + 2, s, "%") Then ordType = REG_EXPAND_SZ
- c = Len(s) + 1
- e = RegSetValueExStr(HKEY, m_sValueKey, 0&, ordType, s, c)
- ' User should convert to a compatible type before calling
- Case Else
- e = ERROR_INVALID_DATA
- End Select
- If Not e Then
- m_vValue = vValue
- Else
- Err.Raise vbObjectError + 1048 + 26001, _
- App.EXEName & ".clsRegistry", _
- "Failed to set registry value Key: '" & m_hClassKey & _
- "',Section: '" & m_sSectionKey & _
- "',Key: '" & m_sValueKey & _
- "' to value: '" & m_vValue & "'"
- End If
- 'Close the key
- RegCloseKey HKEY
- End If
- End Property
- Public Property Get ValueKey( _
- ) As String
- ValueKey = m_sValueKey
- End Property
- Public Property Let ValueKey(ByVal sValueKey As String)
- m_sValueKey = sValueKey
- End Property
- Public Property Get ValueType( _
- ) As ERegistryValueTypes
- ValueType = m_eValueType
- End Property
- Public Property Let ValueType(ByVal eValueType As ERegistryValueTypes)
- m_eValueType = eValueType
- End Property
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement