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 ' Private priv_strKey As String Private priv_bAutocreate As Boolean Private priv_bKeyExists As Boolean ' Public Enum regTypes REG_NONE = 0 REG_SZ = 1 REG_EXPAND_SZ = 2 REG_BINARY = 3 REG_DWORD = 4 End Enum ' Public Enum regErrors ERR_INVALID_KEY = vbObjectError + 512 + 2 ERR_UNKNOWN_ROOT = vbObjectError + 512 + 3 ERR_OPEN_FAIL = vbObjectError + 512 + 4 ERR_NOCREATION = vbObjectError + 512 + 5 ERR_NOLETPROPERTY = vbObjectError + 512 + 7 ERR_READ_FAIL = vbObjectError + 512 + 8 ERR_BINDATA = vbObjectError + 512 + 12 ERR_CREATE_FAIL = vbObjectError + 512 + 15 End Enum ' 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 ' Private Const MAX_SIZE = 2048 ' Private Const HKEY_CLASSES_ROOT = &H80000000 Private Const HKEY_CURRENT_USER = &H80000001 Private Const HKEY_LOCAL_MACHINE = &H80000002 Private Const HKEY_USERS = &H80000003 Private Const HKEY_CURRENT_CONFIG = &H80000005 Private Const HKEY_DYN_DATA = &H80000006 ' Private Const ERROR_SUCCESS = 0& Private Const ERROR_MORE_DATA = 234 Private Const ERROR_NO_MORE_ITEMS = 259& ' Private Const REG_OPTION_NON_VOLATILE = 0 Private Const REG_CREATED_NEW_KEY = &H1 Private Const REG_OPENED_EXISTING_KEY = &H2 ' 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_ALL_ACCESS = &HF003F ' 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, _ lpType As Long, lpData As Any, lpcbData As Long) As Long Private Declare Function RegDeleteValue Lib "advapi32.dll" _ Alias "RegDeleteValueA" _ (ByVal hKey As Long, ByVal lpValueName As String) _ As Long Private Declare Function RegDeleteKey Lib "advapi32.dll" _ Alias "RegDeleteKeyA" _ (ByVal hKey As Long, ByVal lpSubKey As String) As Long Private Declare Function RegOpenKeyEx Lib "advapi32.dll" _ 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 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 Private Declare Function RegQueryValueEx Lib "advapi32.dll" _ Alias "RegQueryValueExA" _ (ByVal hKey As Long, ByVal lpszValueName As String, _ ByVal lpdwReserved As Long, lpdwType As Long, _ lpData As Any, lpcbData As Long) As Long Private Declare Function RegSetValueEx Lib "advapi32.dll" _ Alias "RegSetValueExA" _ (ByVal hKey As Long, ByVal lpValueName As String, _ ByVal Reserved As Long, ByVal dwType As Long, _ lpData As Any, ByVal cbData 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 RegCloseKey Lib "advapi32.dll" _ (ByVal hKey As Long) As Long Public Function delKey() As Long Dim lngPos As Long Dim strParent As String Dim strChild As String Dim lngHdle As Long Dim boolKeyDel As Boolean ' 116 Key = priv_strKey 117 If Right(Key, 1) = "\" Then 'Unterschlüsel löschen 119 Key = Left(Key, Len(Key) - 1) 120 If Right(Key, 1) = "\" Then err.Raise ERR_INVALID_KEY, "delKey", "Ungültiger Schlüssel!" 121 boolKeyDel = True 122 Else 'Wert löschen 124 boolKeyDel = False 125 End If 127 lngPos = InStrRev(Key, "\") 128 If lngPos = 0 Then 129 err.Raise ERR_INVALID_KEY, "delKey", "Ungültiger Schlüssel!" 130 End If 132 strParent = Left(Key, lngPos - 1) 133 strChild = Mid(Key, lngPos + 1) 134 lngHdle = OpenKey(strParent) 135 If boolKeyDel Then 'Schlüssel löschen 137 delKey = RegDeleteKey(lngHdle, strChild) 138 Else 'Wert löschen 140 delKey = RegDeleteValue(lngHdle, strChild) 141 End If End Function Public Function regEnum() As Collection Dim collKeyList As New Collection Dim lngHdle As Long Dim strStore As String Dim lngResult As Long Dim lngIdx As Long Dim lngStoreSize As Long Dim LastWriteTime As FILETIME 153 Key = priv_strKey 154 lngIdx = 0 155 If Right(Key, 1) = "\" Then 'Schlüssel aufzählen 157 lngHdle = OpenKey(Key) 158 Do 159 strStore = Space(MAX_SIZE) 160 lngStoreSize = MAX_SIZE 161 lngResult = RegEnumKeyEx(lngHdle, lngIdx, strStore, lngStoreSize, 0&, 0&, 0&, LastWriteTime) 162 If lngResult <> ERROR_NO_MORE_ITEMS Then 163 collKeyList.ADD Left(strStore, lngStoreSize) 164 lngIdx = lngIdx + 1 165 End If 166 Loop Until lngResult = ERROR_NO_MORE_ITEMS 168 Else 'Werte aufzählen 170 lngHdle = OpenKey(Key) 171 Do 172 strStore = Space(MAX_SIZE) 173 lngStoreSize = MAX_SIZE 174 lngResult = RegEnumValue(lngHdle, lngIdx, strStore, lngStoreSize, ByVal 0&, ByVal 0&, ByVal 0&, ByVal 0&) 175 If lngResult <> ERROR_NO_MORE_ITEMS Then 176 collKeyList.ADD Left(strStore, lngStoreSize) 177 lngIdx = lngIdx + 1 178 End If 179 Loop While lngResult <> ERROR_NO_MORE_ITEMS 181 End If 182 Call RegCloseKey(lngHdle) 183 Set regEnum = collKeyList End Function Public Function getValue() As Variant Dim lngLength As Long Dim strMain As String Dim strSub As String Dim lngPos As Long Dim lngHdle As Long Dim lngResult As Long Dim strStore As String Dim lngDataVal As Long Dim lngType As Long Dim lngZ As Long Dim intCode As Integer 199 Key = priv_strKey 'Schlüssel splitten 201 lngPos = InStrRev(Key, "\") 202 If lngPos = 0 Then 203 err.Raise ERR_INVALID_KEY, "getValue", "Ungültiger Schlüssel: """ & Key & """" 204 End If 205 strMain = Left(Key, lngPos - 1) 206 strSub = Mid(Key, lngPos + 1) 207 lngHdle = OpenKey(strMain) 208 lngResult = RegQueryValueEx(lngHdle, strSub, 0, lngType, "", lngLength) 210 If lngResult = ERROR_MORE_DATA Then 211 If lngType = regTypes.REG_SZ Or lngType = regTypes.REG_EXPAND_SZ Then 212 strStore = Space(lngLength) 213 lngResult = RegQueryValueEx(lngHdle, strSub, 0, lngType, ByVal strStore, lngLength) 214 If lngLength = 0 Then 215 strStore = "" 216 Else 217 strStore = Left(strStore, lngLength - 1) 218 End If 219 ElseIf lngType = regTypes.REG_BINARY Then 220 ReDim bytearray(lngLength) As Byte 221 lngResult = RegQueryValueEx(lngHdle, strSub, 0, lngType, bytearray(0), lngLength) 222 For lngZ = 1 To lngLength 223 intCode = bytearray(lngZ - 1) 224 getValue = getValue & Right("0" & Hex(intCode), 2) & " " 225 Next 226 strStore = Trim(getValue) 227 ElseIf lngType = regTypes.REG_DWORD Then 228 lngResult = RegQueryValueEx(lngHdle, strSub, 0, lngType, lngDataVal, 4) 229 strStore = CStr(lngDataVal) 230 End If 231 End If 232 If lngResult = ERROR_SUCCESS Then 233 getValue = strStore 234 Else 235 err.Raise ERR_READ_FAIL, "getValue", "Kann Schlüssel nicht lesen """ & Key & """" 236 End If 237 Call RegCloseKey(lngHdle) End Function Public Function setValue(ByVal strStore As String, Optional ByVal regType As Long = regTypes.REG_SZ) As Boolean Dim strMain As String Dim strValname As String Dim lngPos As Long Dim lngHdle As Long Dim lngLength As Long Dim lngResult As Long Dim lngCount As Long Dim strChar As String Dim strVals As String Dim X As Long Dim strSngle As String Dim intSngle As Integer Dim lngData As Long Dim strRoot As String Dim strNewkey As String Dim lngTempHdle As Long Dim secAttribs As SECURITY_ATTRIBUTES Dim lngDispo As Long Dim strAnsi As String 261 Key = priv_strKey 262 lngPos = InStrRev(Key, "\") 263 If lngPos = 0 Then 264 err.Raise ERR_INVALID_KEY, "getValue", "Ungültiger Schlüssel: """ & Key & """" 265 End If 266 strMain = Left(Key, lngPos - 1) 267 strValname = Mid(Key, lngPos + 1) 269 If InStr(strMain, "\") = 0 Then 'Hauptschlüssel 271 lngHdle = OpenKey(strMain) 272 Else 'Benannter Schlüssel, eventuell anlegen 274 If Me.KeyExists = False And Me.autoCreate = False Then 275 err.Raise ERR_NOCREATION, "setValue", "Schlüssel wird nicht angelegt" 276 End If ' 278 lngPos = InStr(strMain, "\") 279 strRoot = Left(strMain, lngPos - 1) 280 strNewkey = Mid(strMain, lngPos + 1) 281 lngTempHdle = OpenKey(strRoot) 282 lngResult = RegCreateKeyEx(lngTempHdle, strNewkey, 0, "", REG_OPTION_NON_VOLATILE, KEY_CREATE_SUB_KEY Or KEY_SET_VALUE, secAttribs, lngHdle, lngDispo) 283 End If 285 If lngHdle = 0 Then 286 err.Raise ERR_CREATE_FAIL, "setValue", "Fehler beim Erstellen/Zugriff auf Schlüssel """ & Key & """ Error #: " & lngResult 287 End If 289 Select Case regType Case regTypes.REG_SZ 291 lngLength = Len(strStore) + 1 292 lngResult = RegSetValueEx(lngHdle, strValname, 0, REG_SZ, ByVal strStore, lngLength) Case regTypes.REG_BINARY 294 strStore = Trim(strStore) & " " 295 lngCount = 0 296 strVals = "" 297 strChar = "" 298 For X = 1 To Len(strStore) 299 strSngle = Mid(strStore, X, 1) 300 If strSngle = " " Then 301 intSngle = Fix("&H" & strChar) 302 If intSngle > 255 Then 303 err.Raise ERR_BINDATA, "setValue", "Ungültige Binärzahl (größer als 255): """ & strStore & """" 304 End If 305 strVals = strVals & Chr(intSngle) 306 lngCount = lngCount + 1 307 strChar = "" 308 Else 309 strChar = strChar & strSngle 310 End If 311 Next 313 strAnsi = StrConv(strVals, vbFromUnicode) 314 lngResult = RegSetValueEx(lngHdle, strValname, 0, REG_BINARY, ByVal StrPtr(strAnsi), lngCount) Case regTypes.REG_DWORD 317 lngLength = 4 318 lngData = CLng(strStore) 319 lngResult = RegSetValueEx(lngHdle, strValname, 0, REG_DWORD, lngData, lngLength) 320 End Select 321 Call RegCloseKey(lngHdle) 322 If lngResult = ERROR_SUCCESS Then 323 setValue = True 324 Else 325 setValue = False 326 End If End Function Private Function getRoot(ByVal Key As String) As Long 330 Select Case UCase(Key) Case "HKCU", "HKEY_CURRENT_USER" 332 getRoot = HKEY_CURRENT_USER Case "HKLM", "HKEY_LOCAL_MACHINE" 334 getRoot = HKEY_LOCAL_MACHINE Case "HKU", "HKEY_USERS" 336 getRoot = HKEY_USERS Case "HKDD", "HKEY_DYN_DATA" 338 getRoot = HKEY_DYN_DATA Case "HKCC", "HKEY_CURRENT_CONFIG" 340 getRoot = HKEY_CURRENT_CONFIG Case "HKCR", "HKEY_CLASSES_ROOT" 342 getRoot = HKEY_CLASSES_ROOT Case Else 344 err.Raise ERR_UNKNOWN_ROOT, "getRoot", "Unbekannter Hauptschlüssel: """ & Key & """" 345 End Select End Function Private Function OpenKey(ByVal Key As String) As Long Dim lngPos As Long Dim strMain As String Dim strSub As String Dim lngResult As Long 354 lngPos = InStr(Key, "\") 355 If lngPos = 0 Then 'Hauptschlüssel 357 OpenKey = getRoot(Key) 358 Else 359 strMain = Left(Key, lngPos - 1) 360 strSub = Mid(Key, lngPos + 1) 361 lngResult = RegOpenKeyEx(getRoot(strMain), strSub, 0, KEY_ALL_ACCESS, OpenKey) 362 If lngResult <> ERROR_SUCCESS Then 363 err.Raise ERR_OPEN_FAIL, "OpenKey", "Kann Schlüssel nicht öffnen """ & Key & """, Error # " & lngResult 364 End If 365 End If End Function Public Property Get Key() As String 369 Key = priv_strKey End Property Public Property Let Key(k As String) 373 If k = vbNullString Or k = "\" Then 374 err.Raise ERR_INVALID_KEY, "Let Key", "Ungültiger Schlüssel" 375 Else 376 priv_strKey = k 377 End If End Property Public Property Get autoCreate() As Boolean 380 autoCreate = priv_bAutocreate End Property Public Property Let autoCreate(b As Boolean) 384 priv_bAutocreate = b End Property Private Sub Class_Initialize() 388 priv_bAutocreate = True End Sub Public Property Get KeyExists() As Boolean Dim lngHdle As Long ' 394 On Error Resume Next 395 Key = priv_strKey 396 If Right(Key, 1) = "\" Then 'Schlüssel 398 lngHdle = OpenKey(Key) 399 priv_bKeyExists = Not (lngHdle = 0) 400 err.Clear 401 If Not lngHdle = 0 Then RegCloseKey (lngHdle) 402 Else 'Wert 404 On Error Resume Next 405 Call getValue 406 priv_bKeyExists = (err.Number = 0) 407 err.Clear 408 End If 409 KeyExists = priv_bKeyExists 410 On Error GoTo 0 End Property Public Property Let KeyExists(dummy As Boolean) 413 err.Raise ERR_NOLETPROPERTY, "keyExists", "" End Property