Registry.bas

   1 Attribute VB_Name = "RegistryFunctions"\r
   2 Option Explicit\r
   3 \r
   4 Private Const HKEY_CLASSES_ROOT = &H80000000\r
   5 Private Const HKEY_CURRENT_USER = &H80000001\r
   6 Private Const HKEY_LOCAL_MACHINE = &H80000002\r
   7 Private Const HKEY_USERS = &H80000003\r
   8 Private Const HKEY_PERFORMANCE_DATA = &H80000004\r
   9 Private Const HKEY_CURRENT_CONFIG = &H80000005\r
  10 Private Const HKEY_DYN_DATA = &H80000006\r
  11 Private Const STANDARD_RIGHTS_ALL = &H1F0000\r
  12 Private Const KEY_QUERY_VALUE = &H1\r
  13 Private Const KEY_SET_VALUE = &H2\r
  14 Private Const KEY_CREATE_SUB_KEY = &H4\r
  15 Private Const KEY_ENUMERATE_SUB_KEYS = &H8\r
  16 Private Const KEY_NOTIFY = &H10\r
  17 Private Const SYNCHRONIZE = &H100000\r
  18 Private Const KEY_CREATE_LINK = &H20\r
  19 Private Const KEY_ALL_ACCESS = ((STANDARD_RIGHTS_ALL Or _\r
  20     KEY_QUERY_VALUE Or KEY_SET_VALUE Or KEY_CREATE_SUB_KEY _\r
  21     Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY Or _\r
  22     KEY_CREATE_LINK) And (Not SYNCHRONIZE))\r
  23 Private Const REG_OPTION_NON_VOLATILE = 0\r
  24 Global Const REG_NONE = 0\r
  25 Global Const REG_SZ = 1\r
  26 Global Const REG_EXPAND_SZ = 2\r
  27 Global Const REG_BINARY = 3\r
  28 Global Const REG_DWORD = 4\r
  29 Global Const REG_DWORD_LITTLE_ENDIAN = 4 ' Same as REG_DWORD\r
  30 Global Const REG_DWORD_BIG_ENDIAN = 5\r
  31 Global Const REG_LINK = 6\r
  32 Global Const REG_MULTI_SZ = 7\r
  33 Global Const REG_RESOURCE_LIST = 8\r
  34 Global Const REG_FULL_RESOURCE_DESCRIPTOR = 9\r
  35 Global Const REG_RESOURCE_REQUIREMENTS_LIST = 10\r
  36 \r
  37 Private Const REG_CREATED_NEW_KEY = &H1\r
  38 Private Const REG_OPENED_EXISTING_KEY = &H2\r
  39 \r
  40 Private Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" _\r
  41     (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, _\r
  42     ByVal samDesired As Long, phkResult As Long) As Long\r
  43 Private Declare Function RegCloseKey Lib "advapi32.dll" _\r
  44     (ByVal hKey As Long) As Long\r
  45 Private Declare Function RegEnumValue Lib "advapi32.dll" _\r
  46     Alias "RegEnumValueA" (ByVal hKey As Long, ByVal dwIndex _\r
  47     As Long, lpValueName As String, lpcbValueName As Long, ByVal _\r
  48     lpReserved As Long, lpType As Long, lpData As Any, lpcbData As _\r
  49     Long) As Long\r
  50 Private Declare Function RegEnumKeyEx Lib "advapi32.dll" _\r
  51     Alias "RegEnumKeyExA" (ByVal hKey As Long, ByVal dwIndex _\r
  52     As Long, lpName As String, lpcbName As Long, ByVal _\r
  53     lpReserved As Long, lpClass As String, lpcbClass As _\r
  54     Long, lpftLastWriteTime As Any) As Long\r
  55 Private Declare Function RegQueryValueEx Lib "advapi32.dll" _\r
  56     Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName _\r
  57     As String, ByVal lpReserved As Long, lpType As Long, lpData As _\r
  58     Any, lpcbData As Long) As Long\r
  59 Private Declare Function RegCreateKeyEx Lib "advapi32.dll" _\r
  60     Alias "RegCreateKeyExA" (ByVal hKey As Long, ByVal lpSubKey _\r
  61     As String, ByVal Reserved As Long, ByVal lpClass As String, _\r
  62     ByVal dwOptions As Long, ByVal samDesired As Long, _\r
  63     lpSecurityAttributes As Any, phkResult _\r
  64     As Long, lpdwDisposition As Long) As Long\r
  65 Private Declare Function RegSetValueEx Lib "advapi32.dll" _\r
  66     Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName _\r
  67     As String, ByVal Reserved As Long, ByVal dwType As Long, _\r
  68     lpData As Any, ByVal cbData As Long) As Long\r
  69 Private Declare Function RegDeleteValue Lib "advapi32.dll" _\r
  70     Alias "RegDeleteValueA" (ByVal hKey As Long, ByVal _\r
  71     lpValueName As String) As Long\r
  72 Private Declare Function RegDeleteKey Lib "advapi32.dll" Alias _\r
  73     "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey As String) As Long\r
  74 Sub ConvertValueName(Path As String, ByRef hKey As Long, ByRef Key As String, ValueName As String)\r
  75 Dim Data As String, bNum As Long\r
  76 Data = Mid$(Path, 1, InStr(Path, "\") - 1)\r
  77 Select Case Data\r
  78 Case "HKEY_CLASSES_ROOT"\r
  79 hKey = HKEY_CLASSES_ROOT\r
  80 Case "HKEY_CURRENT_USER"\r
  81 hKey = HKEY_CURRENT_USER\r
  82 Case "HKEY_LOCAL_MACHINE"\r
  83 hKey = HKEY_LOCAL_MACHINE\r
  84 Case "HKEY_USERS"\r
  85 hKey = HKEY_USERS\r
  86 Case "HKEY_PERFORMANCE_DATA"\r
  87 hKey = HKEY_PERFORMANCE_DATA\r
  88 Case "HKEY_CURRENT_CONFIG"\r
  89 hKey = HKEY_CURRENT_CONFIG\r
  90 Case "HKEY_DYN_DATA"\r
  91 hKey = HKEY_DYN_DATA\r
  92 End Select\r
  93 bNum = 1\r
  94 Do Until InStr(bNum, Path, "\") = 0\r
  95 bNum = InStr(bNum, Path, "\") + 1\r
  96 Loop\r
  97 On Error Resume Next\r
  98 Key = Mid$(Path, Len(Data) + 2, bNum - 2 - (Len(Data) + 1))\r
  99 ValueName = Mid$(Path, bNum)\r
 100 On Error GoTo 0\r
 101 End Sub\r
 102 Function GetReg(Path As String, Optional Default)\r
 103 Attribute GetReg.VB_Description = "Reads a value from the registry."\r
 104 Dim hKey As Long, kHandle As Long, Key As String, ValueName As String, Data As String, vLen As Long, vType As Long, NumData As Long\r
 105 ConvertValueName Path, hKey, Key, ValueName\r
 106 If RegOpenKeyEx(hKey, Key, 0&, KEY_QUERY_VALUE, kHandle) = 0 Then\r
 107     If RegQueryValueEx(kHandle, ValueName, 0&, vType, ByVal 0&, vLen) = 0 Then\r
 108         Data = String$(vLen, Chr$(0))\r
 109         If vType = REG_DWORD Or vType = REG_DWORD_BIG_ENDIAN Then\r
 110             If RegQueryValueEx(kHandle, ValueName, 0&, 0&, NumData, vLen) = 0 Then\r
 111                 GetReg = NumData\r
 112             End If\r
 113         Else\r
 114             If RegQueryValueEx(kHandle, ValueName, 0&, 0&, ByVal Data, vLen) = 0 Then\r
 115                 If vType = REG_SZ Or vType = REG_EXPAND_SZ Or vType = REG_MULTI_SZ Then\r
 116                     Data = Left$(Data, vLen - 1)\r
 117                     If Data <> "" Then GetReg = Data\r
 118                 Else\r
 119                     GetReg = Data\r
 120                 End If\r
 121             End If\r
 122         End If\r
 123     End If\r
 124     RegCloseKey kHandle\r
 125     If Not IsEmpty(GetReg) Then Exit Function\r
 126 End If\r
 127 If Not IsError(Default) Then GetReg = Default\r
 128 End Function\r
 129 Function GetRegType(Path As String) As Long\r
 130 Dim hKey As Long, kHandle As Long, Key As String, ValueName As String, Data As String, vLen As Long, vType As Long\r
 131 ConvertValueName Path, hKey, Key, ValueName\r
 132 If RegOpenKeyEx(hKey, Key, 0&, KEY_QUERY_VALUE, kHandle) = 0 Then\r
 133     If RegQueryValueEx(kHandle, ValueName, 0&, vType, ByVal 0&, ByVal 0&) Then\r
 134         GetRegType = vType\r
 135     End If\r
 136     RegCloseKey kHandle\r
 137 End If\r
 138 End Function\r
 139 Function EnumReg(ByVal Path As String, Index As Long) As String\r
 140 Dim hKey As Long, kHandle As Long, Key As String, ValueName As String, Data As String, vLen As Long\r
 141 If Right$(Path, 1) <> "\" Then Path = Path + "\"\r
 142 ConvertValueName Path, hKey, Key, ValueName\r
 143 ValueName = ""\r
 144 If RegOpenKeyEx(hKey, Key, 0&, KEY_QUERY_VALUE, kHandle) = 0 Then\r
 145     vLen = 255\r
 146     Data = String$(255, Chr$(0))\r
 147     If RegEnumValue(kHandle, Index, ByVal Data, vLen, 0&, 0&, ByVal 0&, 0&) = 0 Then\r
 148         Data = Left$(Data, vLen)\r
 149         If Data = String$(255, Chr$(0)) Then Data = ""\r
 150         EnumReg = Data\r
 151     End If\r
 152     RegCloseKey kHandle\r
 153 End If\r
 154 End Function\r
 155 Function EnumKey(ByVal Path As String, Index As Long) As String\r
 156 Dim hKey As Long, kHandle As Long, Key As String, ValueName As String, Data As String, vLen As Long\r
 157 If Right$(Path, 1) <> "\" Then Path = Path + "\"\r
 158 ConvertValueName Path, hKey, Key, ValueName\r
 159 ValueName = ""\r
 160 If RegOpenKeyEx(hKey, Key, 0&, KEY_ENUMERATE_SUB_KEYS, kHandle) = 0 Then\r
 161     vLen = 255\r
 162     Data = String$(255, Chr$(0))\r
 163     If RegEnumKeyEx(kHandle, Index, ByVal Data, vLen, 0&, ByVal 0&, 0&, ByVal 0&) = 0 Then\r
 164         Data = Left$(Data, vLen)\r
 165         If Data = String$(255, Chr$(0)) Then Data = ""\r
 166         EnumKey = Data\r
 167     End If\r
 168     RegCloseKey kHandle\r
 169 End If\r
 170 End Function\r
 171 Sub MultiStringToArray(MultiString As String, ByRef StrArray() As String)\r
 172 Dim cNum As Long, cNum2 As Long\r
 173 ReDim StrArray(0)\r
 174 For cNum = 1 To Len(MultiString)\r
 175     cNum2 = InStr(cNum, MultiString, Chr(0))\r
 176     If cNum2 = 0 Then cNum2 = Len(MultiString) + 1\r
 177     ReDim Preserve StrArray(UBound(StrArray) + 1)\r
 178     StrArray(UBound(StrArray)) = Mid$(MultiString, cNum, cNum2 - cNum)\r
 179     cNum = cNum2\r
 180 Next cNum\r
 181 End Sub\r
 182 Sub ArrayToMultiString(StrArray() As String, ByRef MultiString As String)\r
 183 Dim sNum As Long\r
 184 MultiString = ""\r
 185 For sNum = 1 To UBound(StrArray)\r
 186     MultiString = MultiString + StrArray(sNum) + Chr$(0)\r
 187 Next sNum\r
 188 End Sub\r
 189 Sub NewKey(ByVal Path As String, Optional Default, Optional vType)\r
 190 Attribute NewKey.VB_Description = "Creates a new key in the registry."\r
 191 Dim hKey As Long, kHandle As Long, Key As String, ValueName As String, Temp As Long, Setg As String, NumData As Long\r
 192 If Right$(Path, 1) <> "\" Then Path = Path + "\"\r
 193 ConvertValueName Path, hKey, Key, ValueName\r
 194 ValueName = ""\r
 195 If RegCreateKeyEx(hKey, Key, 0&, 0&, REG_OPTION_NON_VOLATILE, KEY_CREATE_SUB_KEY Or KEY_SET_VALUE, ByVal 0&, kHandle, Temp) = 0 Then\r
 196     If Not IsError(Default) Then\r
 197         If IsError(vType) Then vType = REG_SZ\r
 198         If vType = REG_DWORD Or vType = REG_DWORD_BIG_ENDIAN Then\r
 199             NumData = Default\r
 200             RegSetValueEx kHandle, ValueName, 0&, vType, NumData, 4\r
 201         Else\r
 202             Setg = Default\r
 203             If vType = REG_SZ Or vType = REG_EXPAND_SZ Or vType = REG_MULTI_SZ Then _\r
 204                 Setg = Setg + Chr$(0)\r
 205             RegSetValueEx kHandle, ValueName, 0&, vType, ByVal Setg, Len(Setg)\r
 206         End If\r
 207     End If\r
 208     RegCloseKey kHandle\r
 209 End If\r
 210 End Sub\r
 211 Sub SetReg(Path As String, NewValue, Optional vType)\r
 212 Attribute SetReg.VB_Description = "Writes a value to the registry."\r
 213 Dim hKey As Long, kHandle As Long, Key As String, ValueName As String, Setg As String, NumData As Long\r
 214 ConvertValueName Path, hKey, Key, ValueName\r
 215 If RegOpenKeyEx(hKey, Key, 0&, KEY_SET_VALUE, kHandle) = 0 Then\r
 216     If IsError(vType) Then vType = REG_SZ\r
 217     If vType = REG_DWORD Or vType = REG_DWORD_BIG_ENDIAN Then\r
 218         NumData = NewValue\r
 219         RegSetValueEx kHandle, ValueName, 0&, vType, NumData, 4\r
 220     Else\r
 221         Setg = NewValue\r
 222         If vType = REG_SZ Or vType = REG_EXPAND_SZ Or vType = REG_MULTI_SZ Then _\r
 223             Setg = Setg + Chr$(0)\r
 224         RegSetValueEx kHandle, ValueName, 0&, vType, ByVal Setg, Len(Setg)\r
 225     End If\r
 226     RegCloseKey kHandle\r
 227 End If\r
 228 End Sub\r
 229 Sub DelReg(Path As String)\r
 230 Attribute DelReg.VB_Description = "Deletes a value from the registry."\r
 231 Dim hKey As Long, kHandle As Long, Key As String, ValueName As String\r
 232 ConvertValueName Path, hKey, Key, ValueName\r
 233 If RegOpenKeyEx(hKey, Key, 0&, KEY_SET_VALUE, kHandle) = 0 Then\r
 234     RegDeleteValue kHandle, ValueName\r
 235     RegCloseKey kHandle\r
 236 End If\r
 237 End Sub\r
 238 Sub DelKey(ByVal Path As String)\r
 239 Attribute DelKey.VB_Description = "Deletes a key from the registry."\r
 240 Dim hKey As Long, Key As String, Data As String\r
 241 If Right$(Path, 1) <> "\" Then Path = Path + "\"\r
 242 ConvertValueName Path, hKey, Key, Data\r
 243 RegDeleteKey hKey, Key\r
 244 End Sub\r