home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 1_2002.ISO / Data / Zips / CODE_UPLOAD99219152000.psc / Module1.bas < prev    next >
Encoding:
BASIC Source File  |  2000-09-16  |  9.9 KB  |  336 lines
  1. Attribute VB_Name = "Module1"
  2. Option Explicit
  3. '/--------------------------------------------------\
  4. '| I've added extra registry functions for your use |
  5. '| Feel free to change the function titles          |
  6. '\--------------------------------------------------/
  7.  
  8. Public Const HKEY_CLASSES_ROOT = &H80000000
  9. Public Const HKEY_CURRENT_USER = &H80000001
  10. Public Const HKEY_LOCAL_MACHINE = &H80000002
  11. Public Const HKEY_USERS = &H80000003
  12. Public Const HKEY_PERFORMANCE_DATA = &H80000004
  13. Public Const HKEY_CURRENT_CONFIG = &H80000005
  14. Public Const HKEY_DYN_DATA = &H80000006
  15. Public Const REG_SZ = 1                         ' Unicode nul terminated string
  16. Public Const REG_BINARY = 3                     ' Free form binary
  17. Public Const REG_DWORD = 4                      ' 32-bit number
  18. Public Const ERROR_SUCCESS = 0&
  19.  
  20. Public Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
  21. Public Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
  22. Public Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
  23. Public Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey As String) As Long
  24. Public Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal hKey As Long, ByVal lpValueName As String) As Long
  25. '--------------------------------------------------
  26. Public Declare Function RegEnumKey Lib "advapi32.dll" Alias "RegEnumKeyA" (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpName As String, ByVal cbName As Long) As Long
  27. Public Declare Function RegEnumValue Lib "advapi32.dll" Alias "RegEnumValueA" (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpValueName As String, lpcbValueName As Long, lpReserved As Long, lpType As Long, lpData As Byte, lpcbData As Long) As Long
  28. '--------------------------------------------------
  29. Public Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long
  30. Public 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
  31.  
  32. Public Sub CreateKey(hKey As Long, strPath As String)
  33. Dim hCurKey As Long
  34. Dim lRegResult As Long
  35.  
  36. lRegResult = RegCreateKey(hKey, strPath, hCurKey)
  37.  
  38. If lRegResult <> ERROR_SUCCESS Then
  39.   ' there is a problem
  40. End If
  41.  
  42. lRegResult = RegCloseKey(hCurKey)
  43.  
  44. End Sub
  45.  
  46. Public Sub DeleteKey(ByVal hKey As Long, ByVal strPath As String)
  47. Dim lRegResult As Long
  48.  
  49. lRegResult = RegDeleteKey(hKey, strPath)
  50.  
  51. End Sub
  52.  
  53. Public Sub DeleteValue(ByVal hKey As Long, ByVal strPath As String, ByVal strValue As String)
  54. Dim hCurKey As Long
  55. Dim lRegResult As Long
  56.  
  57. lRegResult = RegOpenKey(hKey, strPath, hCurKey)
  58.  
  59. lRegResult = RegDeleteValue(hCurKey, strValue)
  60.  
  61. lRegResult = RegCloseKey(hCurKey)
  62.  
  63. End Sub
  64.  
  65. Public Function GetSettingString(hKey As Long, strPath As String, strValue As String, Optional Default As String) As String
  66. Dim hCurKey As Long
  67. Dim lValueType As Long
  68. Dim strBuffer As String
  69. Dim lDataBufferSize As Long
  70. Dim intZeroPos As Integer
  71. Dim lRegResult As Long
  72.  
  73. ' Set up default value
  74. If Not IsEmpty(Default) Then
  75.   GetSettingString = Default
  76. Else
  77.   GetSettingString = ""
  78. End If
  79.  
  80. ' Open the key and get length of string
  81. lRegResult = RegOpenKey(hKey, strPath, hCurKey)
  82. lRegResult = RegQueryValueEx(hCurKey, strValue, 0&, lValueType, ByVal 0&, lDataBufferSize)
  83.  
  84. If lRegResult = ERROR_SUCCESS Then
  85.  
  86.   If lValueType = REG_SZ Then
  87.     ' initialise string buffer and retrieve string
  88.     strBuffer = String(lDataBufferSize, " ")
  89.     lRegResult = RegQueryValueEx(hCurKey, strValue, 0&, 0&, ByVal strBuffer, lDataBufferSize)
  90.     
  91.     ' format string
  92.     intZeroPos = InStr(strBuffer, Chr$(0))
  93.     If intZeroPos > 0 Then
  94.       GetSettingString = Left$(strBuffer, intZeroPos - 1)
  95.     Else
  96.       GetSettingString = strBuffer
  97.     End If
  98.  
  99.   End If
  100.  
  101. Else
  102.   ' there is a problem
  103. End If
  104.  
  105. lRegResult = RegCloseKey(hCurKey)
  106. End Function
  107.  
  108. Public Sub SaveSettingString(hKey As Long, strPath As String, strValue As String, strData As String)
  109. Dim hCurKey As Long
  110. Dim lRegResult As Long
  111.  
  112. lRegResult = RegCreateKey(hKey, strPath, hCurKey)
  113.  
  114. lRegResult = RegSetValueEx(hCurKey, strValue, 0, REG_SZ, ByVal strData, Len(strData))
  115.  
  116. If lRegResult <> ERROR_SUCCESS Then
  117.   'there is a problem
  118. End If
  119.  
  120. lRegResult = RegCloseKey(hCurKey)
  121. End Sub
  122.  
  123. Public Function GetSettingLong(ByVal hKey As Long, ByVal strPath As String, ByVal strValue As String, Optional Default As Long) As Long
  124.  
  125. Dim lRegResult As Long
  126. Dim lValueType As Long
  127. Dim lBuffer As Long
  128. Dim lDataBufferSize As Long
  129. Dim hCurKey As Long
  130.  
  131. ' Set up default value
  132. If Not IsEmpty(Default) Then
  133.   GetSettingLong = Default
  134. Else
  135.   GetSettingLong = 0
  136. End If
  137.  
  138. lRegResult = RegOpenKey(hKey, strPath, hCurKey)
  139. lDataBufferSize = 4       ' 4 bytes = 32 bits = long
  140.  
  141. lRegResult = RegQueryValueEx(hCurKey, strValue, 0&, lValueType, lBuffer, lDataBufferSize)
  142.  
  143. If lRegResult = ERROR_SUCCESS Then
  144.  
  145.   If lValueType = REG_DWORD Then
  146.     GetSettingLong = lBuffer
  147.   End If
  148.  
  149. Else
  150.   'there is a problem
  151. End If
  152.  
  153. lRegResult = RegCloseKey(hCurKey)
  154.  
  155. End Function
  156.  
  157. Public Sub SaveSettingLong(ByVal hKey As Long, ByVal strPath As String, ByVal strValue As String, ByVal lData As Long)
  158. Dim hCurKey As Long
  159. Dim lRegResult As Long
  160.  
  161. lRegResult = RegCreateKey(hKey, strPath, hCurKey)
  162.  
  163. lRegResult = RegSetValueEx(hCurKey, strValue, 0&, REG_DWORD, lData, 4)
  164.  
  165. If lRegResult <> ERROR_SUCCESS Then
  166.   'there is a problem
  167. End If
  168.  
  169. lRegResult = RegCloseKey(hCurKey)
  170. End Sub
  171.  
  172. Public Function GetSettingByte(ByVal hKey As Long, ByVal strPath As String, ByVal strValueName As String, Optional Default As Variant) As Variant
  173. Dim lValueType As Long
  174. Dim byBuffer() As Byte
  175. Dim lDataBufferSize As Long
  176. Dim lRegResult As Long
  177. Dim hCurKey As Long
  178.  
  179. ' setup default value
  180. If Not IsEmpty(Default) Then
  181.   If VarType(Default) = vbArray + vbByte Then
  182.     GetSettingByte = Default
  183.   Else
  184.     GetSettingByte = 0
  185.   End If
  186.  
  187. Else
  188.   GetSettingByte = 0
  189. End If
  190.  
  191. ' Open the key and get number of bytes
  192. lRegResult = RegOpenKey(hKey, strPath, hCurKey)
  193. lRegResult = RegQueryValueEx(hCurKey, strValueName, 0&, lValueType, ByVal 0&, lDataBufferSize)
  194.  
  195. If lRegResult = ERROR_SUCCESS Then
  196.  
  197.   If lValueType = REG_BINARY Then
  198.   
  199.     ' initialise buffers and retrieve value
  200.     ReDim byBuffer(lDataBufferSize - 1) As Byte
  201.     lRegResult = RegQueryValueEx(hCurKey, strValueName, 0&, lValueType, byBuffer(0), lDataBufferSize)
  202.     
  203.     GetSettingByte = byBuffer
  204.  
  205.   End If
  206.  
  207. Else
  208.   'there is a problem
  209. End If
  210.  
  211. lRegResult = RegCloseKey(hCurKey)
  212.  
  213. End Function
  214.  
  215. Public Sub SaveSettingByte(ByVal hKey As Long, ByVal strPath As String, ByVal strValueName As String, byData() As Byte)
  216. ' Make sure that the array starts with element 0 before passing it!
  217. ' (otherwise it will not be saved!)
  218.  
  219. Dim lRegResult As Long
  220. Dim hCurKey As Long
  221.  
  222. lRegResult = RegCreateKey(hKey, strPath, hCurKey)
  223.  
  224. ' Pass the first array element and length of array
  225. lRegResult = RegSetValueEx(hCurKey, strValueName, 0&, REG_BINARY, byData(0), UBound(byData()) + 1)
  226.  
  227. lRegResult = RegCloseKey(hCurKey)
  228.  
  229. End Sub
  230.  
  231. Public Function GetAllKeys(hKey As Long, strPath As String) As Variant
  232. ' Returns: an array in a variant of strings
  233.  
  234. Dim lRegResult As Long
  235. Dim lCounter As Long
  236. Dim hCurKey As Long
  237. Dim strBuffer As String
  238. Dim lDataBufferSize As Long
  239. Dim strNames() As String
  240. Dim intZeroPos As Integer
  241.  
  242. lCounter = 0
  243.  
  244. lRegResult = RegOpenKey(hKey, strPath, hCurKey)
  245.  
  246. Do
  247.  
  248.   'initialise buffers (longest possible length=255)
  249.   lDataBufferSize = 255
  250.   strBuffer = String(lDataBufferSize, " ")
  251.   lRegResult = RegEnumKey(hCurKey, lCounter, strBuffer, lDataBufferSize)
  252.  
  253.   If lRegResult = ERROR_SUCCESS Then
  254.   
  255.     'tidy up string and save it
  256.     ReDim Preserve strNames(lCounter) As String
  257.     
  258.     intZeroPos = InStr(strBuffer, Chr$(0))
  259.     If intZeroPos > 0 Then
  260.       strNames(UBound(strNames)) = Left$(strBuffer, intZeroPos - 1)
  261.     Else
  262.       strNames(UBound(strNames)) = strBuffer
  263.     End If
  264.  
  265.     lCounter = lCounter + 1
  266.  
  267.   Else
  268.     Exit Do
  269.   End If
  270. Loop
  271.  
  272. GetAllKeys = strNames
  273. End Function
  274.  
  275. Public Function GetAllValues(hKey As Long, strPath As String) As Variant
  276. ' Returns: a 2D array.
  277. ' (x,0) is value name
  278. ' (x,1) is value type (see constants)
  279.  
  280. Dim lRegResult As Long
  281. Dim hCurKey As Long
  282. Dim lValueNameSize As Long
  283. Dim strValueName As String
  284. Dim lCounter As Long
  285. Dim byDataBuffer(4000) As Byte
  286. Dim lDataBufferSize As Long
  287. Dim lValueType As Long
  288. Dim strNames() As String
  289. Dim lTypes() As Long
  290. Dim intZeroPos As Integer
  291.  
  292. lRegResult = RegOpenKey(hKey, strPath, hCurKey)
  293.  
  294. Do
  295.   ' Initialise bufffers
  296.   lValueNameSize = 255
  297.   strValueName = String$(lValueNameSize, " ")
  298.   lDataBufferSize = 4000
  299.   
  300.   lRegResult = RegEnumValue(hCurKey, lCounter, strValueName, lValueNameSize, 0&, lValueType, byDataBuffer(0), lDataBufferSize)
  301.   
  302.   If lRegResult = ERROR_SUCCESS Then
  303.     
  304.     ' Save the type
  305.     ReDim Preserve strNames(lCounter) As String
  306.     ReDim Preserve lTypes(lCounter) As Long
  307.     lTypes(UBound(lTypes)) = lValueType
  308.     
  309.     'Tidy up string and save it
  310.     intZeroPos = InStr(strValueName, Chr$(0))
  311.     If intZeroPos > 0 Then
  312.       strNames(UBound(strNames)) = Left$(strValueName, intZeroPos - 1)
  313.     Else
  314.       strNames(UBound(strNames)) = strValueName
  315.     End If
  316.  
  317.     lCounter = lCounter + 1
  318.  
  319.   Else
  320.     Exit Do
  321.   End If
  322. Loop
  323.  
  324. 'Move data into array
  325. Dim Finisheddata() As Variant
  326. ReDim Finisheddata(UBound(strNames), 0 To 1) As Variant
  327.  
  328. For lCounter = 0 To UBound(strNames)
  329.   Finisheddata(lCounter, 0) = strNames(lCounter)
  330.   Finisheddata(lCounter, 1) = lTypes(lCounter)
  331. Next
  332.  
  333. GetAllValues = Finisheddata
  334.  
  335. End Function
  336.