home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 3_2004-2005.ISO / Data / Zips / Instant_Pr1856912232005.psc / cRegistry.cls < prev    next >
Text File  |  2005-02-23  |  25KB  |  682 lines
  1. VERSION 1.0 CLASS
  2. BEGIN
  3.   MultiUse = -1  'True
  4.   Persistable = 0  'NotPersistable
  5.   DataBindingBehavior = 0  'vbNone
  6.   DataSourceBehavior  = 0  'vbNone
  7.   MTSTransactionMode  = 0  'NotAnMTSObject
  8. END
  9. Attribute VB_Name = "cRegistry"
  10. Attribute VB_GlobalNameSpace = True
  11. Attribute VB_Creatable = True
  12. Attribute VB_PredeclaredId = False
  13. Attribute VB_Exposed = False
  14. Option Explicit
  15.  
  16. ' =========================================================
  17. ' Class:    cRegistry
  18. ' Author:   Steve McMahon
  19. ' Date  :   21 Feb 1997
  20. '
  21. ' A nice class wrapper around the registry functions
  22. ' Allows searching,deletion,modification and addition
  23. ' of Keys or Values.
  24. '
  25. ' Updated 29 April 1998 for VB5.
  26. '   * Fixed GPF in EnumerateValues
  27. '   * Added support for all registry types, not just strings
  28. '   * Put all declares in local class
  29. '   * Added VB5 Enums
  30. '   * Added CreateKey and DeleteKey methods
  31. '
  32. ' Updated 2 January 1999
  33. '   * The CreateExeAssociation method failed to set up the
  34. '     association correctly if the optional document icon
  35. '     was not provided.
  36. '   * Added new parameters to CreateExeAssociation to set up
  37. '     other standard handlers: Print, Add, New
  38. '   * Provided the CreateAdditionalEXEAssociations method
  39. '     to allow non-standard menu items to be added (for example,
  40. '     right click on a .VBP file.  VB installs Run and Make
  41. '     menu items).
  42. '
  43. ' Updated 8 February 2000
  44. '   * Ensure CreateExeAssociation and related items sets up the
  45. '     registry keys in the
  46. '           HKEY_LOCAL_MACHINE\SOFTWARE\Classes
  47. '     branch as well as the HKEY_CLASSES_ROOT branch.
  48. '
  49. ' ---------------------------------------------------------------------------
  50. ' vbAccelerator - free, advanced source code for VB programmers.
  51. '     http://vbaccelerator.com
  52. ' =========================================================
  53.  
  54. 'Registry Specific Access Rights
  55. Private Const KEY_QUERY_VALUE = &H1
  56. Private Const KEY_SET_VALUE = &H2
  57. Private Const KEY_CREATE_SUB_KEY = &H4
  58. Private Const KEY_ENUMERATE_SUB_KEYS = &H8
  59. Private Const KEY_NOTIFY = &H10
  60. Private Const KEY_CREATE_LINK = &H20
  61. Private Const KEY_ALL_ACCESS = &H3F
  62.  
  63. 'Open/Create Options
  64. Private Const REG_OPTION_NON_VOLATILE = 0&
  65. Private Const REG_OPTION_VOLATILE = &H1
  66.  
  67. 'Key creation/open disposition
  68. Private Const REG_CREATED_NEW_KEY = &H1
  69. Private Const REG_OPENED_EXISTING_KEY = &H2
  70.  
  71. 'masks for the predefined standard access types
  72. Private Const STANDARD_RIGHTS_ALL = &H1F0000
  73. Private Const SPECIFIC_RIGHTS_ALL = &HFFFF
  74.  
  75. 'Define severity codes
  76. Private Const ERROR_SUCCESS = 0&
  77. Private Const ERROR_ACCESS_DENIED = 5
  78. Private Const ERROR_INVALID_DATA = 13&
  79. Private Const ERROR_MORE_DATA = 234 '  dderror
  80. Private Const ERROR_NO_MORE_ITEMS = 259
  81.  
  82.  
  83. 'Structures Needed For Registry Prototypes
  84. Private Type SECURITY_ATTRIBUTES
  85.   nLength As Long
  86.   lpSecurityDescriptor As Long
  87.   bInheritHandle As Boolean
  88. End Type
  89.  
  90. Private Type FILETIME
  91.   dwLowDateTime As Long
  92.   dwHighDateTime As Long
  93. End Type
  94.  
  95. 'Registry Function Prototypes
  96. Private Declare Function RegOpenKeyEx Lib "advapi32" Alias "RegOpenKeyExA" _
  97.   (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, _
  98.   ByVal samDesired As Long, phkResult As Long) As Long
  99.  
  100. Private Declare Function RegSetValueExStr Lib "advapi32" Alias "RegSetValueExA" _
  101.   (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, _
  102.    ByVal dwType As Long, ByVal szData As String, ByVal cbData As Long) As Long
  103. Private Declare Function RegSetValueExLong Lib "advapi32" Alias "RegSetValueExA" _
  104.   (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, _
  105.    ByVal dwType As Long, szData As Long, ByVal cbData As Long) As Long
  106. Private Declare Function RegSetValueExByte Lib "advapi32" Alias "RegSetValueExA" _
  107.   (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, _
  108.    ByVal dwType As Long, szData As Byte, ByVal cbData As Long) As Long
  109.  
  110. Private Declare Function RegCloseKey Lib "advapi32" (ByVal hKey As Long) As Long
  111.  
  112. Private Declare Function RegQueryValueExStr Lib "advapi32" Alias "RegQueryValueExA" _
  113.   (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, _
  114.    ByRef lpType As Long, ByVal szData As String, ByRef lpcbData As Long) As Long
  115. Private Declare Function RegQueryValueExLong Lib "advapi32" Alias "RegQueryValueExA" _
  116.   (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, _
  117.    ByRef lpType As Long, szData As Long, ByRef lpcbData As Long) As Long
  118. Private Declare Function RegQueryValueExByte Lib "advapi32" Alias "RegQueryValueExA" _
  119.   (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, _
  120.    ByRef lpType As Long, szData As Byte, ByRef lpcbData As Long) As Long
  121.    
  122. Private Declare Function RegCreateKeyEx Lib "advapi32" Alias "RegCreateKeyExA" _
  123.   (ByVal hKey As Long, ByVal lpSubKey As String, ByVal Reserved As Long, _
  124.    ByVal lpClass As String, ByVal dwOptions As Long, ByVal samDesired As Long, _
  125.    lpSecurityAttributes As SECURITY_ATTRIBUTES, phkResult As Long, _
  126.    lpdwDisposition As Long) As Long
  127.  
  128. Private Declare Function RegEnumKeyEx Lib "advapi32.dll" Alias "RegEnumKeyExA" _
  129.   (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpName As String, _
  130.    lpcbName As Long, ByVal lpReserved As Long, ByVal lpClass As String, _
  131.    lpcbClass As Long, lpftLastWriteTime As FILETIME) As Long
  132.  
  133. Private Declare Function RegEnumKey Lib "advapi32.dll" Alias "RegEnumKeyA" ( _
  134.     ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpName As String, _
  135.     ByVal cbName As Long) As Long
  136.  
  137. Private Declare Function RegEnumValue Lib "advapi32.dll" Alias "RegEnumValueA" _
  138.   (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpValueName As String, _
  139.    lpcbValueName As Long, ByVal lpReserved As Long, ByVal lpType As Long, _
  140.    ByVal lpData As Long, ByVal lpcbData As Long) As Long
  141.    
  142. Private Declare Function RegEnumValueLong Lib "advapi32.dll" Alias "RegEnumValueA" _
  143.   (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpValueName As String, _
  144.    lpcbValueName As Long, ByVal lpReserved As Long, lpType As Long, _
  145.    lpData As Long, lpcbData As Long) As Long
  146. Private Declare Function RegEnumValueStr Lib "advapi32.dll" Alias "RegEnumValueA" _
  147.   (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpValueName As String, _
  148.    lpcbValueName As Long, ByVal lpReserved As Long, lpType As Long, _
  149.    ByVal lpData As String, lpcbData As Long) As Long
  150. Private Declare Function RegEnumValueByte Lib "advapi32.dll" Alias "RegEnumValueA" _
  151.   (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpValueName As String, _
  152.    lpcbValueName As Long, ByVal lpReserved As Long, lpType As Long, _
  153.    lpData As Byte, lpcbData As Long) As Long
  154.  
  155. Private Declare Function RegQueryInfoKey Lib "advapi32.dll" Alias "RegQueryInfoKeyA" _
  156.    (ByVal hKey As Long, ByVal lpClass As String, _
  157.    lpcbClass As Long, ByVal lpReserved As Long, lpcSubKeys As Long, _
  158.    lpcbMaxSubKeyLen As Long, lpcbMaxClassLen As Long, lpcValues As Long, _
  159.    lpcbMaxValueNameLen As Long, lpcbMaxValueLen As Long, lpcbSecurityDescriptor As Long, _
  160.    lpftLastWriteTime As Any) As Long
  161.  
  162. Private Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" _
  163.   (ByVal hKey As Long, ByVal lpSubKey As String) As Long
  164.  
  165. Private Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" _
  166.   (ByVal hKey As Long, ByVal lpValueName As String) As Long
  167.  
  168. ' Other declares:
  169. Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
  170.     lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)
  171. Private Declare Function ExpandEnvironmentStrings Lib "kernel32" Alias "ExpandEnvironmentStringsA" (ByVal lpSrc As String, ByVal lpDst As String, ByVal nSize As Long) As Long
  172.  
  173.  
  174. Public Enum ERegistryClassConstants
  175.     HKEY_CLASSES_ROOT = &H80000000
  176.     HKEY_CURRENT_USER = &H80000001
  177.     HKEY_LOCAL_MACHINE = &H80000002
  178.     HKEY_USERS = &H80000003
  179. End Enum
  180.  
  181. Public Enum ERegistryValueTypes
  182. 'Predefined Value Types
  183.     REG_NONE = (0)                         'No value type
  184.     REG_SZ = (1)                           'Unicode nul terminated string
  185.     REG_EXPAND_SZ = (2)                    'Unicode nul terminated string w/enviornment var
  186.     REG_BINARY = (3)                       'Free form binary
  187.     REG_DWORD = (4)                        '32-bit number
  188.     REG_DWORD_LITTLE_ENDIAN = (4)          '32-bit number (same as REG_DWORD)
  189.     REG_DWORD_BIG_ENDIAN = (5)             '32-bit number
  190.     REG_LINK = (6)                         'Symbolic Link (unicode)
  191.     REG_MULTI_SZ = (7)                     'Multiple Unicode strings
  192.     REG_RESOURCE_LIST = (8)                'Resource list in the resource map
  193.     REG_FULL_RESOURCE_DESCRIPTOR = (9)     'Resource list in the hardware description
  194.     REG_RESOURCE_REQUIREMENTS_LIST = (10)
  195. End Enum
  196.  
  197. Private m_hClassKey As Long
  198. Private m_sSectionKey As String
  199. Private m_sValueKey As String
  200. Private m_vValue As Variant
  201. Private m_sSetValue As String
  202. Private m_vDefault As Variant
  203. Private m_eValueType As ERegistryValueTypes
  204.  
  205. Public Property Get KeyExists() As Boolean
  206.     'KeyExists = bCheckKeyExists( _
  207.     '                m_hClassKey, _
  208.     '                m_sSectionKey _
  209.     '            )
  210. Dim hKey As Long
  211.     If RegOpenKeyEx(m_hClassKey, m_sSectionKey, 0, 1, hKey) = ERROR_SUCCESS Then
  212.         KeyExists = True
  213.         RegCloseKey hKey
  214.     Else
  215.         KeyExists = False
  216.     End If
  217.     
  218. End Property
  219. Public Function CreateKey() As Boolean
  220. Dim tSA As SECURITY_ATTRIBUTES
  221. Dim hKey As Long
  222. Dim lCreate As Long
  223. Dim e As Long
  224.  
  225.     'Open or Create the key
  226.     e = RegCreateKeyEx(m_hClassKey, m_sSectionKey, 0, "", REG_OPTION_NON_VOLATILE, _
  227.                  KEY_ALL_ACCESS, tSA, hKey, lCreate)
  228.     If e Then
  229.         Err.Raise 26001, App.EXEName & ".cRegistry", "Failed to create registry Key: '" & m_sSectionKey
  230.     Else
  231.         CreateKey = (e = ERROR_SUCCESS)
  232.         'Close the key
  233.         RegCloseKey hKey
  234.     End If
  235. End Function
  236. Public Function DeleteKey() As Boolean
  237. Dim e As Long
  238.     e = RegDeleteKey(m_hClassKey, m_sSectionKey)
  239.     If e Then
  240.         Err.Raise 26001, App.EXEName & ".cRegistry", "Failed to delete registry Key: '" & m_hClassKey & "',Section: '" & m_sSectionKey
  241.     Else
  242.         DeleteKey = (e = ERROR_SUCCESS)
  243.     End If
  244.     
  245. End Function
  246. Public Function DeleteValue() As Boolean
  247. Dim e As Long
  248. Dim hKey As Long
  249.  
  250.     e = RegOpenKeyEx(m_hClassKey, m_sSectionKey, 0, KEY_ALL_ACCESS, hKey)
  251.     If e Then
  252.         Err.Raise 26001, App.EXEName & ".cRegistry", "Failed to open key '" & m_hClassKey & "',Section: '" & m_sSectionKey & "' for delete access"
  253.     Else
  254.         e = RegDeleteValue(hKey, m_sValueKey)
  255.         If e Then
  256.             Err.Raise 26001, App.EXEName & ".cRegistry", "Failed to delete registry Key: '" & m_hClassKey & "',Section: '" & m_sSectionKey & "',Key: '" & m_sValueKey
  257.         Else
  258.             DeleteValue = (e = ERROR_SUCCESS)
  259.         End If
  260.     End If
  261.  
  262. End Function
  263. Public Property Get Value() As Variant
  264. Dim vValue As Variant
  265. Dim cData As Long, sData As String, ordType As Long, e As Long
  266. Dim hKey As Long
  267.  
  268.     e = RegOpenKeyEx(m_hClassKey, m_sSectionKey, 0, KEY_QUERY_VALUE, hKey)
  269.     'ApiRaiseIfáe
  270.  
  271.     e = RegQueryValueExLong(hKey, m_sValueKey, 0&, ordType, 0&, cData)
  272.     If e And e <> ERROR_MORE_DATA Then
  273.         Value = m_vDefault
  274.         Exit Property
  275.     End If
  276.     
  277.     m_eValueType = ordType
  278.     Select Case ordType
  279.     Case REG_DWORD, REG_DWORD_LITTLE_ENDIAN
  280.         Dim iData As Long
  281.         e = RegQueryValueExLong(hKey, m_sValueKey, 0&, _
  282.                                ordType, iData, cData)
  283.         vValue = CLng(iData)
  284.         
  285.     Case REG_DWORD_BIG_ENDIAN  ' Unlikely, but you never know
  286.         Dim dwData As Long
  287.         e = RegQueryValueExLong(hKey, m_sValueKey, 0&, _
  288.                                ordType, dwData, cData)
  289.         vValue = SwapEndian(dwData)
  290.         
  291.     Case REG_SZ, REG_MULTI_SZ ' Same thing to Visual Basic
  292.         sData = String$(cData - 1, 0)
  293.         e = RegQueryValueExStr(hKey, m_sValueKey, 0&, _
  294.                                ordType, sData, cData)
  295.         vValue = sData
  296.         
  297.     Case REG_EXPAND_SZ
  298.         sData = String$(cData - 1, 0)
  299.         e = RegQueryValueExStr(hKey, m_sValueKey, 0&, _
  300.                                ordType, sData, cData)
  301.         vValue = ExpandEnvStr(sData)
  302.         
  303.     ' Catch REG_BINARY and anything else
  304.     Case Else
  305.         Dim abData() As Byte
  306.         ReDim abData(cData)
  307.         e = RegQueryValueExByte(hKey, m_sValueKey, 0&, _
  308.                                 ordType, abData(0), cData)
  309.         vValue = abData
  310.         
  311.     End Select
  312.     Value = vValue
  313.     
  314. End Property
  315. Public Property Let Value( _
  316.         ByVal vValue As Variant _
  317.     )
  318. Dim ordType As Long
  319. Dim c As Long
  320. Dim hKey As Long
  321. Dim e As Long
  322. Dim lCreate As Long
  323. Dim tSA As SECURITY_ATTRIBUTES
  324.  
  325.     'Open or Create the key
  326.     e = RegCreateKeyEx(m_hClassKey, m_sSectionKey, 0, "", REG_OPTION_NON_VOLATILE, _
  327.                  KEY_ALL_ACCESS, tSA, hKey, lCreate)
  328.     
  329.     If e Then
  330.         Err.Raise 26001, App.EXEName & ".cRegistry", "Failed to set registry value Key: '" & m_hClassKey & "',Section: '" & m_sSectionKey & "',Key: '" & m_sValueKey & "' to value: '" & m_vValue & "'"
  331.     Else
  332.  
  333.         Select Case m_eValueType
  334.         Case REG_BINARY
  335.             If (VarType(vValue) = vbArray + vbByte) Then
  336.                 Dim ab() As Byte
  337.                 ab = vValue
  338.                 ordType = REG_BINARY
  339.                 c = UBound(ab) - LBound(ab) - 1
  340.                 e = RegSetValueExByte(hKey, m_sValueKey, 0&, ordType, ab(0), c)
  341.             Else
  342.                 Err.Raise 26001
  343.             End If
  344.         Case REG_DWORD, REG_DWORD_BIG_ENDIAN, REG_DWORD_LITTLE_ENDIAN
  345.             If (VarType(vValue) = vbInteger) Or (VarType(vValue) = vbLong) Then
  346.                 Dim i As Long
  347.                 i = vValue
  348.                 ordType = REG_DWORD
  349.                 e = RegSetValueExLong(hKey, m_sValueKey, 0&, ordType, i, 4)
  350.             End If
  351.         Case REG_SZ, REG_EXPAND_SZ
  352.             Dim s As String, iPos As Long
  353.             s = vValue
  354.             ordType = REG_SZ
  355.             ' Assume anything with two non-adjacent percents is expanded string
  356.             iPos = InStr(s, "%")
  357.             If iPos Then
  358.                 If InStr(iPos + 2, s, "%") Then ordType = REG_EXPAND_SZ
  359.             End If
  360.             c = Len(s) + 1
  361.             e = RegSetValueExStr(hKey, m_sValueKey, 0&, ordType, s, c)
  362.             
  363.         ' User should convert to a compatible type before calling
  364.         Case Else
  365.             e = ERROR_INVALID_DATA
  366.             
  367.         End Select
  368.         
  369.         If Not e Then
  370.             m_vValue = vValue
  371.         Else
  372.             Err.Raise vbObjectError + 1048 + 26001, App.EXEName & ".cRegistry", "Failed to set registry value Key: '" & m_hClassKey & "',Section: '" & m_sSectionKey & "',Key: '" & m_sValueKey & "' to value: '" & m_vValue & "'"
  373.         End If
  374.         
  375.         'Close the key
  376.         RegCloseKey hKey
  377.     
  378.     End If
  379.     
  380. End Property
  381. Public Function EnumerateValues( _
  382.         ByRef sKeyNames() As String, _
  383.         ByRef iKeyCount As Long _
  384.     ) As Boolean
  385. Dim lResult As Long
  386. Dim hKey As Long
  387. Dim sName As String
  388. Dim lNameSize As Long
  389. Dim sData As String
  390. Dim lIndex As Long
  391. Dim cJunk As Long
  392. Dim cNameMax As Long
  393. Dim ft As Currency
  394.    
  395.    ' Log "EnterEnumerateValues"
  396.  
  397.    iKeyCount = 0
  398.    Erase sKeyNames()
  399.     
  400.    lIndex = 0
  401.    lResult = RegOpenKeyEx(m_hClassKey, m_sSectionKey, 0, KEY_QUERY_VALUE, hKey)
  402.    If (lResult = ERROR_SUCCESS) Then
  403.       ' Log "OpenedKey:" & m_hClassKey & "," & m_sSectionKey
  404.       lResult = RegQueryInfoKey(hKey, "", cJunk, 0, _
  405.                                cJunk, cJunk, cJunk, cJunk, _
  406.                                cNameMax, cJunk, cJunk, ft)
  407.        Do While lResult = ERROR_SUCCESS
  408.    
  409.            'Set buffer space
  410.            lNameSize = cNameMax + 1
  411.            sName = String$(lNameSize, 0)
  412.            If (lNameSize = 0) Then lNameSize = 1
  413.            
  414.            ' Log "Requesting Next Value"
  415.          
  416.            'Get value name:
  417.            lResult = RegEnumValue(hKey, lIndex, sName, lNameSize, _
  418.                                   0&, 0&, 0&, 0&)
  419.            ' Log "RegEnumValue returned:" & lResult
  420.            If (lResult = ERROR_SUCCESS) Then
  421.        
  422.                 ' Although in theory you can also retrieve the actual
  423.                 ' value and type here, I found it always (ultimately) resulted in
  424.                 ' a GPF, on Win95 and NT.  Why?  Can anyone help?
  425.        
  426.                sName = Left$(sName, lNameSize)
  427.                ' Log "Enumerated value:" & sName
  428.                  
  429.                iKeyCount = iKeyCount + 1
  430.                ReDim Preserve sKeyNames(1 To iKeyCount) As String
  431.                sKeyNames(iKeyCount) = sName
  432.            End If
  433.            lIndex = lIndex + 1
  434.        Loop
  435.    End If
  436.    If (hKey <> 0) Then
  437.       RegCloseKey hKey
  438.    End If
  439.  
  440.    ' Log "Exit Enumerate Values"
  441.    EnumerateValues = True
  442.    Exit Function
  443.    
  444. EnumerateValuesError:
  445.    If (hKey <> 0) Then
  446.       RegCloseKey hKey
  447.    End If
  448.    Err.Raise vbObjectError + 1048 + 26003, App.EXEName & ".cRegistry", Err.Description
  449.    Exit Function
  450.  
  451. End Function
  452. Public Function EnumerateSections( _
  453.         ByRef sSect() As String, _
  454.         ByRef iSectCount As Long _
  455.     ) As Boolean
  456. Dim lResult As Long
  457. Dim hKey As Long
  458. Dim dwReserved As Long
  459. Dim szBuffer As String
  460. Dim lBuffSize As Long
  461. Dim lIndex As Long
  462. Dim lType As Long
  463. Dim sCompKey As String
  464. Dim iPos As Long
  465.  
  466. On Error GoTo EnumerateSectionsError
  467.  
  468.    iSectCount = 0
  469.    Erase sSect
  470. '
  471.    lIndex = 0
  472.  
  473.    lResult = RegOpenKeyEx(m_hClassKey, m_sSectionKey, 0, KEY_ENUMERATE_SUB_KEYS, hKey)
  474.    Do While lResult = ERROR_SUCCESS
  475.        'Set buffer space
  476.        szBuffer = String$(255, 0)
  477.        lBuffSize = Len(szBuffer)
  478.       
  479.       'Get next value
  480.        lResult = RegEnumKey(hKey, lIndex, szBuffer, lBuffSize)
  481.                              
  482.        If (lResult = ERROR_SUCCESS) Then
  483.            iSectCount = iSectCount + 1
  484.            ReDim Preserve sSect(1 To iSectCount) As String
  485.            iPos = InStr(szBuffer, Chr$(0))
  486.            If (iPos > 0) Then
  487.               sSect(iSectCount) = Left(szBuffer, iPos - 1)
  488.            Else
  489.               sSect(iSectCount) = Left(szBuffer, lBuffSize)
  490.            End If
  491.        End If
  492.        
  493.        lIndex = lIndex + 1
  494.    Loop
  495.    If (hKey <> 0) Then
  496.       RegCloseKey hKey
  497.    End If
  498.    EnumerateSections = True
  499.    Exit Function
  500.  
  501. EnumerateSectionsError:
  502.    If (hKey <> 0) Then
  503.       RegCloseKey hKey
  504.    End If
  505.    Err.Raise vbObjectError + 1048 + 26002, App.EXEName & ".cRegistry", Err.Description
  506.    Exit Function
  507. End Function
  508. Private Sub pSetClassValue(ByVal sValue As String)
  509. Dim sSection As String
  510.    ClassKey = HKEY_CLASSES_ROOT
  511.    Value = sValue
  512.    sSection = SectionKey
  513.    ClassKey = HKEY_LOCAL_MACHINE
  514.    SectionKey = "SOFTWARE\Classes\" & sSection
  515.    Value = sValue
  516.    SectionKey = sSection
  517. End Sub
  518. Public Sub CreateEXEAssociation( _
  519.         ByVal sExePath As String, _
  520.         ByVal sClassName As String, _
  521.         ByVal sClassDescription As String, _
  522.         ByVal sAssociation As String, _
  523.         Optional ByVal sOpenMenuText As String = "&Open", _
  524.         Optional ByVal bSupportPrint As Boolean = False, _
  525.         Optional ByVal sPrintMenuText As String = "&Print", _
  526.         Optional ByVal bSupportNew As Boolean = False, _
  527.         Optional ByVal sNewMenuText As String = "&New", _
  528.         Optional ByVal bSupportInstall As Boolean = False, _
  529.         Optional ByVal sInstallMenuText As String = "", _
  530.         Optional ByVal lDefaultIconIndex As Long = -1 _
  531.     )
  532.    ' Check if path is wrapped in quotes:
  533.    sExePath = Trim$(sExePath)
  534.    If (Left$(sExePath, 1) <> """") Then
  535.       sExePath = """" & sExePath
  536.    End If
  537.    If (Right$(sExePath, 1) <> """") Then
  538.       sExePath = sExePath & """"
  539.    End If
  540.     
  541.     ' Create the .File to Class association:
  542.    SectionKey = "." & sAssociation
  543.    ValueType = REG_SZ
  544.    ValueKey = ""
  545.    pSetClassValue sClassName
  546.    
  547.    ' Create the Class shell open command:
  548.    SectionKey = sClassName
  549.    pSetClassValue sClassDescription
  550.    
  551.    SectionKey = sClassName & "\shell\open"
  552.    If (sOpenMenuText = "") Then sOpenMenuText = "&Open"
  553.    ValueKey = ""
  554.    pSetClassValue sOpenMenuText
  555.    SectionKey = sClassName & "\shell\open\command"
  556.    ValueKey = ""
  557.    pSetClassValue sExePath & " ""%1"""
  558.    
  559.    If (bSupportPrint) Then
  560.       SectionKey = sClassName & "\shell\print"
  561.       If (sPrintMenuText = "") Then sPrintMenuText = "&Print"
  562.       ValueKey = ""
  563.       pSetClassValue sPrintMenuText
  564.       SectionKey = sClassName & "\shell\print\command"
  565.       ValueKey = ""
  566.       pSetClassValue sExePath & " /p ""%1"""
  567.    End If
  568.    
  569.    If (bSupportInstall) Then
  570.       If (sInstallMenuText = "") Then
  571.          sInstallMenuText = "&Install " & sAssociation
  572.       End If
  573.       SectionKey = sClassName & "\shell\add"
  574.       ValueKey = ""
  575.       pSetClassValue sInstallMenuText
  576.       SectionKey = sClassName & "\shell\add\command"
  577.       ValueKey = ""
  578.       pSetClassValue sExePath & " /a ""%1"""
  579.    End If
  580.    
  581.    If (bSupportNew) Then
  582.       SectionKey = sClassName & "\shell\new"
  583.       ValueKey = ""
  584.       If (sNewMenuText = "") Then sNewMenuText = "&New"
  585.       pSetClassValue sNewMenuText
  586.       SectionKey = sClassName & "\shell\new\command"
  587.       ValueKey = ""
  588.       pSetClassValue sExePath & " /n ""%1"""
  589.    End If
  590.    
  591.    If lDefaultIconIndex > -1 Then
  592.       SectionKey = sClassName & "\DefaultIcon"
  593.       ValueKey = ""
  594.       pSetClassValue sExePath & "," & CStr(lDefaultIconIndex)
  595.    End If
  596.     
  597. End Sub
  598. Public Sub CreateAdditionalEXEAssociations( _
  599.       ByVal sClassName As String, _
  600.       ParamArray vItems() As Variant _
  601.    )
  602. Dim iItems As Long
  603. Dim iItem As Long
  604.    
  605.    On Error Resume Next
  606.    iItems = UBound(vItems) + 1
  607.    If (iItems Mod 3) <> 0 Or (Err.Number <> 0) Then
  608.       Err.Raise vbObjectError + 1048 + 26004, App.EXEName & ".cRegistry", "Invalid parameter list passed to CreateAdditionalEXEAssociations - expected Name/Text/Command"
  609.    Else
  610.       ' Check if it exists:
  611.       SectionKey = sClassName
  612.       If Not (KeyExists) Then
  613.          Err.Raise vbObjectError + 1048 + 26005, App.EXEName & ".cRegistry", "Error - attempt to create additional associations before class defined."
  614.       Else
  615.          For iItem = 0 To iItems - 1 Step 3
  616.             ValueType = REG_SZ
  617.             SectionKey = sClassName & "\shell\" & vItems(iItem)
  618.             ValueKey = ""
  619.             pSetClassValue vItems(iItem + 1)
  620.             SectionKey = sClassName & "\shell\" & vItems(iItem) & "\command"
  621.             ValueKey = ""
  622.             pSetClassValue vItems(iItem + 2)
  623.          Next iItem
  624.       End If
  625.    End If
  626.    
  627. End Sub
  628. Public Property Get ValueType() As ERegistryValueTypes
  629.     ValueType = m_eValueType
  630. End Property
  631. Public Property Let ValueType(ByVal eValueType As ERegistryValueTypes)
  632.     m_eValueType = eValueType
  633. End Property
  634. Public Property Get ClassKey() As ERegistryClassConstants
  635.     ClassKey = m_hClassKey
  636. End Property
  637. Public Property Let ClassKey( _
  638.         ByVal eKey As ERegistryClassConstants _
  639.     )
  640.     m_hClassKey = eKey
  641. End Property
  642. Public Property Get SectionKey() As String
  643.     SectionKey = m_sSectionKey
  644. End Property
  645. Public Property Let SectionKey( _
  646.         ByVal sSectionKey As String _
  647.     )
  648.     m_sSectionKey = sSectionKey
  649. End Property
  650. Public Property Get ValueKey() As String
  651.     ValueKey = m_sValueKey
  652. End Property
  653. Public Property Let ValueKey( _
  654.         ByVal sValueKey As String _
  655.     )
  656.     m_sValueKey = sValueKey
  657. End Property
  658. Public Property Get Default() As Variant
  659.     Default = m_vDefault
  660. End Property
  661. Public Property Let Default( _
  662.         ByVal vDefault As Variant _
  663.     )
  664.     m_vDefault = vDefault
  665. End Property
  666. Private Function SwapEndian(ByVal dw As Long) As Long
  667.     CopyMemory ByVal VarPtr(SwapEndian) + 3, dw, 1
  668.     CopyMemory ByVal VarPtr(SwapEndian) + 2, ByVal VarPtr(dw) + 1, 1
  669.     CopyMemory ByVal VarPtr(SwapEndian) + 1, ByVal VarPtr(dw) + 2, 1
  670.     CopyMemory SwapEndian, ByVal VarPtr(dw) + 3, 1
  671. End Function
  672. Private Function ExpandEnvStr(sData As String) As String
  673.     Dim c As Long, s As String
  674.     ' Get the length
  675.     s = "" ' Needed to get around Windows 95 limitation
  676.     c = ExpandEnvironmentStrings(sData, s, c)
  677.     ' Expand the string
  678.     s = String$(c - 1, 0)
  679.     c = ExpandEnvironmentStrings(sData, s, c)
  680.     ExpandEnvStr = s
  681. End Function
  682.