home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 1_2002.ISO / Data / Zips / CODE_UPLOAD1153611102000.psc / RegistryAccess.bas < prev   
Encoding:
BASIC Source File  |  2000-10-15  |  4.9 KB  |  149 lines
  1. Attribute VB_Name = "RegistryAccess"
  2. Declare Function RegQueryValueEx 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
  3. 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
  4. 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
  5. Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hkey As Long) As Long
  6. Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hkey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
  7.  
  8. Public Const KEY_NOTIFY = &H10
  9. Public Const ERROR_SUCCESS = 0&
  10.  
  11. Const REG_SZ = 1&
  12. Const KEY_QUERY_VALUE = &H1&
  13. Const KEY_ENUMERATE_SUB_KEYS = &H8
  14. Const READ_CONTROL = &H20000
  15. Const STANDARD_RIGHTS_READ = READ_CONTROL
  16. Const KEY_READ = STANDARD_RIGHTS_READ Or KEY_QUERY_VALUE Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY
  17. Const DisplayErrorMsg = False
  18.  
  19. Dim MainKeyHandle As Long
  20. Dim lBufferSize As Long
  21. Dim rtn As Long
  22. Dim hkey As Long
  23. Dim sBuffer As String
  24.  
  25. Function GetStringValue(SubKey As String, Entry As String)
  26.  
  27.     Call ParseKey(SubKey, MainKeyHandle)
  28.  
  29.     If MainKeyHandle Then
  30.         rtn = RegOpenKeyEx(MainKeyHandle, SubKey, 0, KEY_READ, hkey)
  31.         If rtn = ERROR_SUCCESS Then
  32.             sBuffer = Space(255)
  33.             lBufferSize = Len(sBuffer)
  34.             rtn = RegQueryValueEx(hkey, Entry, 0, REG_SZ, sBuffer, lBufferSize)
  35.             If rtn = ERROR_SUCCESS Then
  36.                 rtn = RegCloseKey(hkey)
  37.                 sBuffer = Trim(sBuffer)
  38.                 GetStringValue = Left(sBuffer, Len(sBuffer) - 1)
  39.             Else
  40.                 GetStringValue = ""
  41.                 If DisplayErrorMsg = True Then
  42.                     MsgBox ErrorMsg(rtn)
  43.                 End If
  44.             End If
  45.         Else
  46.             GetStringValue = ""
  47.             If DisplayErrorMsg = True Then
  48.                 MsgBox ErrorMsg(rtn)
  49.             End If
  50.         End If
  51.     End If
  52.  
  53. End Function
  54.  
  55. Private Sub ParseKey(Keyname As String, keyhandle As Long)
  56.     
  57.     rtn = InStr(Keyname, "\")
  58.  
  59.     If Left(Keyname, 5) <> "HKEY_" Or Right(Keyname, 1) = "\" Then
  60.         If DisplayErrorMsg = True Then
  61.             MsgBox "Incorrect Format:" + Chr(10) + Chr(10) + Keyname
  62.         End If
  63.         Exit Sub
  64.     ElseIf rtn = 0 Then
  65.         keyhandle = GetMainKeyHandle(Keyname)
  66.         Keyname = ""
  67.     Else
  68.         keyhandle = GetMainKeyHandle(Left(Keyname, rtn - 1))
  69.         Keyname = Right(Keyname, Len(Keyname) - rtn)
  70.     End If
  71.  
  72. End Sub
  73.  
  74. Function ErrorMsg(lErrorCode As Long) As String
  75.  
  76.     Select Case lErrorCode
  77.         Case 1009, 1015
  78.             GetErrorMsg = "The Registry Database is corrupt!"
  79.         Case 2, 1010
  80.             GetErrorMsg = "Bad Key Name"
  81.         Case 1011
  82.             GetErrorMsg = "Can't Open Key"
  83.         Case 4, 1012
  84.             GetErrorMsg = "Can't Read Key"
  85.         Case 5
  86.             GetErrorMsg = "Access to this key is denied"
  87.         Case 1013
  88.             GetErrorMsg = "Can't Write Key"
  89.         Case 8, 14
  90.             GetErrorMsg = "Out of memory"
  91.         Case 87
  92.             GetErrorMsg = "Invalid Parameter"
  93.         Case 234
  94.             GetErrorMsg = "There is more data than the buffer has been allocated to hold."
  95.         Case Else
  96.             GetErrorMsg = "Undefined Error Code:  " & Str$(lErrorCode)
  97.     End Select
  98.  
  99. End Function
  100.  
  101. Function GetMainKeyHandle(MainKeyName As String) As Long
  102.  
  103.     Const HKEY_LOCAL_MACHINE = &H80000002
  104.  
  105.     Select Case MainKeyName
  106.        Case "HKEY_LOCAL_MACHINE"
  107.             GetMainKeyHandle = HKEY_LOCAL_MACHINE
  108.     End Select
  109.  
  110. End Function
  111.  
  112. Function SetStringValue(SubKey As String, Entry As String, Value As String)
  113.  
  114.     Call ParseKey(SubKey, MainKeyHandle)
  115.  
  116.     If MainKeyHandle Then
  117.         rtn = RegOpenKeyEx(MainKeyHandle, SubKey, 0, KEY_WRITE, hkey)
  118.         If rtn = ERROR_SUCCESS Then
  119.             rtn = RegSetValueEx(hkey, Entry, 0, REG_SZ, ByVal Value, Len(Value))
  120.             If Not rtn = ERROR_SUCCESS Then
  121.                 If DisplayErrorMsg = True Then
  122.                     MsgBox ErrorMsg(rtn)
  123.                 End If
  124.             End If
  125.             rtn = RegCloseKey(hkey)
  126.         Else
  127.             If DisplayErrorMsg = True Then
  128.                 MsgBox ErrorMsg(rtn)
  129.             End If
  130.         End If
  131.     End If
  132.  
  133. End Function
  134.  
  135. Function CreateKey(SubKey As String)
  136.  
  137.     Call ParseKey(SubKey, MainKeyHandle)
  138.  
  139.     If MainKeyHandle Then
  140.         rtn = RegCreateKey(MainKeyHandle, SubKey, hkey)
  141.         If rtn = ERROR_SUCCESS Then
  142.             rtn = RegCloseKey(hkey)
  143.         End If
  144.     End If
  145.  
  146. End Function
  147.  
  148.  
  149.