Abundant Technologies - IT Consulting Experts

 Source Code Library

 Code Details

 
Option Explicit Global Const REG_SZ As Long = 1 Global Const REG_DWORD As Long = 4 Global Const HKEY_CLASSES_ROOT = &H80000000 Global Const HKEY_CURRENT_USER = &H80000001 Global Const HKEY_LOCAL_MACHINE = &H80000002 Global Const HKEY_USERS = &H80000003 Global Const ERROR_NONE = 0 Global Const ERROR_BADDB = 1 Global Const ERROR_BADKEY = 2 Global Const ERROR_CANTOPEN = 3 Global Const ERROR_CANTREAD = 4 Global Const ERROR_CANTWRITE = 5 Global Const ERROR_OUTOFMEMORY = 6 Global Const ERROR_INVALID_PARAMETER = 7 Global Const ERROR_ACCESS_DENIED = 8 Global Const ERROR_INVALID_PARAMETERS = 87 Global Const ERROR_NO_MORE_ITEMS = 259 Global Const SYNCHRONIZE = &H100000 Global Const STANDARD_RIGHTS_READ = &H20000 Global Const STANDARD_RIGHTS_WRITE = &H20000 Global Const STANDARD_RIGHTS_EXECUTE = &H20000 Global Const STANDARD_RIGHTS_REQUIRED = &HF0000 Global Const STANDARD_RIGHTS_ALL = &H1F0000 Global Const KEY_QUERY_VALUE = &H1 Global Const KEY_SET_VALUE = &H2 Global Const KEY_CREATE_SUB_KEY = &H4 Global Const KEY_ENUMERATE_SUB_KEYS = &H8 Global Const KEY_NOTIFY = &H10 Global Const KEY_CREATE_LINK = &H20 Global Const KEY_READ = ((STANDARD_RIGHTS_READ Or KEY_QUERY_VALUE Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY) And (Not SYNCHRONIZE)) Global Const KEY_WRITE = ((STANDARD_RIGHTS_WRITE Or KEY_SET_VALUE Or KEY_CREATE_SUB_KEY) And (Not SYNCHRONIZE)) Global Const KEY_ALL_ACCESS = &H3F Global Const REG_OPTION_NON_VOLATILE = 0 Declare Function RegCloseKey Lib "advapi32.dll" _ (ByVal hKey As Long) As Long 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, ByVal lpSecurityAttributes _ As Long, phkResult As Long, lpdwDisposition As Long) As Long 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 Declare Function RegQueryValueExString Lib "advapi32.dll" Alias _ "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As _ String, ByVal lpReserved As Long, lpType As Long, ByVal lpData _ As String, lpcbData As Long) As Long Declare Function RegQueryValueExLong Lib "advapi32.dll" Alias _ "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As _ String, ByVal lpReserved As Long, lpType As Long, lpData As _ Long, lpcbData As Long) As Long Declare Function RegQueryValueExNULL Lib "advapi32.dll" Alias _ "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As _ String, ByVal lpReserved As Long, lpType As Long, ByVal lpData _ As Long, lpcbData As Long) As Long Declare Function RegSetValueExString Lib "advapi32.dll" Alias _ "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, _ ByVal Reserved As Long, ByVal dwType As Long, ByVal lpValue As _ String, ByVal cbData As Long) As Long Declare Function RegSetValueExLong Lib "advapi32.dll" Alias _ "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, _ ByVal Reserved As Long, ByVal dwType As Long, lpValue As Long, _ ByVal cbData As Long) As Long Public Sub mdl_Registry_CreateNewKey(sNewKeyName As String, lPredefinedKey As Long) Dim hNewKey As Long 'handle to the new key Dim lRetVal As Long 'result of the RegCreateKeyEx function lRetVal = RegCreateKeyEx(lPredefinedKey, sNewKeyName, 0&, _ vbNullString, REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS, _ 0&, hNewKey, lRetVal) RegCloseKey (hNewKey) End Sub 'For the registry calls Function mdl_Registry_QUERYVALUE(sKeyName As String, sValueName As String) As Variant Dim lRetVal As Long 'result of the API functions Dim hKey As Long 'handle of opened key Dim vValue As Variant 'setting of queried value lRetVal = RegOpenKeyEx(HKEY_LOCAL_MACHINE, sKeyName, 0, KEY_READ, hKey) lRetVal = mdl_Registry_QUERYVALUEEX(hKey, sValueName, vValue) mdl_Registry_QUERYVALUE = vValue RegCloseKey (hKey) End Function 'Setting Values in registry Function mdl_Registry_SETKEYVALUE(sKeyName As String, sValueName As String, vValueSetting As Variant, lValueType As Long) As Variant Dim lRetVal As Long 'result of the SetValueEx function Dim hKey As Long 'handle of open key 'open the specified key If RegOpenKeyEx(HKEY_LOCAL_MACHINE, sKeyName, 0, KEY_WRITE, hKey) = 2 Then 'This key does not exist in the registry. mdl_Registry_SETKEYVALUE = 2 Exit Function End If mdl_Registry_SETKEYVALUE = mdl_Registry_SETVALUEEX(hKey, sValueName, lValueType, vValueSetting) RegCloseKey (hKey) End Function Public Function mdl_Registry_SETVALUEEX(ByVal hKey As Long, sValueName As String, lType As Long, vValue As Variant) As Long Dim lValue As Long Dim sValue As String Select Case lType Case REG_SZ sValue = vValue & Chr$(0) mdl_Registry_SETVALUEEX = RegSetValueExString(hKey, sValueName, 0&, _ lType, sValue, Len(sValue)) Case REG_DWORD lValue = vValue mdl_Registry_SETVALUEEX = RegSetValueExLong(hKey, sValueName, 0&, _ lType, lValue, 4) End Select End Function Function mdl_Registry_QUERYVALUEEX(ByVal lhKey As Long, ByVal szValueName As String, vValue As Variant) As Long Dim cch As Long Dim lrc As Long Dim lType As Long Dim lValue As Long Dim sValue As String On Error GoTo QueryValueExError ' Determine the size and type of data to be read lrc = RegQueryValueExNULL(lhKey, szValueName, 0&, lType, 0&, cch) If lrc <> ERROR_NONE Then Error 5 Select Case lType ' For strings Case REG_SZ: sValue = String(cch, 0) lrc = RegQueryValueExString(lhKey, szValueName, 0&, lType, _ sValue, cch) If lrc = ERROR_NONE Then vValue = Left$(sValue, cch - 1) Else vValue = Empty End If ' For DWORDS Case REG_DWORD: lrc = RegQueryValueExLong(lhKey, szValueName, 0&, lType, _ lValue, cch) If lrc = ERROR_NONE Then vValue = lValue Case Else 'all other data types not supported lrc = -1 End Select QueryValueExExit: mdl_Registry_QUERYVALUEEX = lrc Exit Function QueryValueExError: Resume QueryValueExExit End Function

Mail To: info@3pc.com