Soyez le premier à donner votre avis sur cette source.
Vue 6 884 fois - Téléchargée 653 fois
Option Explicit 'RegistryRW.cls '24.05.2010 Philippe Hollmuller (philippe.hollmuller@gmail.com) 'Class for reading writing windows registry with error managment. 'You are free to use this class in your applications but not to sell the source code 'Use: 'Dim regRW As RegistryRW 'Set regRW = New RegistryRW 'Dim val As String ''Computername can be "" for local machine or a name of a computer on the network 'val = regRW.GetRegValue("Computername", HKEY_CURRENT_USER, "Test1\test2\haha", "KeyName") 'if regRW.ErrNumber <> 0 then ' MsgBox regRW.ErrDescription 'End If 'Types Definition Private Type SECURITY_ATTRIBUTES nLength As Long lpSecurityDescriptor As Long bInheritHandle As Long End Type Public Enum RegKeyRootEnum HKEY_CLASSES_ROOT = &H80000000 HKEY_CURRENT_USER = &H80000001 HKEY_LOCAL_MACHINE = &H80000002 HKEY_USERS = &H80000003 HKEY_CURRENT_CONFIG = &H80000005 End Enum Public Enum RegValTypeEnum REG_BINARY = 3 REG_DWORD = 4 'A DWORD is a 32-bit unsigned integer (range: 0 through 4294967295 decimal). Because a DWORD is unsigned, its first bit (Most Significant Bit (MSB)) is not reserved for signing. REG_QWORD = 11 'A DWORD is a 64-bit unsigned integer (range: 0 through 18446744073709551615. Because a QWORD is unsigned, its first bit (Most Significant Bit (MSB)) is not reserved for signing. REG_SZ = 1 REG_MULTI_SZ = 7 REG_EXPAND_SZ = 2 End Enum 'API Declarations 'pour fermer la connection à la base de registre distante Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, ByRef lpType As Long, ByVal lpData As String, ByRef 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, ByVal lpData As String, ByVal cbData 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 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 RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey As String) As Long 'pour se connecter à une base de regitre distante Private Declare Function RegConnectRegistry Lib "advapi32.dll" Alias "RegConnectRegistryA" (ByVal lpMachineName As String, ByVal hKey As Long, phkResult As Long) As Long 'pour lister les sous-clé d'une ruche 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 Any) As Long 'pour lister les valeurs ruche 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 'ouvre une clé pour savoir si elle est valide Private Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long 'Constants Definition Private Const SYNCHRONIZE = &H100000 Private Const STANDARD_RIGHTS_ALL = &H1F0000 Private Const KEY_QUERY_VALUE = &H1 Private Const KEY_SET_VALUE = &H2 Private Const KEY_CREATE_LINK = &H20 Private Const KEY_CREATE_SUB_KEY = &H4 Private Const KEY_ENUMERATE_SUB_KEYS = &H8 Private Const KEY_EVENT = &H1 Private Const KEY_NOTIFY = &H10 Private Const READ_CONTROL = &H20000 Private Const STANDARD_RIGHTS_READ = (READ_CONTROL) Private Const STANDARD_RIGHTS_WRITE = (READ_CONTROL) 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 Const KEY_READ = ((STANDARD_RIGHTS_READ Or KEY_QUERY_VALUE Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY) And (Not SYNCHRONIZE)) Private Const KEY_EXECUTE = (KEY_READ) Private Const KEY_WRITE = ((STANDARD_RIGHTS_WRITE Or KEY_SET_VALUE Or KEY_CREATE_SUB_KEY) And (Not SYNCHRONIZE)) Private Const REG_CREATED_NEW_KEY = &H1 Private Const REG_DWORD_BIG_ENDIAN = 5 Private Const REG_DWORD_LITTLE_ENDIAN = 4 Private Const REG_FULL_RESOURCE_DESCRIPTOR = 9 Private Const REG_LINK = 6 Private Const REG_NONE = 0 Private Const REG_NOTIFY_CHANGE_ATTRIBUTES = &H2 Private Const REG_NOTIFY_CHANGE_LAST_SET = &H4 Private Const REG_NOTIFY_CHANGE_NAME = &H1 Private Const REG_NOTIFY_CHANGE_SECURITY = &H8 Private Const REG_OPTION_BACKUP_RESTORE = 4 Private Const REG_OPTION_CREATE_LINK = 2 Private Const REG_OPTION_NON_VOLATILE = 0 Private Const REG_OPTION_RESERVED = 0 Private Const REG_OPTION_VOLATILE = 1 Private Const REG_LEGAL_CHANGE_FILTER = (REG_NOTIFY_CHANGE_NAME Or REG_NOTIFY_CHANGE_ATTRIBUTES Or REG_NOTIFY_CHANGE_LAST_SET Or REG_NOTIFY_CHANGE_SECURITY) Private Const REG_LEGAL_OPTION = (REG_OPTION_RESERVED Or REG_OPTION_NON_VOLATILE Or REG_OPTION_VOLATILE Or REG_OPTION_CREATE_LINK Or REG_OPTION_BACKUP_RESTORE) Private Const BUFFER_SIZE As Long = 255 Private Const ERROR_NO_MORE_ITEMS = 259& Private Const MILLION_1 As Double = 1000000 'To split big String numbers DWORD OR QWORD and make double buffering 'API call and Constants for transfomringt API error to string: Private Declare Function FormatMessage Lib "kernel32" _ Alias "FormatMessageA" _ (ByVal dwFlags As Long, _ lpSource As Long, _ ByVal dwMessageId As Long, _ ByVal dwLanguageId As Long, _ ByVal lpBuffer As String, _ ByVal nSize As Long, _ Args As Any) As Long Private Const MAX_PATH As Long = 260 Private Const LB_SETTABSTOPS As Long = &H192 Private Const FORMAT_MESSAGE_FROM_SYSTEM As Long = &H1000 Private Const FORMAT_MESSAGE_IGNORE_INSERTS As Long = &H200 Private Const FORMAT_MESSAGE_MAX_WIDTH_MASK As Long = &HFF Private Const FORMAT_MESSAGE_ARGUMENT_ARRAY As Long = &H2000 'Private attributes: Private myErrNumber As Long Private myErrDescription As String 'Properties Public Property Get ErrNumber() As Long ErrNumber = myErrNumber End Property 'ok 22.05.2010 Public Property Get ErrDescription() As String ErrDescription = myErrDescription End Property 'ok 22.05.2010 'Functions Public Function keyRootAsString(keyRoot As RegKeyRootEnum) As String Select Case keyRoot Case HKEY_CLASSES_ROOT keyRootAsString = "HKEY_CLASSES_ROOT" Case HKEY_CURRENT_CONFIG keyRootAsString = "HKEY_CURRENT_CONFIG" Case HKEY_CURRENT_USER keyRootAsString = "HKEY_CURRENT_USER" Case HKEY_LOCAL_MACHINE keyRootAsString = "HKEY_LOCAL_MACHINE" Case HKEY_USERS keyRootAsString = "HKEY_USERS" Case Else keyRootAsString = CStrNotNull(keyRoot) End Select End Function 'ok 19.05.2010 Public Function keyRootFromString(keyRootStr As String) As RegKeyRootEnum Select Case Trim(keyRootStr) Case "HKEY_CLASSES_ROOT" keyRootFromString = HKEY_CLASSES_ROOT Case "HKEY_CURRENT_CONFIG" keyRootFromString = HKEY_CURRENT_CONFIG Case "HKEY_CURRENT_USER" keyRootFromString = HKEY_CURRENT_USER Case "HKEY_LOCAL_MACHINE" keyRootFromString = HKEY_LOCAL_MACHINE Case "HKEY_USERS" keyRootFromString = HKEY_USERS Case Else keyRootFromString = 0 End Select End Function 'ok 19.05.2010 Public Function valTypeAsString(valType As RegValTypeEnum) As String Select Case valType Case REG_BINARY valTypeAsString = "REG_BINARY" Case REG_DWORD valTypeAsString = "REG_DWORD" Case REG_QWORD valTypeAsString = "REG_QWORD" Case REG_SZ valTypeAsString = "REG_SZ" Case REG_MULTI_SZ valTypeAsString = "REG_MULTI_SZ" Case REG_EXPAND_SZ valTypeAsString = "REG_EXPAND_SZ" Case Else valTypeAsString = CStrNotNull(valType) End Select End Function 'ok 23.05.2010 Public Function valTypeFromString(valTypeStr As String) As RegKeyRootEnum Select Case Trim(valTypeStr) Case "REG_BINARY" valTypeFromString = REG_BINARY Case "REG_DWORD" valTypeFromString = REG_DWORD Case "REG_QWORD" valTypeFromString = REG_QWORD Case "REG_SZ" valTypeFromString = REG_SZ Case "REG_MULTI_SZ" valTypeFromString = REG_MULTI_SZ Case "REG_EXPAND_SZ" valTypeFromString = REG_EXPAND_SZ Case Else valTypeFromString = 0 End Select End Function 'ok 19.05.2010 'private use to connect to a computer's registry, local computer if name is empty "" Private Function connectRegistry(ComputerName As String, ByVal keyRoot As RegKeyRootEnum, _ ByRef hKeyResult As Long, FunctionName As String, Path As String) As Boolean On Error Resume Next myErrNumber = 0 myErrDescription = "" Dim rv As Long rv = 1 rv = RegConnectRegistry(ComputerName, CLng(keyRoot), hKeyResult) 'l'api renvoie 0 si la connexion a pu être établi (cela évite de faire un ping) If rv = 0 Then connectRegistry = True Else connectRegistry = False myErrNumber = rv myErrDescription = "RegistryRW." & FunctionName & ": connectRegistry \\" & ComputerName & "\" & keyRootAsString(keyRoot) & "\" & Path & " failed: " & WinApiErrorAsString(rv) End If If Err.Number <> 0 Then connectRegistry = False myErrNumber = Err.Number myErrDescription = "RegistryRW." & FunctionName & ": connectRegistry \\" & ComputerName & "\" & keyRootAsString(keyRoot) & "\" & Path & " failed: " & Err.Description End If End Function 'ok 19.05.2010 Private Function openKey(hKeyResult As Long, Path As String, hKeyTmp As Long, keyRoot As RegKeyRootEnum, _ ComputerName As String, FunctionName As String) As Boolean On Error Resume Next Dim rv As Long rv = 1 rv = RegOpenKey(hKeyResult, Path, hKeyTmp) 'l'api renvoie 0 si la connexion a pu être établi (cela évite de faire un ping) If rv = 0 Then openKey = True Else openKey = False myErrNumber = rv myErrDescription = "RegistryRW." & FunctionName & ": Registry OpenKey \\" & ComputerName & "\" & keyRootAsString(keyRoot) & "\" & Path & " failed: " & WinApiErrorAsString(rv) End If If Err.Number <> 0 Then openKey = False myErrNumber = Err.Number myErrDescription = "RegistryRW." & FunctionName & ": Registry OpenKey \\" & ComputerName & "\" & keyRootAsString(keyRoot) & "\" & Path & " failed: " & Err.Description End If End Function 'ok 19.05.2010 'Fonctions 'Delete e Registry Key with all his contained Values Public Function DeleteRegistryKey(ComputerName As String, ByVal keyRoot As RegKeyRootEnum, _ Path As String) As Boolean Dim hKeyResult As Long If connectRegistry(ComputerName, keyRoot, hKeyResult, "DeleteRegistryKey", Path) Then Dim hKeyTmp As Long If openKey(hKeyResult, Path, hKeyTmp, keyRoot, ComputerName, "DeleteRegistryKey") Then On Error Resume Next RegCloseKey hKeyTmp 'close the key opened by openKey Dim rv As Long rv = RegDeleteKey(hKeyResult, Path) If rv = 0 Then DeleteRegistryKey = True Else DeleteRegistryKey = False myErrNumber = rv myErrDescription = "RegistryRW.DeleteRegistryKey \\" & ComputerName & "\" & keyRootAsString(keyRoot) & "\" & Path & " failed: " & WinApiErrorAsString(rv) End If If Err.Number <> 0 Then DeleteRegistryKey = False myErrNumber = Err.Number myErrDescription = "RegistryRW.DeleteRegistryKey \\" & ComputerName & "\" & keyRootAsString(keyRoot) & "\" & Path & " failed: " & Err.Description End If End If RegCloseKey hKeyResult 'close the key opened by connectRegistry End If End Function 'ok 19.05.2010 'Delete a Value from the Registry Public Function DeleteValue(ComputerName As String, ByVal keyRoot As RegKeyRootEnum, _ Path As String, ValueName As String) As Boolean 'le lien avec l'ordi distant ce fait grâce au hKeyResult qui est un paramettre de résultat 'hKeyResult est le dernier paramettre de RegConnectRegistry et le premier de RegOpenKey Dim hKeyResult As Long If connectRegistry(ComputerName, keyRoot, hKeyResult, "DeleteValue", Path) Then Dim hKeyTmp As Long If openKey(hKeyResult, Path, hKeyTmp, keyRoot, ComputerName, "DeleteValue") Then On Error Resume Next Dim rv As Long rv = RegDeleteValue(hKeyTmp, ValueName) If rv = 0 Then DeleteValue = True Else DeleteValue = False myErrNumber = rv myErrDescription = "RegistryRW.DeleteValue \\" & ComputerName & "\" & keyRootAsString(keyRoot) & "\" & Path & "\" & ValueName & " failed: " & WinApiErrorAsString(rv) End If If Err.Number <> 0 Then DeleteValue = False myErrNumber = Err.Number myErrDescription = "RegistryRW.DeleteValue \\" & ComputerName & "\" & keyRootAsString(keyRoot) & "\" & Path & "\" & ValueName & " failed: " & Err.Description End If RegCloseKey hKeyTmp 'close the key opened by openKey End If RegCloseKey hKeyResult 'close the key opened by connectRegistry End If End Function 'ok 19.05.2010 'Creates a New Registry Key Public Function CreateRegistryKey(ComputerName As String, ByVal keyRoot As RegKeyRootEnum, _ Path As String) As Boolean Dim hKeyResult As Long If connectRegistry(ComputerName, keyRoot, hKeyResult, "CreateRegistryKey", Path) Then On Error Resume Next Dim hKeyTmp As Long Dim y As SECURITY_ATTRIBUTES Dim Operation As Long Dim rv As Long rv = RegCreateKeyEx(hKeyResult, Path, 0, "", 0, KEY_ALL_ACCESS, y, hKeyTmp, Operation) If rv = 0 Then CreateRegistryKey = True Else CreateRegistryKey = False myErrNumber = rv myErrDescription = "RegistryRW.CreateRegistryKey \\" & ComputerName & "\" & keyRootAsString(keyRoot) & "\" & Path & " failed: " & WinApiErrorAsString(rv) End If If Err.Number <> 0 Then CreateRegistryKey = False myErrNumber = Err.Number myErrDescription = "RegistryRW.CreateRegistryKey \\" & ComputerName & "\" & keyRootAsString(keyRoot) & "\" & Path & " failed: " & Err.Description End If RegCloseKey hKeyTmp 'close the key opened by RegCreateKeyEx RegCloseKey hKeyResult 'close the key opened by connectRegistry End If End Function 'ok 19.05.2010 'Get a specific Registry Value (to access the Default Registry Key Value set ValueName parameter as "") Public Function GetRegValType(ComputerName As String, ByVal keyRoot As RegKeyRootEnum, _ Path As String, ValueName As String) As RegKeyRootEnum Dim rv As RegValTypeEnum GetRegValue ComputerName, keyRoot, Path, ValueName, rv GetRegValType = rv End Function 'ok 23.05.2010 'Get a specific Registry Value (to access the Default Registry Key Value set ValueName parameter as "") Public Function GetRegValue(ComputerName As String, ByVal keyRoot As RegKeyRootEnum, _ Path As String, ValueName As String, Optional ByRef valType As RegValTypeEnum = REG_SZ) As String Dim hKeyResult As Long If connectRegistry(ComputerName, keyRoot, hKeyResult, "GetRegValue", Path) Then Dim hKeyTmp As Long If openKey(hKeyResult, Path, hKeyTmp, keyRoot, ComputerName, "GetRegValue") Then On Error Resume Next Dim keyValType As Long Dim KeyValSize As Long Dim KeyVal As String Dim tmpVal As String Dim i As Integer Dim rv As Long tmpVal = String(1024, 0) KeyValSize = 1024 rv = RegQueryValueEx(hKeyTmp, ValueName, 0, keyValType, tmpVal, KeyValSize) If rv = 0 Then If KeyValSize > 0 Then If (Asc(Mid(tmpVal, KeyValSize, 1)) = 0) Then tmpVal = Left(tmpVal, KeyValSize - 1) Else tmpVal = Left(tmpVal, KeyValSize) End If Else tmpVal = "" End If Select Case keyValType Case REG_DWORD, REG_QWORD Dim valMillionCount As Double 'pour double buffering valeur en cas de QWord et DWORD, non signés de 32 et 64 bits Dim valLow As Double 'pour double buffering valeur en cas de QWord et DWORD, non signés de 32 et 64 bits valLow = 0 For i = Len(tmpVal) To 1 Step -1 If valLow * 256 > 99999999# Then Dim milc As Double milc = Fix(valLow / MILLION_1) valLow = valLow - (milc * MILLION_1) valMillionCount = valMillionCount + milc End If valMillionCount = valMillionCount * 256 valLow = valLow * 256 valLow = valLow + Asc(Mid(tmpVal, i, 1)) Next i milc = Fix(valLow / MILLION_1) valLow = valLow - (milc * MILLION_1) valMillionCount = valMillionCount + milc Dim ErrMsg As String 'set KeyVal: If Not DblToString(valLow, valMillionCount, KeyVal, ErrMsg) Then myErrNumber = 1 myErrDescription = "RegistryRW.GetRegValue \\" & ComputerName & "\" & keyRootAsString(keyRoot) & "\" & Path & "\" & ValueName & " failed: Error by transforming Values to string." Else valType = keyValType End If Case Else KeyVal = tmpVal valType = keyValType End Select Else KeyVal = "" myErrNumber = rv myErrDescription = "RegistryRW.GetRegValue \\" & ComputerName & "\" & keyRootAsString(keyRoot) & "\" & Path & "\" & ValueName & " failed: " & WinApiErrorAsString(rv) End If If Err.Number <> 0 Then KeyVal = "" myErrNumber = Err.Number myErrDescription = "RegistryRW.GetRegValue \\" & ComputerName & "\" & keyRootAsString(keyRoot) & "\" & Path & "\" & ValueName & " failed: " & Err.Description End If GetRegValue = KeyVal 'return value RegCloseKey hKeyTmp 'close the key opened by openKey End If RegCloseKey hKeyResult 'close the key opened by connectRegistry End If End Function 'ok 22.05.2010 'Tests if a key exists by key path Public Function ExistsKey(ComputerName As String, ByVal keyRoot As RegKeyRootEnum, _ Path As String) As Boolean Dim hKeyResult As Long If connectRegistry(ComputerName, keyRoot, hKeyResult, "ExistsKey", Path) Then Dim hKeyTmp As Long If openKey(hKeyResult, Path, hKeyTmp, keyRoot, ComputerName, "ExistsKey") Then ExistsKey = True RegCloseKey hKeyTmp 'close the key opened by openKey End If RegCloseKey hKeyResult 'close the key opened by connectRegistry End If End Function 'ok 24.05.2010 'Tests if a Value name exists in the key path Public Function ExistsValue(ComputerName As String, ByVal keyRoot As RegKeyRootEnum, _ Path As String, ValueName As String) As Boolean Dim hKeyResult As Long If connectRegistry(ComputerName, keyRoot, hKeyResult, "ExistsValue", Path) Then Dim hKeyTmp As Long If openKey(hKeyResult, Path, hKeyTmp, keyRoot, ComputerName, "ExistsValue") Then On Error Resume Next Dim keyValType As Long Dim KeyValSize As Long Dim tmpVal As String tmpVal = String(1024, 0) KeyValSize = 1024 If RegQueryValueEx(hKeyTmp, ValueName, 0, keyValType, tmpVal, KeyValSize) = 0 Then ExistsValue = True End If RegCloseKey hKeyTmp 'close the key opened by openKey End If RegCloseKey hKeyResult 'close the key opened by connectRegistry End If End Function 'ok 24.05.2010 'Create or Modify a Registry Value (to access the Default Registry Key Value set ValueName parameter as "") Public Function SetRegValue(ComputerName As String, ByVal keyRoot As RegKeyRootEnum, _ Path As String, ValueName As String, NewValue As String, _ Optional ByVal RegValType As RegValTypeEnum = REG_SZ, _ Optional ByVal overwriteExixtingRegValType As Boolean = True) As Boolean Dim hKeyResult As Long If connectRegistry(ComputerName, keyRoot, hKeyResult, "SetRegValue", Path) Then Dim hKeyTmp As Long If openKey(hKeyResult, Path, hKeyTmp, keyRoot, ComputerName, "SetRegValue") Then On Error Resume Next Dim rv As Long Dim i As Integer Dim valMillionCount As Double 'pour double buffering valeur en cas de QWord et DWORD, non signés de 32 et 64 bits Dim valLow As Double 'pour double buffering valeur en cas de QWord et DWORD, non signés de 32 et 64 bits Dim keyValType As Long Dim KeyValSize As Long Dim oldRegValType As Long Dim tmpVal As String tmpVal = String(1024, 0) KeyValSize = 1024 Dim existingVal As Boolean rv = RegQueryValueEx(hKeyTmp, ValueName, 0, keyValType, tmpVal, KeyValSize) oldRegValType = keyValType 'pour pouvoir récrire l'ancienne valeur en cas d'échec dépassement de capacité Select Case rv Case 0 existingVal = True Case 2 existingVal = False keyValType = RegValType 'la valeur n'existe pas encore dans la registry Case Else 'Error SetRegValue = False myErrNumber = rv myErrDescription = "RegistryRW.SetRegValue \\" & ComputerName & "\" & keyRootAsString(keyRoot) & "\" & Path & "\" & ValueName & " failed: " & WinApiErrorAsString(rv) RegCloseKey hKeyTmp 'close the key opened by openKey RegCloseKey hKeyResult 'close the key opened by connectRegistry Exit Function 'EXIT End Select If keyValType <> RegValType Then 'Différence entre existante dans la registry et 'voulue par la fonction If overwriteExixtingRegValType Then keyValType = RegValType Else SetRegValue = False myErrNumber = rv myErrDescription = "RegistryRW.SetRegValue \\" & ComputerName & "\" & keyRootAsString(keyRoot) & "\" & Path & "\" & ValueName & " failed: RegistryValue allready existing with a different type." RegCloseKey hKeyTmp 'close the key opened by openKey RegCloseKey hKeyResult 'close the key opened by connectRegistry Exit Function 'EXIT End If End If 'Now do the writing depending on keyValType: Select Case keyValType Case REG_BINARY, REG_SZ, REG_MULTI_SZ, REG_EXPAND_SZ tmpVal = NewValue Case REG_DWORD, REG_QWORD Dim oldVal As String 'lire Valeur existante, err et errDesc pour pouvoir revenir en arrière en cas de dépassement de capacité.? Dim oldErrDescription As String Dim oldErrNr As Long If existingVal Then oldErrNr = ErrNumber oldErrDescription = ErrDescription oldVal = Me.GetRegValue(ComputerName, keyRoot, Path, ValueName) 'lire valeur avant d'écrire pour pouvoir revenir en arrière en cas de dépassement de capacité If Me.ErrNumber <> 0 Then existingVal = False End If myErrNumber = oldErrNr myErrDescription = oldErrDescription End If 'préparation valeurs écriture Dim ErrMsg As String If Not setDWordQWordValueFromString(NewValue, valLow, valMillionCount, ErrMsg) Then SetRegValue = False myErrNumber = 1 myErrDescription = "RegistryRW.SetRegValue \\" & ComputerName & "\" & keyRootAsString(keyRoot) & "\" & Path & "\" & ValueName & " failed: " & NewValue & " is not " & IIf(keyValType = REG_DWORD, "DWORD", "QWORD") & ". " & ErrMsg RegCloseKey hKeyTmp 'close the key opened by openKey RegCloseKey hKeyResult 'close the key opened by connectRegistry Exit Function 'EXIT End If tmpVal = "" Dim loopLimit As Integer If keyValType = REG_DWORD Then loopLimit = 3 ElseIf keyValType = REG_QWORD Then loopLimit = 7 End If 'Construct the string for RegSetValueEx DWORD or QWORD For i = 0 To loopLimit valLow = valLow + ((valMillionCount - (Fix(valMillionCount / 256) * 256)) * MILLION_1) valMillionCount = Fix(valMillionCount / 256) tmpVal = tmpVal & Chr(valLow - (Fix(valLow / 256) * 256)) valLow = Fix(valLow / 256) Next If valLow > 0 Or valMillionCount > 0 Then SetRegValue = False myErrNumber = 1 myErrDescription = "RegistryRW.SetRegValue \\" & ComputerName & "\" & keyRootAsString(keyRoot) & "\" & Path & "\" & ValueName & " failed: " & NewValue & " is not " & IIf(keyValType = REG_DWORD, "DWORD", "QWORD") & ", overflow." & ErrMsg RegCloseKey hKeyTmp 'close the key opened by openKey RegCloseKey hKeyResult 'close the key opened by connectRegistry Exit Function 'EXIT End If Case Else 'keyValType not implemented for write SetRegValue = False myErrNumber = 1 myErrDescription = "RegistryRW.SetRegValue \\" & ComputerName & "\" & keyRootAsString(keyRoot) & "\" & Path & "\" & ValueName & " failed: keyValType " & CStr(keyValType) & " not implemented existing in registry. To be implemented in RegistryRW." RegCloseKey hKeyTmp 'close the key opened by openKey RegCloseKey hKeyResult 'close the key opened by connectRegistry Exit Function 'EXIT End Select KeyValSize = Len(tmpVal) 'Ecriture rv = RegSetValueEx(hKeyTmp, ValueName, 0, keyValType, tmpVal, KeyValSize) If rv = 0 Then Select Case keyValType 'Relecture pour contrôle Case REG_DWORD, REG_QWORD 'dépassement de capacité, valeur écrite correspond à valeur voulue?? Dim valInRegEqualsWantedVal As Boolean oldErrNr = ErrNumber oldErrDescription = ErrDescription Dim valLow1 As Double, valMillionCount1 As Double Dim val1 As String val1 = Me.GetRegValue(ComputerName, keyRoot, Path, ValueName) 'Lire la valeur écrite auparavant If Me.ErrNumber <> 0 Then SetRegValue = False myErrDescription = "RegistryRW.SetRegValue read again: " & myErrDescription RegCloseKey hKeyTmp 'close the key opened by openKey RegCloseKey hKeyResult 'close the key opened by connectRegistry Exit Function 'EXIT End If myErrNumber = oldErrNr myErrDescription = oldErrDescription If setDWordQWordValueFromString(NewValue, valLow, valMillionCount, ErrMsg) Then If setDWordQWordValueFromString(val1, valLow1, valMillionCount1, ErrMsg) Then valInRegEqualsWantedVal = ((valLow = valLow1) And _ (valMillionCount = valMillionCount1)) End If End If If valInRegEqualsWantedVal Then SetRegValue = True Else SetRegValue = False If existingVal Then 'remettre l'ancienne valeur Me.SetRegValue ComputerName, keyRoot, Path, ValueName, oldVal, oldRegValType, overwriteExixtingRegValType Else 'effacer la valeur faussement enregistrée Me.DeleteValue ComputerName, keyRoot, Path, ValueName End If myErrNumber = 1 myErrDescription = "RegistryRW.SetRegValue \\" & ComputerName & "\" & keyRootAsString(keyRoot) & "\" & Path & "\" & ValueName & " failed: overflow." RegCloseKey hKeyTmp 'close the key opened by openKey RegCloseKey hKeyResult 'close the key opened by connectRegistry Exit Function 'EXIT End If Case Else 'setting a string value, no control necessary SetRegValue = True End Select Else SetRegValue = False myErrNumber = rv myErrDescription = "RegistryRW.SetRegValue \\" & ComputerName & "\" & keyRootAsString(keyRoot) & "\" & Path & "\" & ValueName & " failed: " & WinApiErrorAsString(rv) End If If Err.Number <> 0 Then SetRegValue = False myErrNumber = Err.Number myErrDescription = "RegistryRW.SetRegValue \\" & ComputerName & "\" & keyRootAsString(keyRoot) & "\" & Path & "\" & ValueName & " failed: " & Err.Description End If RegCloseKey hKeyTmp 'close the key opened by openKey End If RegCloseKey hKeyResult 'close the key opened by connectRegistry End If End Function 'ok 22.05.2010 'list the printers on a computer Public Function listComputerPrinter(ComputerName As String) As Collection Set listComputerPrinter = listKeysIn(ComputerName, HKEY_LOCAL_MACHINE, "SYSTEM\CurrentControlSet\Control\Print\Printers") End Function 'ok 19.05.2010 Public Function listKeysIn(ComputerName As String, ByVal keyRoot As RegKeyRootEnum, _ Path As String) As Collection Dim rv As Collection Set rv = New Collection Dim hKeyResult As Long If connectRegistry(ComputerName, keyRoot, hKeyResult, "listKeysIn", Path) Then Dim hKeyTmp As Long, Cnt As Long, sName As String, ret As Long Cnt = 0 ret = BUFFER_SIZE If openKey(hKeyResult, Path, hKeyTmp, keyRoot, ComputerName, "listKeysIn") Then On Error Resume Next 'crer un buffer sName = Space(BUFFER_SIZE) 'énumaire les sous-clé While RegEnumKeyEx(hKeyTmp, Cnt, sName, ret, ByVal 0&, vbNullString, ByVal 0&, ByVal 0&) <> ERROR_NO_MORE_ITEMS 'ajoute les sous clés rv.Add (Left$(sName, ret)) 'prepare pour la clé suivante Cnt = Cnt + 1 sName = Space(BUFFER_SIZE) ret = BUFFER_SIZE Wend RegCloseKey hKeyTmp 'close the key opened by openKey End If RegCloseKey hKeyResult 'close the key opened by connectRegistry End If Set listKeysIn = rv If Err.Number <> 0 Then myErrNumber = Err.Number myErrDescription = "RegistryRW.listKeysIn \\" & ComputerName & "\" & keyRootAsString(keyRoot) & "\" & Path & " failed: " & Err.Description End If End Function 'ok 22.05.2010 Public Function listValuesIn(ComputerName As String, ByVal keyRoot As RegKeyRootEnum, _ Path As String) As Collection Dim rv As Collection Set rv = New Collection Dim hKeyResult As Long If connectRegistry(ComputerName, keyRoot, hKeyResult, "listValuesIn", Path) Then Dim hKeyTmp As Long, Cnt As Long, sName As String, sData As String, ret As Long, RetData As Long Cnt = 0 ret = BUFFER_SIZE Cnt = 0 If openKey(hKeyResult, Path, hKeyTmp, keyRoot, ComputerName, "listValuesIn") Then On Error Resume Next sName = Space(BUFFER_SIZE) sData = Space(BUFFER_SIZE) ret = BUFFER_SIZE RetData = BUFFER_SIZE 'enumerate the values While RegEnumValue(hKeyTmp, Cnt, sName, ret, 0, ByVal 0&, ByVal sData, RetData) <> ERROR_NO_MORE_ITEMS If ret > 0 Then sName = Left$(sName, ret) Else sName = "" End If If RetData > 1 Then sData = Left$(sData, RetData - 1) Else sData = "" End If If sName <> "" Then rv.Add sName End If 'prepare for next value Cnt = Cnt + 1 sName = Space(BUFFER_SIZE) sData = Space(BUFFER_SIZE) ret = BUFFER_SIZE RetData = BUFFER_SIZE Wend 'Close the registry key RegCloseKey hKeyTmp 'close the key opened by openKey End If RegCloseKey hKeyResult 'close the key opened by connectRegistry End If Set listValuesIn = rv If Err.Number <> 0 Then myErrNumber = Err.Number myErrDescription = "RegistryRW.listValuesIn \\" & ComputerName & "\" & keyRootAsString(keyRoot) & "\" & Path & " failed: " & Err.Description End If End Function 'set les valeurs valLow et valMillionCount en fonction de la string d'entrée Private Function setDWordQWordValueFromString(s As String, _ valLow As Double, valMillionCount As Double, _ ErrMsg As String) As Boolean On Error Resume Next 'Test si cast en Cdbl possible: Dim d As Double d = CDbl(Trim(s)) If Err.Number <> 0 Then ErrMsg = Err.Description setDWordQWordValueFromString = False Exit Function 'EXIT ERROR End If If d < 0 Or Fix(d) <> d Then 'négatif ou contenand virgule ErrMsg = "Value < 0 is not a WORD, Word is unsigned value." setDWordQWordValueFromString = False Exit Function 'EXIT ERROR End If valLow = d 'd can be set from a big string like 1.2E+15 valMillionCount = Fix(valLow / MILLION_1) 'split in buffers valLow = valLow - (valMillionCount * MILLION_1) setDWordQWordValueFromString = True 'si pas d'erreur, valLow contient la valeur s sous forme de double, ok si 1.7E17, 'mais arrondi en virgule flottante si grand nombre en string passé en paramètre 'dépassant 15 caractères formattés pour calculs sur dbl 'limite sans double buffering sans perdre de précision: 999999999999999 'RECHERCHE DE PRECISION: 'peut être que la string passée contient un grand nombre pour un QWord 64 bits, calculer If WordStrToLowAndHighDbl(Trim(s), valLow, valMillionCount) Then setDWordQWordValueFromString = True End If Err.Clear End Function 'ok 22.05.2010 'Transformer un string en double Private Function WordStrToLowAndHighDbl(s As String, valLow As Double, valMillionCount As Double) As Boolean On Error Resume Next Dim v As Integer Dim i As Long Dim sLow As String, sMillionCount As String Dim numberMillion As Integer numberMillion = Len(CStr(MILLION_1)) - 1 If Len(s) <= numberMillion Then sLow = s Else sLow = Right(s, numberMillion) sMillionCount = Left(s, Len(s) - Len(sLow)) End If Dim sTmp As String Dim rv As Double Dim dLow As Double Dim dMillionCount As Double Dim lowIsSet As Boolean Dim MillionCountIsSet As Boolean 'Calcule valLow: sTmp = sLow rv = 0 For i = 1 To Len(sTmp) v = CInt(Mid(sTmp, i, 1)) 'can make error if 1.7E17 passed as parameter rv = 10 * rv rv = rv + CDbl(Mid(sTmp, i, 1)) If Err.Number <> 0 Then Err.Clear Exit Function 'EXIT ERROR End If Next i If Len(sTmp) > 0 Then dLow = rv lowIsSet = True End If 'Calcule valMillionCount: sTmp = sMillionCount rv = 0 For i = 1 To Len(sTmp) v = CInt(Mid(sTmp, i, 1)) 'can make error if 1.7E17 passed as parameter rv = 10 * rv rv = rv + CDbl(Mid(sTmp, i, 1)) If Err.Number <> 0 Then Err.Clear Exit Function 'EXIT ERROR End If Next i If Len(sTmp) > 0 Then dMillionCount = rv MillionCountIsSet = True End If If lowIsSet Then valLow = dLow If MillionCountIsSet Then valMillionCount = dMillionCount Else valMillionCount = 0 End If WordStrToLowAndHighDbl = True End If Err.Clear End Function 'ok 22.05.2010 'transforme deux doubles représentant un nombre en un string de sortie Private Function DblToString(valLow, valMillionCount, _ ByRef StringToSet As String, ByRef ErrMsg As String) As Boolean On Error GoTo DblToString_Err Dim d As Double Dim deci As Double Dim rv As String d = valLow While d >= 1 d = d / 10 deci = d - Fix(d) d = Fix(d) rv = Left(CStr(Round(deci * 10)), 1) & rv Wend If valMillionCount > 0 Then Dim numberMillion As Integer numberMillion = Len(CStr(MILLION_1)) - 1 While Len(rv) < numberMillion rv = "0" & rv Wend End If d = valMillionCount While d >= 1 d = d / 10 deci = d - Fix(d) d = Fix(d) rv = Left(CStr(Round(deci * 10)), 1) & rv Wend If rv = "" Then rv = 0 End If StringToSet = rv DblToString = True Exit Function DblToString_Err: StringToSet = "" ErrMsg = Err.Description DblToString = False Err.Clear End Function 'ok 19.05.2010 Private Function CStrNotNull(val As Variant) CStrNotNull = "" On Error Resume Next CStrNotNull = CStr(val) If Err.Number <> 0 Then CStrNotNull = "" End If End Function 'API error to string: Public Function WinApiErrorAsString(msgID As Long) As String Dim ret As Long Dim sVal As String Dim sCodes As String Dim sBuff As String sBuff = Space$(MAX_PATH) ret = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM Or _ FORMAT_MESSAGE_IGNORE_INSERTS Or _ FORMAT_MESSAGE_MAX_WIDTH_MASK, _ 0&, msgID, 0&, _ sBuff, Len(sBuff), 0&) sBuff = Left$(sBuff, ret) 'sCodes = msgID & vbTab & Hex(msgID) & vbTab If ret Then WinApiErrorAsString = sCodes & sBuff Else WinApiErrorAsString = sCodes & "(No such error)" End If End Function
Vous n'êtes pas encore membre ?
inscrivez-vous, c'est gratuit et ça prend moins d'une minute !
Les membres obtiennent plus de réponses que les utilisateurs anonymes.
Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.
Le fait d'être membre vous permet d'avoir des options supplémentaires.