modregistry.bas

高级卸载工具

Attribute VB_Name = "ModRegistry"
'★★★★★****************************★★★★★**********************★★★★★
'金诺VB园-收藏整理
'本站是专注于VB和VBNET编程的源码下载站
'发布日期：2008-3-14 22:00:47
'网    站：http://www.vbget.com/          (金诺VB园)
'网    站：http://www.vbget.com/daohan/   (VB编程网址导航)
'E-Mail  ：[e-mail]
'QQ      ：158676144
'源码作者：如果您有VB商业源码需要获得收益，本站将有VIP收费下载频道可供你发布!
'         您有权定价;改价;删除;及即时查看下载量(即收益)，所有收益全部归您！
'         本站将在双方协商的一个金额周期内打款到作者帐户中，您只需负责打款费用！
'         本站只作为一个平台提供最新VB源码咨讯和源码下载！
'本注释由<站长工具之智能注释>软件自动添加！金诺VB园有此软件下载！
'★★★★★****************************★★★★★**********************★★★★★


Option Explicit

Public Const ERROR_SUCCESS = 0&
Private Const ERROR_MORE_DATA = 234

' Registry data types
Private Const REG_SZ = 1
Private Const REG_EXPAND_SZ = 2
Private Const REG_BINARY = 3
Private Const REG_DWORD = 4
Private Const REG_MULTI_SZ = 7

' Registry security attributes
Private Const KEY_QUERY_VALUE = &H1
Private Const KEY_ENUMERATE_SUB_KEYS = &H8

Private Const KEY_NOTIFY = &H10&
Private Const READ_CONTROL = &H20000
Private Const STANDARD_RIGHTS_READ = READ_CONTROL
Private Const KEY_READ = STANDARD_RIGHTS_READ Or KEY_QUERY_VALUE Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY

Public Enum HKeyTypes
    HKEY_LOCAL_MACHINE = &H80000002
End Enum

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
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hkey As Long) As Long
Private Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hkey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Private Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal hkey As Long, ByVal lpSubKey As String) As Long
Private Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal hkey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Private 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
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, lpData As Any, ByVal cbData As Long) As Long
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
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
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (dest As Any, source As Any, ByVal numBytes As Long)

Public Sub SaveString(hkey As HKeyTypes, strPath As String, strValue As String, strdata As String)
    Dim keyhand As Long, R As Long
    
    R = RegCreateKey(hkey, strPath, keyhand)
    If R = ERROR_SUCCESS Then
        R = RegSetValueEx(keyhand, strValue, 0, REG_SZ, ByVal strdata, Len(strdata))
        R = RegCloseKey(keyhand)
    End If
End Sub

Public Sub DeleteKey(ByVal hkey As HKeyTypes, ByVal strPath As String)
    Dim R As Long
    
    R = RegDeleteKey(hkey, strPath)
End Sub

'Takes Root, Key and Sets all the subkeys in global collection
Public Sub GetKeyNames(ByVal hkey As Long, ByVal strPath As String, colKeys As Collection)
    Dim Cnt As Long, StrBuff As String, strKey As String, TKey As Long
    
    RegOpenKey hkey, strPath, TKey
    Do
        StrBuff = String(255, vbNullChar)
        If RegEnumKeyEx(TKey, Cnt, StrBuff, 255, 0, vbNullString, 0, ByVal 0&) <> 0 Then Exit Do
        Cnt = Cnt + 1
        strKey = Left$(StrBuff, InStr(StrBuff, vbNullChar) - 1)
        colKeys.Add strKey
    Loop
End Sub

'Enumerates all the values in key and takes root and key
'Returns a collection in which each valu name, data and type is tored in an array of size 2
Function EnumRegistryValuesEx(ByVal hkey As Long, ByVal KeyName As String) As Collection
On Error Resume Next
    Dim handle As Long, index As Long, valueType As Long, name As String, nameLen As Long
    Dim resLong As Long, resString As String, dataLen As Long, valueInfo(0 To 2) As Variant
    Dim retVal As Long
    
    ' Initialize the result
    Set EnumRegistryValuesEx = New Collection
    
    ' Open the key, exit if not found.
    If Len(KeyName) Then
        If RegOpenKeyEx(hkey, KeyName, 0, KEY_READ, handle) Then Exit Function
        ' In all cases, subsequent functions use hKey
        hkey = handle
    End If
    
    Do
        ' This is the max length for a key name
        nameLen = 260
        name = Space$(nameLen)
        
        ' Prepare the receiving buffer for the value
        dataLen = 4096
        ReDim resBinary(0 To dataLen - 1) As Byte
        
        ' Read the value's name and data and exit the loop if not found
        retVal = RegEnumValue(hkey, index, name, nameLen, ByVal 0&, valueType, resBinary(0), dataLen)
        
        ' Enlarge the buffer if you need more space
        If retVal = ERROR_MORE_DATA Then
            ReDim resBinary(0 To dataLen - 1) As Byte
            retVal = RegEnumValue(hkey, index, name, nameLen, ByVal 0&, valueType, resBinary(0), dataLen)
        End If
        
        ' Exit the loop if any other error (typically, no more values)
        If retVal Then Exit Do
        
        ' Retrieve the value's name
        valueInfo(0) = Left$(name, nameLen)
        valueInfo(1) = ""
        valueInfo(2) = ""
        
        ' Return a value corresponding to the value type
        Select Case valueType
            Case REG_DWORD
                CopyMemory resLong, resBinary(0), 4
                valueInfo(1) = resLong
                valueInfo(2) = vbLong
            Case REG_SZ, REG_EXPAND_SZ
                ' Copy everything but the trailing null char
                resString = Space$(dataLen - 1)
                CopyMemory ByVal resString, resBinary(0), dataLen - 1
                valueInfo(1) = resString
                valueInfo(2) = vbString
            Case REG_BINARY
                ' Shrink the buffer if necessary
                If dataLen < UBound(resBinary) + 1 Then
                    ReDim Preserve resBinary(0 To dataLen - 1) As Byte
                End If
                valueInfo(1) = resBinary()
                valueInfo(2) = vbArray + vbByte
            Case REG_MULTI_SZ
                ' Copy everything but the 2 trailing null chars
                resString = Space$(dataLen - 2)
                CopyMemory ByVal resString, resBinary(0), dataLen - 2
                valueInfo(1) = resString
                valueInfo(2) = vbString
            Case Else
                ' Unsupported value type - do nothing
        End Select
        
        ' Add the array to the result collection, the element's key is the value's name
        EnumRegistryValuesEx.Add valueInfo, valueInfo(0)
        
        index = index + 1
    Loop
   
    ' Close the key, if it was actually opened
    If handle Then RegCloseKey handle
End Function

' Takes Root, Key and Value and returns the string data

Public Function GetStringValue(hkey As HKeyTypes, strPath As String, strValue As String) As String
    Dim keyhand As Long, lRegResult As Long, strBuf As String, lDataBufSize As Long
    Dim lValueType As Long, lresult As Long
    
    lRegResult = RegOpenKey(hkey, strPath, keyhand)
    lRegResult = RegQueryValueEx(keyhand, strValue, 0&, lValueType, ByVal 0&, lDataBufSize)
    If lValueType = REG_SZ Or REG_EXPAND_SZ Then
        strBuf = String(lDataBufSize, " ")
        lresult = RegQueryValueEx(keyhand, strValue, 0&, 0&, ByVal strBuf, lDataBufSize)
        If lresult = ERROR_SUCCESS Then
            strBuf = StripNull(strBuf)
            GetStringValue = strBuf
        End If
    End If
End Function

'Takes Root, Key and Value and returns the long data
Public Function GetDWORDValue(lngKeyRoot As Long, subKey As String, Entry As String) As Long
    Dim rtn As Long, lBuffer As Long, hkey As Long
   
    rtn = RegOpenKeyEx(lngKeyRoot, subKey, 0, KEY_READ, hkey) 'Open the key
    If rtn = ERROR_SUCCESS Then ' If the key could be opened then
        rtn = RegQueryValueEx(hkey, Entry, 0, REG_DWORD, lBuffer, 4) ' Get the value from the registry
        If rtn = ERROR_SUCCESS Then ' If the value could be retreived then
            rtn = RegCloseKey(hkey)  ' Close the key
            GetDWORDValue = lBuffer  ' Return the value
        Else
            GetDWORDValue = 0
        End If
    End If
End Function

' Get the binay value from a key and takes root, Key, value and sets the data in array
' Returns the boolean if succeeds
' Used only to retirve ARPCache SlowInfoCache
Public Function GetBinaryValue(lngKeyRoot As Long, subKey As String, Entry As String, sBuffer() As Byte) As Boolean
On Error GoTo errHandle:
    Dim hkey As Long, lBufferSize As Long, rtn As Long
   
   lBufferSize = 1
   rtn = RegOpenKeyEx(lngKeyRoot, subKey, 0, KEY_READ, hkey) 'open the key
   If rtn = ERROR_SUCCESS Then 'if the key could be opened
        lBufferSize = 1
        rtn = RegQueryValueEx(hkey, Entry, 0, REG_BINARY, 0, lBufferSize) 'get the value from the registry
        ReDim sBuffer(lBufferSize - 1)
        rtn = RegQueryValueEx(hkey, Entry, 0, REG_BINARY, sBuffer(0), lBufferSize) 'get the value from the registry
        If rtn = ERROR_SUCCESS Then 'if the value could be retreived then
            rtn = RegCloseKey(hkey)  'close the key
            'Check if array is of correct size
            If UBound(sBuffer) = 551 Then
                GetBinaryValue = True
            End If
        End If
    End If
    Exit Function
errHandle:
   GetBinaryValue = False
End Function