home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 5_2007-2008.ISO / data / Zips / RegEdit_2_2049892242007.psc / RegEdit / clsRegistryAccess.cls < prev    next >
Text File  |  2007-02-13  |  32KB  |  783 lines
  1. VERSION 1.0 CLASS
  2. BEGIN
  3.   MultiUse = -1  'True
  4.   Persistable = 0  'NotPersistable
  5.   DataBindingBehavior = 0  'vbNone
  6.   DataSourceBehavior  = 0  'vbNone
  7.   MTSTransactionMode  = 0  'NotAnMTSObject
  8. END
  9. Attribute VB_Name = "clsRegistryAccess"
  10. Attribute VB_GlobalNameSpace = False
  11. Attribute VB_Creatable = True
  12. Attribute VB_PredeclaredId = False
  13. Attribute VB_Exposed = False
  14.                                                          '
  15. Option Explicit
  16.  
  17. Private Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
  18. Private 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
  19. Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
  20. Private Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
  21. 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, ByVal lpSecurityAttributes As Long, phkResult As Long, ByVal lpdwDisposition As Long) As Long
  22. Private Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey As String) As Long
  23. 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
  24. 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
  25. Private 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
  26. Private Declare Function RegQueryValueExA Lib "advapi32.dll" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, ByRef lpData As Long, lpcbData As Long) As Long
  27. Private Declare Function RegRestoreKey Lib "advapi32.dll" Alias "RegRestoreKeyA" (ByVal hKey As Long, ByVal lpFile As String, ByVal dwFlags As Long) As Long
  28. Private Declare Function RegSaveKey Lib "advapi32.dll" Alias "RegSaveKeyA" (ByVal hKey As Long, ByVal lpFile As String, ByVal lpSecurityAttributes As Long) As Long
  29. 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
  30. Private Declare Function RegSetValueExA Lib "advapi32.dll" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, ByRef lpData As Long, ByVal cbData As Long) As Long
  31. Private Declare Function RegSetValueExB Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, ByRef lpData As Byte, ByVal cbData As Long) As Long
  32. Private Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal hKey As Long, ByVal lpValueName As String) As Long
  33.  
  34. Private Declare Function GetCurrentProcess Lib "kernel32" () As Long
  35. Private Declare Function OpenProcessToken Lib "advapi32.dll" (ByVal ProcessHandle As Long, ByVal DesiredAccess As Long, TokenHandle As Long) As Long
  36. Private Declare Function LookupPrivilegeValue Lib "advapi32.dll" Alias "LookupPrivilegeValueA" (ByVal lpSystemName As String, ByVal lpName As String, lpLuid As LUID) As Long
  37. Private Declare Function AdjustTokenPrivileges Lib "advapi32.dll" (ByVal TokenHandle As Long, ByVal DisableAllPrivileges As Long, NewState As TOKEN_PRIVILEGES, ByVal BufferLength As Long, ByVal PreviousState As Long, ByVal ReturnLength As Long) As Long
  38.  
  39. Private Const ERROR_SUCCESS = 0&
  40. Private Const ERROR_BADDB = 1009&
  41. Private Const ERROR_BADKEY = 1010&
  42. Private Const ERROR_CANTOPEN = 1011&
  43. Private Const ERROR_CANTREAD = 1012&
  44. Private Const ERROR_CANTWRITE = 1013&
  45. Private Const ERROR_OUTOFMEMORY = 14&
  46. Private Const ERROR_INVALID_PARAMETER = 87&
  47. Private Const ERROR_FILE_NOT_FOUND = 2&
  48. Private Const ERROR_ACCESS_DENIED = 5&
  49. Private Const ERROR_NO_MORE_ITEMS = 259&
  50. Private Const ERROR_MORE_DATA = 234&
  51. Private Const KEY_QUERY_VALUE = &H1&
  52. Private Const KEY_SET_VALUE = &H2&
  53. Private Const KEY_CREATE_SUB_KEY = &H4&
  54. Private Const KEY_ENUMERATE_SUB_KEYS = &H8&
  55. Private Const KEY_NOTIFY = &H10&
  56. Private Const KEY_CREATE_LINK = &H20&
  57. Private Const READ_CONTROL = &H20000
  58. Private Const WRITE_DAC = &H40000
  59. Private Const WRITE_OWNER = &H80000
  60. Private Const SYNCHRONIZE = &H100000
  61. Private Const STANDARD_RIGHTS_REQUIRED = &HF0000
  62. Private Const STANDARD_RIGHTS_READ = READ_CONTROL
  63. Private Const STANDARD_RIGHTS_WRITE = READ_CONTROL
  64. Private Const STANDARD_RIGHTS_EXECUTE = READ_CONTROL
  65. Private Const STANDARD_RIGHTS_ALL = &H1F0000
  66. Private Const KEY_READ = STANDARD_RIGHTS_READ Or KEY_QUERY_VALUE Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY
  67. Private Const KEY_WRITE = STANDARD_RIGHTS_WRITE Or KEY_SET_VALUE Or KEY_CREATE_SUB_KEY
  68. Private Const KEY_EXECUTE = KEY_READ
  69. 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))
  70. Private Const REG_FORCE_RESTORE = &H8
  71. Private Const TOKEN_ADJUST_PRIVLEGES = &H20
  72. Private Const TOKEN_QUERY = &H8
  73. Private Const SE_PRIVILEGE_ENABLED = &H2
  74. Private Const SE_RESTORE_NAME = "SeRestorePrivilege"
  75. Private Const SE_BACKUP_NAME = "SeBackupPrivilege"
  76.  
  77. Private Type LUID
  78.     LowPart As Long
  79.     HighPart As Long
  80. End Type
  81.  
  82. Private Type LUID_AND_ATTRIBUTES
  83.     pLuid As LUID
  84.     Attributes As Long
  85. End Type
  86.  
  87. Private Type TOKEN_PRIVILEGES
  88.     PrivilegeCount As Long
  89.     Privileges(1) As LUID_AND_ATTRIBUTES
  90. End Type
  91.  
  92. Public Enum rcMainKey
  93.     HKEY_CLASSES_ROOT = &H80000000
  94.     HKEY_CURRENT_USER = &H80000001
  95.     HKEY_LOCAL_MACHINE = &H80000002
  96.     HKEY_USERS = &H80000003
  97.     HKEY_PERFORMANCE_DATA = &H80000004
  98.     HKEY_CURRENT_CONFIG = &H80000005
  99.     HKEY_DYN_DATA = &H80000006
  100. End Enum
  101.  
  102. Public Enum rcRegType
  103.     REG_NONE = 0
  104.     REG_SZ = 1
  105.     REG_EXPAND_SZ = 2
  106.     REG_BINARY = 3
  107.     REG_DWORD = 4
  108.     REG_DWORD_LITTLE_ENDIAN = 4
  109.     REG_DWORD_BIG_ENDIAN = 5
  110.     REG_LINK = 6
  111.     REG_MULTI_SZ = 7
  112.     REG_RESOURCE_LIST = 8
  113.     REG_FULL_RESOURCE_DESCRIPTOR = 9
  114.     REG_RESOURCE_REQUIREMENTS_LIST = 10
  115. End Enum
  116.  
  117. Public Enum convertBINType
  118.     BIN_Bin = 0
  119.     BIN_Array = 1
  120.     BIN_Dot = 2
  121.     BIN_String = 3
  122. End Enum
  123.  
  124. Private hKey             As Long
  125. Private mainKey          As Long
  126. Private sKey             As String
  127. Private createNoExists   As Boolean
  128. Private lReturn As Long
  129.  
  130. Private m_hToken As Long
  131. Private m_TP As TOKEN_PRIVILEGES
  132. Private m_RestoreLuid As LUID
  133. Private m_BackupLuid As LUID
  134.  
  135. Private Const SITUATION_BASE As Long = 13800
  136.  
  137. Public Property Let CreateKeyIfDoesntExists(ByVal offon As Boolean)
  138. Attribute CreateKeyIfDoesntExists.VB_Description = "Let/Get. Should key will be created if no exists (when writting data to registry)"
  139.     createNoExists = offon
  140. End Property
  141.  
  142. Public Property Get CreateKeyIfDoesntExists() As Boolean
  143.     CreateKeyIfDoesntExists = createNoExists
  144. End Property
  145.  
  146. Private Function GetKeys(sPath As String, sKey As String) As rcMainKey
  147. Dim pos As Long, mk As String
  148.     
  149.     sPath = Replace$(sPath, "HKEY_CURRENT_USER", "HKCU", , , 1)
  150.     sPath = Replace$(sPath, "HKEY_LOCAL_MACHINE", "HKLM", , , 1)
  151.     sPath = Replace$(sPath, "HKEY_CLASSES_ROOT", "HKCR", , , 1)
  152.     sPath = Replace$(sPath, "HKEY_USERS", "HKUS", , , 1)
  153.     sPath = Replace$(sPath, "HKEY_PERFORMANCE_DATA", "HKPD", , , 1)
  154.     sPath = Replace$(sPath, "HKEY_DYN_DATA", "HKDD", , , 1)
  155.     sPath = Replace$(sPath, "HKEY_CURRENT_CONFIG", "HKCC", , , 1)
  156.     
  157.     pos = InStr(1, sPath, "\")
  158.  
  159.     If (pos = 0) Then
  160.         mk = UCase$(sPath)
  161.         sKey = ""
  162.     Else
  163.         mk = UCase$(Left$(sPath, 4))
  164.         sKey = Right$(sPath, Len(sPath) - pos)
  165.     End If
  166.     
  167.     Select Case mk
  168.         Case "HKCU": GetKeys = HKEY_CURRENT_USER
  169.         Case "HKLM": GetKeys = HKEY_LOCAL_MACHINE
  170.         Case "HKCR": GetKeys = HKEY_CLASSES_ROOT
  171.         Case "HKUS": GetKeys = HKEY_USERS
  172.         Case "HKPD": GetKeys = HKEY_PERFORMANCE_DATA
  173.         Case "HKDD": GetKeys = HKEY_DYN_DATA
  174.         Case "HKCC": GetKeys = HKEY_CURRENT_CONFIG
  175.     End Select
  176.     
  177. End Function
  178.  
  179. Public Function CreateKey(ByVal sPath As String) As Long
  180. Attribute CreateKey.VB_Description = "Creates key in registry..."
  181.     hKey = GetKeys(sPath, sKey)
  182.     
  183.     If (RegCreateKey(hKey, sKey, mainKey) = ERROR_SUCCESS) Then
  184.         RegCloseKey mainKey
  185.         CreateKey = mainKey
  186.     Else
  187.         CreateKey = 0
  188.     End If
  189. End Function
  190.  
  191. Public Function KillKey(ByVal sPath As String) As Long
  192. Attribute KillKey.VB_Description = "Deletes key from registry..."
  193.     Dim sKeys() As String, nKeys As Long, nIdx As Long
  194.     nKeys = EnumKeys(sPath, sKeys)
  195.     If nKeys > 0 Then
  196.         For nIdx = 0 To nKeys - 1
  197.             KillKey sPath & "\" & sKeys(nIdx)
  198.         Next nIdx
  199.     End If
  200.     hKey = GetKeys(sPath, sKey)
  201.     
  202.     If (RegOpenKeyEx(hKey, sKey, 0, KEY_ALL_ACCESS, mainKey) = ERROR_SUCCESS) Then
  203.         RegDeleteKey mainKey, ""
  204.         RegCloseKey mainKey
  205.         KillKey = mainKey
  206.     Else
  207.         KillKey = 0
  208.     End If
  209. End Function
  210.  
  211. Public Function KeyExists(ByVal sPath As String) As Boolean
  212.     hKey = GetKeys(sPath, sKey)
  213.     If (RegOpenKeyEx(hKey, sKey, 0, KEY_ALL_ACCESS, mainKey) = ERROR_SUCCESS) Then
  214.         KeyExists = True
  215.         RegCloseKey mainKey
  216.     Else
  217.         KeyExists = False
  218.     End If
  219. End Function
  220.  
  221. Public Function EnumKeys(ByVal sPath As String, ByRef Key() As String) As Long
  222. Attribute EnumKeys.VB_Description = "Enumerates subkeys of some key..."
  223.     Dim sName As String, retVal As Long
  224.     
  225.     hKey = GetKeys(sPath, sKey)
  226.     
  227.     Erase Key
  228.     
  229.     If (RegOpenKey(hKey, sKey, mainKey) = ERROR_SUCCESS) Then
  230.  
  231.         EnumKeys = 0
  232.         sName = String(255, 0)
  233.         retVal = Len(sName)
  234.         
  235.         lReturn = RegEnumKeyEx(mainKey, EnumKeys, sName, retVal, ByVal 0&, vbNullString, ByVal 0&, ByVal 0&)
  236.         While lReturn <> ERROR_BADDB And lReturn <> ERROR_BADKEY And lReturn <> ERROR_CANTOPEN And _
  237.             lReturn <> ERROR_CANTREAD And lReturn <> ERROR_CANTWRITE _
  238.             And lReturn <> ERROR_OUTOFMEMORY And lReturn <> ERROR_INVALID_PARAMETER _
  239.             And lReturn <> ERROR_ACCESS_DENIED And lReturn <> ERROR_NO_MORE_ITEMS
  240.             
  241.             ReDim Preserve Key(EnumKeys)
  242.             
  243.             Key(EnumKeys) = Left$(sName, retVal)
  244.                         
  245.             EnumKeys = EnumKeys + 1
  246.             sName = String(255, 0)
  247.             retVal = Len(sName)
  248.             
  249.             lReturn = RegEnumKeyEx(mainKey, EnumKeys, sName, retVal, ByVal 0&, vbNullString, ByVal 0&, ByVal 0&)
  250.         Wend
  251.     
  252.         RegCloseKey mainKey
  253.     Else
  254.         EnumKeys = -1
  255.     End If
  256. End Function
  257.  
  258. Public Function HaveSubkey(ByVal sPath As String) As Boolean
  259. Attribute HaveSubkey.VB_Description = "Checks for subkeys in some key..."
  260.     Dim sName As String, retVal As Long, SubKeyCount As Long
  261.     
  262.     hKey = GetKeys(sPath, sKey)
  263.     
  264.     If (RegOpenKey(hKey, sKey, mainKey) = ERROR_SUCCESS) Then 'try to open key
  265.  
  266.         SubKeyCount = 0
  267.         sName = String(255, 0)
  268.         retVal = Len(sName)
  269.         HaveSubkey = False
  270.         
  271.         lReturn = RegEnumKeyEx(mainKey, SubKeyCount, sName, retVal, ByVal 0&, vbNullString, ByVal 0&, ByVal 0&)
  272.         
  273.         Do While lReturn <> ERROR_BADDB And lReturn <> ERROR_BADKEY And lReturn <> ERROR_CANTOPEN And _
  274.             lReturn <> ERROR_CANTREAD And lReturn <> ERROR_CANTWRITE _
  275.             And lReturn <> ERROR_OUTOFMEMORY And lReturn <> ERROR_INVALID_PARAMETER _
  276.             And lReturn <> ERROR_ACCESS_DENIED And lReturn <> ERROR_NO_MORE_ITEMS
  277.             HaveSubkey = True
  278.             Exit Do
  279.         Loop
  280.     
  281.         RegCloseKey mainKey
  282.     Else
  283.         HaveSubkey = False
  284.     End If
  285. End Function
  286.  
  287. Public Function CreateValue(ByVal sPath As String, ByVal sName As String, ByVal nType As rcRegType) As Long
  288.     Select Case nType
  289.             Case rcRegType.REG_SZ: CreateValue = WriteString(sPath, sName, vbNullChar)
  290.             Case rcRegType.REG_BINARY: CreateValue = WriteBinary(sPath, sName, "")
  291.             Case rcRegType.REG_DWORD: CreateValue = WriteDWORD(sPath, sName, 0)
  292.             Case rcRegType.REG_MULTI_SZ: CreateValue = WriteString(sPath, sName, vbNullChar, REG_MULTI_SZ)
  293.             Case rcRegType.REG_EXPAND_SZ: CreateValue = WriteString(sPath, sName, vbNullChar, REG_EXPAND_SZ)
  294.             Case Else: CreateValue = 0: Exit Function
  295.     End Select
  296. End Function
  297.  
  298. Public Function WriteString(ByVal sPath As String, ByVal sName As String, ByVal sValue As String, Optional ByVal sType As rcRegType = rcRegType.REG_SZ) As Long
  299. Attribute WriteString.VB_Description = "Writes data of string type..."
  300.     If (KeyExists(sPath) = False) Then
  301.         If (createNoExists = True) Then
  302.             CreateKey sPath
  303.         Else
  304.             WriteString = 0
  305.             Exit Function
  306.         End If
  307.     End If
  308.     
  309.     hKey = GetKeys(sPath, sKey)
  310.  
  311.     If (sName = "@") Then sName = ""
  312.  
  313.     If (RegOpenKeyEx(hKey, sKey, 0, KEY_WRITE, mainKey) = ERROR_SUCCESS) Then
  314.         If (RegSetValueEx(mainKey, sName, 0, sType, ByVal sValue, Len(sValue)) = ERROR_SUCCESS) Then
  315.             RegCloseKey mainKey
  316.             WriteString = mainKey
  317.         Else
  318.             WriteString = 0
  319.       End If
  320.     Else
  321.          WriteString = 0
  322.     End If
  323. End Function
  324.  
  325. Public Function ReadString(ByVal sPath As String, ByVal sName As String, Optional sDefault As String = vbNullChar) As String
  326. Attribute ReadString.VB_Description = "Reads data of string type..."
  327.     Dim sData As String, lDuz As Long
  328.     
  329.     hKey = GetKeys(sPath, sKey)
  330.     
  331.     If (RegOpenKeyEx(hKey, sKey, 0, KEY_READ, mainKey) = ERROR_SUCCESS) Then
  332.         sData = String(255, 0)
  333.         lDuz = 255
  334.         
  335.         If (RegQueryValueEx(mainKey, sName, 0, REG_SZ, sData, lDuz) = ERROR_SUCCESS) Then
  336.             RegCloseKey mainKey
  337.             sData = Left$(sData, lDuz)
  338.             If Len(sData) > 0 Then ReadString = Left$(sData, Len(sData) - 1) Else: ReadString = sDefault
  339.         Else
  340.             ReadString = sDefault
  341.         End If
  342.     Else
  343.         ReadString = sDefault
  344.     End If
  345. End Function
  346.  
  347. Public Function WriteDWORD(ByVal sPath As String, ByVal sName As String, ByVal lValue As Long) As Long
  348. Attribute WriteDWORD.VB_Description = "Writes data of dword type..."
  349.     If (KeyExists(sPath) = False) Then
  350.         If (createNoExists = True) Then
  351.             CreateKey sPath
  352.         Else
  353.             WriteDWORD = 0
  354.             Exit Function
  355.         End If
  356.     End If
  357.     hKey = GetKeys(sPath, sKey)
  358.     If (RegOpenKeyEx(hKey, sKey, 0, KEY_WRITE, mainKey) = ERROR_SUCCESS) Then
  359.         If (RegSetValueExA(mainKey, sName, 0, REG_DWORD, lValue, 4) = ERROR_SUCCESS) Then
  360.             RegCloseKey mainKey
  361.             WriteDWORD = mainKey
  362.         Else
  363.             WriteDWORD = 0
  364.         End If
  365.     Else
  366.         WriteDWORD = 0
  367.     End If
  368. End Function
  369.  
  370. Public Function ReadDWORD(ByVal sPath As String, ByVal sName As String, Optional lDefault As Double = -1) As Long
  371. Attribute ReadDWORD.VB_Description = "Reads data of dword type..."
  372.     Dim lData As Long
  373.     hKey = GetKeys(sPath, sKey)
  374.     If (RegOpenKeyEx(hKey, sKey, 0, KEY_READ, mainKey) = ERROR_SUCCESS) Then
  375.         If (RegQueryValueExA(mainKey, sName, 0, REG_DWORD, lData, 4) = ERROR_SUCCESS) Then
  376.             RegCloseKey mainKey
  377.             ReadDWORD = lData
  378.         Else
  379.             ReadDWORD = lDefault
  380.         End If
  381.     Else
  382.         ReadDWORD = lDefault
  383.     End If
  384. End Function
  385.  
  386. Public Function WriteBinary(ByVal sPath As String, ByVal sName As String, _
  387.                                                    ByVal sValue As String) As Long
  388. Attribute WriteBinary.VB_Description = "Writes data of binary type..."
  389.     Dim L As Long, lDuz As Long, B() As Byte
  390.     
  391.     If (KeyExists(sPath) = False) Then
  392.         If (createNoExists = True) Then
  393.             CreateKey sPath
  394.         Else
  395.             WriteBinary = 0
  396.             Exit Function
  397.         End If
  398.     End If
  399.  
  400.     hKey = GetKeys(sPath, sKey)
  401.     
  402.     sValue = StrToBin(sValue)
  403.     
  404.     If (RegOpenKeyEx(hKey, sKey, 0, KEY_WRITE, mainKey) = ERROR_SUCCESS) Then
  405.       
  406.         lDuz = Len(sValue)
  407.         ReDim B(lDuz) As Byte
  408.       
  409.         For L = 1 To lDuz
  410.             B(L) = Asc(Mid$(sValue, L, 1))
  411.         Next
  412.         
  413.         If (lDuz = 0) Then
  414.             ReDim B(1) As Byte
  415.             B(1) = 0
  416.         End If
  417.         
  418.         If (RegSetValueExB(mainKey, sName, 0, REG_BINARY, B(1), lDuz) = ERROR_SUCCESS) Then
  419.             RegCloseKey mainKey
  420.             WriteBinary = mainKey
  421.         Else
  422.             WriteBinary = 0
  423.         End If
  424.     Else
  425.          WriteBinary = 0
  426.     End If
  427.  
  428. End Function
  429.  
  430. Public Function ReadBinary(ByVal sPath As String, ByVal sName As String, Optional sDefault As String = vbNullString, Optional ByVal convertTo As convertBINType = BIN_Bin, Optional ByVal posBegin As Long = 1, Optional ByVal totalBytes As Long = 0) As Variant
  431.     Dim arrData() As Byte, lDuz As Long
  432.     Dim sData As String, strData As String, cData As Integer, nI As Long
  433.     ReDim arrData(0 To 1) As Byte
  434.     arrData(0) = 0
  435.     hKey = GetKeys(sPath, sKey)
  436.     If (RegOpenKeyEx(hKey, sKey, 0, KEY_READ, mainKey) = ERROR_SUCCESS) Then
  437.         lDuz = 1
  438.         RegQueryValueEx mainKey, sName, 0, REG_BINARY, 0, lDuz
  439.         sData = String(lDuz, 0)
  440.         If lDuz > 0 Then
  441.             RegQueryValueEx mainKey, sName, 0, REG_BINARY, sData, lDuz
  442.             RegCloseKey mainKey
  443.             If totalBytes = 0 Then totalBytes = lDuz Else sData = Mid(sData, posBegin, totalBytes)
  444.             Select Case convertTo
  445.                 Case BIN_Array
  446.                     ReDim arrData(totalBytes - 1) As Byte
  447.                     For nI = 1 To totalBytes
  448.                         arrData(nI - 1) = Asc(Mid$(sData, nI, 1))
  449.                     Next
  450.                     ReadBinary = arrData
  451.                 Case BIN_String
  452.                     ReadBinary = sData
  453.                 Case BIN_Dot
  454.                     strData = ""
  455.                     For nI = 1 To totalBytes
  456.                         cData = Asc(Mid$(sData, nI, 1))
  457.                         If cData < 33 Or (cData > 126 And cData < 144) Or (cData > 147 And cData < 161) Then
  458.                             strData = strData & "."
  459.                         Else
  460.                             strData = strData & Mid$(sData, nI, 1)
  461.                         End If
  462.                         If nI > 0 And nI Mod 8 = 0 Then strData = strData & Chr$(13)
  463.                     Next
  464.                     ReadBinary = strData
  465.                 Case BIN_Bin
  466.                     ReadBinary = Trim$(BinToStr(sData))
  467.             End Select
  468.         Else
  469.             ReadBinary = sDefault
  470.         End If
  471.     Else
  472.         ReadBinary = sDefault
  473.     End If
  474. End Function
  475.  
  476. Public Function KillValue(ByVal sPath As String, ByVal sName As String) As Long
  477. Attribute KillValue.VB_Description = "Deletes value from registry..."
  478.  
  479.     hKey = GetKeys(sPath, sKey)
  480.     
  481.     If (RegOpenKeyEx(hKey, sKey, 0, KEY_ALL_ACCESS, mainKey) = ERROR_SUCCESS) Then
  482.         RegDeleteValue mainKey, sName
  483.         RegCloseKey mainKey
  484.         KillValue = mainKey
  485.     Else
  486.         KillValue = 0
  487.     End If
  488.     
  489. End Function
  490.  
  491. Public Function ValueExists(ByVal sPath As String, ByVal sName As String) As Boolean
  492. Attribute ValueExists.VB_Description = "Checks if some value exists in registry"
  493.     
  494.     hKey = GetKeys(sPath, sKey)
  495.     
  496.     Dim sData As String
  497.     
  498.     If (RegOpenKeyEx(hKey, sKey, 0, KEY_READ, mainKey) = ERROR_SUCCESS) Then
  499.         
  500.         If (RegQueryValueEx(mainKey, sName, 0, 0, sData, 1) = ERROR_SUCCESS) Then
  501.             RegCloseKey mainKey
  502.             ValueExists = True
  503.         Else
  504.             ValueExists = False
  505.         End If
  506.     Else
  507.         ValueExists = False
  508.     End If
  509.     
  510. End Function
  511.  
  512. Public Function EnumValues(ByVal sPath As String, ByRef sValue() As String, ByRef sData() As Variant, Optional ByVal OnlyType As rcRegType = -1) As Long
  513. Attribute EnumValues.VB_Description = "Enumerates all values from specified key..."
  514.     Const lengthVars = 2000
  515.     Dim rName As String
  516.     Dim rData As Long
  517.     Dim mKey As Long, rType As Long, Cnt As Long
  518.     Dim RetData As Long, retValue As Long
  519.     
  520.     hKey = GetKeys(sPath, sKey)
  521.     If RegOpenKey(hKey, sKey, mKey) = ERROR_SUCCESS Then
  522.         Cnt = 0
  523.         Erase sValue
  524.         Erase sData
  525.         Do
  526.             rName = String(lengthVars, 0)
  527.             retValue = lengthVars
  528.             RetData = lengthVars
  529.             lReturn = RegEnumValue(mKey, Cnt, ByVal rName, retValue, 0, rType, ByVal rData, RetData)
  530.             Cnt = Cnt + 1
  531.             If lReturn = ERROR_SUCCESS Then
  532.                 If (OnlyType = -1) Or (OnlyType = rType) Then
  533.                     ReDim Preserve sValue(EnumValues) As String
  534.                     ReDim Preserve sData(EnumValues) As Variant
  535.                     rName = Trim$(Left$(rName, retValue))
  536.                     sValue(EnumValues) = rName
  537.                     Select Case rType
  538.                         Case REG_SZ, REG_MULTI_SZ, REG_EXPAND_SZ
  539.                             sData(EnumValues) = ReadString(sPath, rName)
  540.                         Case REG_BINARY
  541.                             sData(EnumValues) = ReadBinary(sPath, rName)
  542.                         Case REG_DWORD
  543.                             sData(EnumValues) = ReadDWORD(sPath, rName)
  544.                     End Select
  545.                     EnumValues = EnumValues + 1
  546.                 End If
  547.             End If
  548.         Loop While lReturn = ERROR_SUCCESS
  549.         RegCloseKey hKey
  550.     Else
  551.         EnumValues = -1
  552.     End If
  553. End Function
  554.  
  555. Public Sub ExportToReg(ByVal sRegFile As String, ByVal sPath As String, Optional IncludeSubKeys As Boolean = True)
  556.     Dim fFile As Long
  557.     
  558.     sPath = Mid$(sPath, Len("My Computer\") + 1)
  559.     If sPath = "" Then Exit Sub
  560.     
  561.     fFile = FreeFile
  562.     Open sRegFile For Output As #fFile
  563.         Print #fFile, "Windows Registry Editor Version 5.00"
  564.         Print #fFile, vbCrLf & "[" & sPath & "]"
  565.         GenKey fFile, sPath, IncludeSubKeys
  566.     Close #fFile
  567. End Sub
  568.  
  569. Sub GenKey(ByVal fFile As Long, ByVal sPath As String, Optional IncludeSubKeys As Boolean = True)
  570.     Dim nK As Long, nV As Long, nT As Byte
  571.     Dim nKeys As Long, nValues As Long, sK As String
  572.     Dim Keys() As String, Values() As String, Datas() As Variant
  573.     Dim sVal As String, nS As Long
  574.     Dim arrTypes()
  575.     
  576.     arrTypes = Array(rcRegType.REG_SZ, rcRegType.REG_BINARY, rcRegType.REG_DWORD, rcRegType.REG_MULTI_SZ, rcRegType.REG_EXPAND_SZ)
  577.     
  578.     nKeys = EnumKeys(sPath, Keys())
  579.     For nT = 0 To 4
  580.         nValues = EnumValues(sPath, Values, Datas, arrTypes(nT))
  581.         For nV = 0 To nValues - 1
  582.             sVal = ""
  583.             Select Case arrTypes(nT)
  584.                 Case rcRegType.REG_SZ
  585.                     Datas(nV) = Chr$(34) & Datas(nV) & Chr$(34)
  586.                 Case rcRegType.REG_BINARY
  587.                     Datas(nV) = "hex:" & Replace$(Datas(nV), " ", ",", , , vbTextCompare)
  588.                 Case rcRegType.REG_DWORD
  589.                     Datas(nV) = "dword:" & frmRegEdit.Dbl2Hex(Datas(nV), 8)
  590.                 Case rcRegType.REG_MULTI_SZ, rcRegType.REG_EXPAND_SZ
  591.                     sVal = Datas(nV)
  592.                     Datas(nV) = ""
  593.                     For nS = 1 To Len(sVal)
  594.                         Datas(nV) = Datas(nV) & IIf(nS > 1, ",", "") & frmRegEdit.Dbl2Hex(Asc(Mid(sVal, nS, 1)), 2) & ",00"
  595.                     Next
  596.                     Datas(nV) = "hex(" & IIf(arrTypes(nT) = rcRegType.REG_MULTI_SZ, 7, 2) & "):" & Datas(nV) & IIf(Datas(nV) <> "", ",", "") & "00,00"
  597.             End Select
  598.             Print #fFile, Chr$(34) & Values(nV) & Chr$(34) & "=" & Datas(nV)
  599.         Next nV
  600.     Next nT
  601.     If nKeys > 0 Then
  602.         For nK = 0 To nKeys - 1
  603.             sK = sPath & "\" & CStr(Keys(nK))
  604.             Print #fFile, vbCrLf & "[" & sK & "]" & vbCrLf
  605.             If IncludeSubKeys Then GenKey fFile, sK, IncludeSubKeys
  606.         Next
  607.     End If
  608. End Sub
  609.  
  610. Public Sub ImportFromReg(ByVal sRegFile As String)
  611.     Dim fFile As Long
  612.     Dim Lines() As String, nL As Long, nP As Long
  613.     Dim cLine As String, curKey As String, vName As String, vData As String
  614.     
  615.     CreateKeyIfDoesntExists = True
  616.     
  617.     fFile = FreeFile
  618.     Open sRegFile For Binary As #fFile
  619.         Lines = Split(Replace$(Replace$(Replace$(Input(LOF(fFile), #fFile), Chr$(0), ""), Chr$(&HFF) & Chr$(&HFE), ""), "\" & vbCrLf, ""), vbCrLf)
  620.     Close #fFile
  621.     
  622.     If (UCase$(Lines(0)) <> UCase("Windows Registry Editor Version 5.00")) Then
  623.         MsgBox "Cannot import " & sRegFile & ": The specified file is not a registry file. You can import only registry files.", vbOKOnly + vbCritical, frmRegEdit.Caption
  624.         Exit Sub
  625.     End If
  626.  
  627.     curKey = ""
  628.     cLine = ""
  629.     For nL = 1 To UBound(Lines)
  630.         If Left$(Lines(nL), 1) = "[" Then
  631.             curKey = Mid$(Lines(nL), 2, Len(Lines(nL)) - 2)
  632.             CreateKey curKey
  633.         Else
  634.             cLine = Replace$(Trim$(Lines(nL)), ChrW$(34), "")
  635.             If curKey <> "" And cLine <> "" Then
  636.                 nP = InStr(1, cLine, "=", vbTextCompare)
  637.                 vName = Left$(cLine, nP - 1)
  638.                 vData = Mid$(cLine, nP + 1)
  639.                 If Len(vData) > 4 Then
  640.                     If Left$(vData, 4) = "hex:" Then
  641.                         vData = Replace$(Mid$(vData, 5), ",", " ", , , vbTextCompare)
  642.                         WriteBinary curKey, vName, vData
  643.                     Else
  644.                         If Left$(vData, 6) = "dword:" Then
  645.                             vData = Mid$(vData, 7)
  646.                             WriteDWORD curKey, vName, CDbl("&H" & vData)
  647.                         Else
  648.                             If Left$(vData, 7) = "hex(7):" Or Left$(vData, 7) = "hex(2):" Then
  649.                                 vData = Replace$(vData, ",", " ", , , vbTextCompare)
  650.                                 WriteString curKey, vName, Replace$(StrToBin(Mid(vData, 8)), Chr$(0), ""), IIf(Left$(vData, 7) = "hex(7):", REG_MULTI_SZ, REG_EXPAND_SZ)
  651.                             Else
  652.                                 WriteString curKey, vName, vData, REG_SZ
  653.                             End If
  654.                         End If
  655.                     End If
  656.                 Else
  657.                     WriteString curKey, vName, vData, REG_SZ
  658.                 End If
  659.             End If
  660.         End If
  661.     Next nL
  662. End Sub
  663.  
  664. Public Function StrToBin(sBin As String) As String
  665.     Dim sRes As String, nPos As Long
  666.     sBin = Trim$(Replace(sBin, " ", vbNullString))
  667.     sRes = ""
  668.     For nPos = 1 To Len(sBin) Step 2
  669.         sRes = sRes & ChrW$("&H" & Mid(sBin, nPos, 2))
  670.     Next nPos
  671.     StrToBin = sRes
  672. End Function
  673.  
  674. Public Function BinToStr(ByVal sStr As String, Optional ByVal isTruncate As Boolean = True) As String
  675. Attribute BinToStr.VB_Description = "Converts binary data into string..."
  676.     Const maxLen = 128
  677.     Dim retVal As String
  678.     Dim nI As Integer, sByte As String
  679.     If Len(sStr) = 0 Then GoTo zeroLength
  680.     If isTruncate Then If Len(sStr) > maxLen Then sStr = Left$(sStr, maxLen)
  681.     retVal = vbNullString
  682.     For nI = 1 To Len(sStr)
  683.         sByte = Mid$(sStr, nI, 1)
  684.         retVal = retVal & " "
  685.         If sByte = vbNullChar Then
  686.             retVal = retVal & "00"
  687.         Else
  688.             If Asc(sByte) < &HF Then retVal = retVal & "0"
  689.             retVal = retVal & Hex$(Asc(sByte))
  690.         End If
  691.     Next nI
  692. zeroLength:
  693.     BinToStr = retVal
  694. End Function
  695.  
  696. Public Function isBinValid(ByVal sBin As String) As Boolean
  697. Attribute isBinValid.VB_Description = "Checks if given binary data is in valid hex format (used for writting binary)"
  698.     Dim Z As Long
  699.     sBin = Trim$(UCase$(Replace(sBin, " ", vbNullString)))
  700.     If Len(sBin) = 0 Then GoTo zeroLength
  701.     For Z = 1 To Len(sBin)
  702.         If InStr(1, Mid$(sBin, Z, 1), "0123456789ABCDEF ", 1) < 1 Then
  703. zeroLength:
  704.            isBinValid = False
  705.            Exit Function
  706.         End If
  707.     Next
  708.     isBinValid = True
  709. End Function
  710.  
  711. Function renameKey(ByVal sKeySource As String, ByVal sNewName As String) As Boolean
  712.     Dim hKeySource As Long
  713.     Dim hKeyDestination As Long
  714.     Dim nResult As Long
  715.     Dim sFile As String
  716. On Error GoTo ErrHandler
  717.     sNewName = Mid(sKeySource, 1, InStrRev(sKeySource, "\")) & sNewName
  718.     hKey = GetKeys(sNewName, sKey)
  719.     sNewName = sKey
  720.     hKey = GetKeys(sKeySource, sKey)
  721.  
  722.     setBackupAndRestorePriviliges
  723.     sFile = App.Path & "\" & App.EXEName & "."
  724.     If Len(Dir(sFile)) > 0 Then Kill sFile
  725.     
  726.     'Check for exist of source
  727.     nResult = RegOpenKeyEx(hKey, sKey, 0&, KEY_ALL_ACCESS, hKeySource)
  728.     If nResult <> ERROR_SUCCESS Then GoTo ErrHandler
  729.     'Save old informations
  730.     nResult = RegSaveKey(hKeySource, sFile, 0&)
  731.     If nResult <> ERROR_SUCCESS Then GoTo ErrHandler
  732.     'Check for exist of destination
  733.     nResult = RegOpenKeyEx(hKey, sNewName, 0&, KEY_ALL_ACCESS, hKeyDestination)
  734.     If nResult <> ERROR_FILE_NOT_FOUND Then GoTo ErrHandler
  735.     'Try to delete source & re-check for self
  736.     If KillKey(sKeySource) = 0 Or KeyExists(sKeySource) Then GoTo ErrHandler
  737.     'If delete successfull then create new key
  738.     nResult = RegCreateKeyEx(hKey, sNewName, 0&, vbNullString, 0&, KEY_ALL_ACCESS, 0&, hKeyDestination, 0&)
  739.     If nResult <> ERROR_SUCCESS Then GoTo ErrHandler
  740.     'and restore old informations to new key
  741.     nResult = RegRestoreKey(hKeyDestination, sFile, REG_FORCE_RESTORE)
  742.     
  743.     resetBackupAndRestorePriviliges
  744.     If Len(Dir(sFile)) > 0 Then Kill sFile
  745.     renameKey = True
  746.     Exit Function
  747.  
  748. ErrHandler:
  749.     If Len(Dir(sFile)) > 0 Then Kill sFile
  750.     RegCloseKey hKeySource
  751.     RegCloseKey hKeyDestination
  752.     renameKey = False
  753. End Function
  754.  
  755. Private Sub setBackupAndRestorePriviliges()
  756.     Dim nResult As Long
  757. On Error GoTo ErrHandler
  758.     
  759.     nResult = OpenProcessToken(GetCurrentProcess, TOKEN_ADJUST_PRIVLEGES Or TOKEN_QUERY, m_hToken)
  760.     nResult = LookupPrivilegeValue(vbNullString, SE_RESTORE_NAME, m_RestoreLuid)
  761.     nResult = LookupPrivilegeValue(vbNullString, SE_BACKUP_NAME, m_BackupLuid)
  762.     
  763.     m_TP.PrivilegeCount = 2
  764.     m_TP.Privileges(0).pLuid = m_RestoreLuid
  765.     m_TP.Privileges(0).Attributes = SE_PRIVILEGE_ENABLED
  766.     m_TP.Privileges(1).pLuid = m_BackupLuid
  767.     m_TP.Privileges(1).Attributes = SE_PRIVILEGE_ENABLED
  768.     
  769.     nResult = AdjustTokenPrivileges(m_hToken, vbFalse, m_TP, Len(m_TP), 0&, 0&)
  770. ErrHandler:
  771. End Sub
  772.  
  773. Private Sub resetBackupAndRestorePriviliges()
  774.     Dim nResult As Long
  775. On Error GoTo ErrHandler
  776.     nResult = AdjustTokenPrivileges(m_hToken, vbTrue, m_TP, Len(m_TP), 0&, 0&)
  777. ErrHandler:
  778. End Sub
  779.  
  780. Private Sub Class_Initialize()
  781.     CreateKeyIfDoesntExists = True
  782. End Sub
  783.