basregistry.bas

可直接打开编辑网络数据库

Attribute VB_Name = "basRegistry"
Option Explicit

Const DCP_AUTHN_LEVEL_DEFAULT = 0
Const DCP_AUTHN_LEVEL_NONE = 1
Const DCP_AUTHN_LEVEL_CONNECT = 2
Const DCP_AUTHN_LEVEL_CALL = 3
Const DCP_AUTHN_LEVEL_PKT = 4
Const DCP_AUTHN_LEVEL_PKT_INTEGRITY = 5
Const DCP_AUTHN_LEVEL_PKT_PRIVACY = 6

Public Const REG_NONE = 0
Public Const REG_SZ = 1
Public Const REG_EXPAND_SZ = 2
Public Const REG_BINARY = 3
Public Const REG_DWORD = 4
Public Const REG_DWORD_LITTLE_ENDIAN = 4
Public Const REG_DWORD_BIG_ENDIAN = 5
Public Const REG_LINK = 6
Public Const REG_MULTI_SZ = 7
Public Const REG_RESOURCE_LIST = 8
Public Const REG_FULL_RESOURCE_DESCRIPTOR = 9
Public Const REG_RESOURCE_REQUIREMENTS_LIST = 10

Public Enum hKeyNames
    HKEY_CLASSES_ROOT = &H80000000
    HKEY_CURRENT_USER = &H80000001
    HKEY_LOCAL_MACHINE = &H80000002
    HKEY_USERS = &H80000003
    HKEY_CURRENT_CONFIG = &H80000005
End Enum

Public Const ERROR_SUCCESS = 0&
Public Const ERROR_NONE = 0
Public Const ERROR_BADDB = 1
Public Const ERROR_BADKEY = 2
Public Const ERROR_CANTOPEN = 3
Public Const ERROR_CANTREAD = 4
Public Const ERROR_CANTWRITE = 5
Public Const ERROR_OUTOFMEMORY = 6
Public Const ERROR_ARENA_TRASHED = 7
Public Const ERROR_ACCESS_DENIED = 8
Public Const ERROR_INVALID_PARAMETERS = 87
Public Const ERROR_NO_MORE_ITEMS = 259

Private Const SYNCHRONIZE = &H100000
Private Const STANDARD_RIGHTS_READ = &H20000
Private Const STANDARD_RIGHTS_WRITE = &H20000
Private Const STANDARD_RIGHTS_EXECUTE = &H20000
Private Const STANDARD_RIGHTS_REQUIRED = &HF0000
Private Const STANDARD_RIGHTS_ALL = &H1F0000
Private Const KEY_QUERY_VALUE = &H1
Private Const KEY_SEDataValue = &H2
Private Const KEY_CREATE_SUB_KEY = &H4
Private Const KEY_ENUMERATE_SUB_KEYS = &H8
Private Const KEY_NOTIFY = &H10
Private Const KEY_CREATE_LINK = &H20
Private Const KEY_READ = ((STANDARD_RIGHTS_READ Or KEY_QUERY_VALUE Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY) And (Not SYNCHRONIZE))

Public Const KEY_ALL_ACCESS = &H3F

Public Const REG_OPTION_NON_VOLATILE = 0


Declare Function WritePrivateProfileString Lib "KERNEL32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lpFileName As String) As Long
Declare Function GetPrivateProfileString Lib "KERNEL32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
Declare Function GetPrivateProfileInt Lib "KERNEL32" Alias "GetPrivateProfileIntA" (ByVal lpApplicationName As String, ByVal lpKeyName As String, ByVal nDefault As Long, ByVal lpFileName As String) As Long


Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
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, lpdwDisposition As Long) As Long
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
Declare Function RegQueryValueExString 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
Declare Function RegQueryValueExLong Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Long, lpcbData As Long) As Long
Declare Function RegQueryValueExNULL Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, ByVal lpData As Long, lpcbData As Long) As Long
Declare Function RegSetValueExString Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, ByVal lpValue As String, ByVal cbData As Long) As Long
Declare Function RegSetValueExLong Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpValue As Long, ByVal cbData As Long) As Long
Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey As String) As Long
Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal hKey As Long, ByVal lpValueName As String) As Long
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
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 Byte, lpcbData As Long) As Long


Declare Function SetEnvironmentVariable Lib "KERNEL32" Alias "SetEnvironmentVariableA" (ByVal lpName As String, ByVal lpValue As String) As Long
Declare Function GetEnvironmentVariable Lib "KERNEL32" Alias "GetEnvironmentVariableA" (ByVal lpName As String, ByVal lpBuffer As String, ByVal nSize As Long) As Long



Public Sub EnumRegKeys(ByRef returnName As Collection, Optional ByRef returnSubs As Collection, Optional hKeyName As String = "HKEY_CURRENT_USER", Optional KeyName As String = "SOFTWARE", Optional ByVal checkForSubs As Boolean = False)
    Dim lRetVal As Long
    Dim lngResult2 As Long
    Dim hKey2 As Long
    Dim hKey As Long
    Dim vValue As Variant
    Dim lngKeyHandle As Long
    Dim lngResult As Long
    Dim lngCurIdx As Long
    Dim strValue As String
    Dim lngValueLen As Long
    Dim lngData As Long
    Dim lngDataLen As Long
    Dim strResult As String
    Dim lKeyName As Long
    Dim SubLevel As Boolean

    Set returnName = New Collection
    Set returnSubs = New Collection
    
    KeyName = CompileKeyString(KeyName)
    
    lKeyName = resolveHkeyLong(hKeyName)
    
    Do
        lRetVal = RegOpenKeyEx(lKeyName, KeyName, 0, KEY_READ, hKey)
        lngValueLen = 2000
        strValue = String(lngValueLen, 0)
        lngDataLen = 2000
        lngResult = RegEnumKey(hKey, lngCurIdx, ByVal strValue, lngValueLen)
        lngCurIdx = lngCurIdx + 1
        RegCloseKey (hKey)
        
        If lngResult = ERROR_SUCCESS Then
            strResult = Left(strValue, lngValueLen)
            If InStr(1, strResult, Chr(0) & Chr(0) & Chr(0) & Chr(0), vbTextCompare) <> 0 Then
                strResult = Mid(strResult, 1, InStr(1, strResult, Chr(0) & Chr(0) & Chr(0) & Chr(0), vbTextCompare) - 1)
            Else
                strResult = strResult
            End If
            If checkForSubs = True Then
                If KeyName = "" Then
                    lngResult2 = RegOpenKeyEx(lKeyName, strResult, 0, KEY_READ, hKey2)
                Else
                    lngResult2 = RegOpenKeyEx(lKeyName, KeyName & "\" & strResult, 0, KEY_READ, hKey2)
                End If
                strValue = String(lngValueLen, 0)
                lngResult2 = RegEnumKey(hKey2, 0, ByVal strValue, lngValueLen)
                RegCloseKey (hKey2)
                If lngResult2 = ERROR_SUCCESS Then
                    SubLevel = True
                Else
                    SubLevel = False
                End If
                returnSubs.Add SubLevel
            End If
            returnName.Add strResult
        End If
    Loop While lngResult = ERROR_SUCCESS
    

End Sub

Public Sub EnumRegValues(ByRef returnName As Collection, Optional ByRef returnData As Collection, Optional ByRef returnType As Collection, Optional hKeyName As String = "HKEY_CURRENT_USER", Optional KeyName As String = "SOFTWARE")
    Dim lRetVal As Long      'result of the API functions
    Dim hKey As Long         'handle of opened key
    Dim hKey2 As Long
    Dim vValue As Variant    'setting of queried value
    Dim Count As Integer
    Dim lngKeyHandle As Long
    Dim lngResult As Long
    Dim lngCurIdx As Long
    Dim strValue As String
    Dim lngValueLen As Long
    Dim lngData As Long
    Dim lngDataLen As Long
    Dim strResult As String
    Dim lKeyName As Long
    Dim retData As String
    Dim retType As Long

    lKeyName = resolveHkeyLong(hKeyName)

    Set returnName = New Collection
    Set returnData = New Collection
    Set returnType = New Collection
    
    KeyName = CompileKeyString(KeyName)
    
    lRetVal = RegOpenKeyEx(lKeyName, KeyName, 0, KEY_READ, hKey)

    Do
        lngValueLen = 2000
        strValue = String(lngValueLen, 0)
        lngDataLen = 2000
        lngResult = RegEnumValue(hKey, lngCurIdx, ByVal strValue, lngValueLen, 0&, REG_DWORD, ByVal lngData, lngDataLen)
        lngCurIdx = lngCurIdx + 1
        If lngResult = ERROR_SUCCESS Then
            strResult = Left(strValue, lngValueLen)
            Call returnName.Add(strResult)
            Call RegOpenKeyEx(lKeyName, KeyName, 0, KEY_ALL_ACCESS, hKey2)
            Call QueryValueEx(hKey2, strResult, retData, retType)
            Call RegCloseKey(hKey2)
            Call returnData.Add(retData)
            Call returnType.Add(retType)
        End If
    Loop While lngResult = ERROR_SUCCESS

    RegCloseKey (hKey)

End Sub

Public Function GetSetting(appName As String, Section As String, Key As String, Optional Default As String, Optional hKeyName As hKeyNames = HKEY_CURRENT_USER, Optional AppNameHeader As String = "SOFTWARE")

Dim lRetVal As Long
Dim hKey As Long
Dim vValue As Variant
Dim keystring As String

    On Error GoTo e_Trap
    
    keystring = CompileKeyString(AppNameHeader, appName, Section)

    lRetVal = RegOpenKeyEx(hKeyName, keystring, 0, KEY_ALL_ACCESS, hKey)
    lRetVal = QueryValueEx(hKey, Key, vValue)
    If IsEmpty(vValue) Or vValue = "" Then
        vValue = Default
    End If
    GetSetting = vValue
    RegCloseKey (hKey)
    Exit Function
e_Trap:
    vValue = Default
    Exit Function
End Function
Public Function SaveSetting(appName As String, Section As String, Key As String, Setting As String, Optional hKeyName As hKeyNames = HKEY_CURRENT_USER, Optional AppNameHeader As String = "SOFTWARE") As Boolean

Dim lRetVal As Long
Dim hKey As Long
Dim keystring As String

    On Error GoTo e_Trap
    
    keystring = CompileKeyString(AppNameHeader, appName, Section)

    lRetVal = RegCreateKeyEx(hKeyName, keystring, 0&, vbNullString, REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS, 0&, hKey, lRetVal)
    lRetVal = SetValueEx(hKey, Key, REG_SZ, Setting)
    RegCloseKey (hKey)
    SaveSetting = True
    Exit Function
e_Trap:
    SaveSetting = False
    Exit Function
End Function
Public Function DeleteSetting(appName As String, Optional Section As String, Optional Key As String, Optional hKeyName As hKeyNames = HKEY_CURRENT_USER, Optional AppNameHeader As String = "SOFTWARE", Optional recurseSubs As Boolean = True) As Boolean

Dim hNewKey As Long
Dim lRetVal As Long
Dim hKey As Long
Dim keystring As String
Dim returnName As Collection
Dim returnSubs As Collection
Dim Count As Integer

    On Error GoTo e_Trap
    
    keystring = CompileKeyString(AppNameHeader, appName, Section)
    
    If Key <> "" Then
        lRetVal = RegCreateKeyEx(hKeyName, keystring, 0&, vbNullString, REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS, 0&, hKey, lRetVal)
        lRetVal = RegDeleteValue(hKey, Key)
        RegCloseKey (hKey)
    Else
        lRetVal = RegDeleteKey(hKeyName, keystring)
        If lRetVal = ERROR_CANTWRITE Then
            Call EnumRegKeys(returnName, returnSubs, resolveHkeyString(hKeyName), keystring)
            For Count = 1 To returnName.Count
                Call DeleteSetting(keystring & "\" & returnName(Count), "", "", hKeyName, "")
            Next Count
            lRetVal = RegDeleteKey(hKeyName, keystring)
        End If
    End If
    If lRetVal = ERROR_SUCCESS Then
        DeleteSetting = True
    Else
        DeleteSetting = False
    End If
    Exit Function
e_Trap:
    DeleteSetting = False
    Exit Function
End Function

Public Function AssociateFileType(extension As String, Optional useNotepadToEdit As Boolean = True, Optional appName As String, Optional filePath As String, Optional setDefault As Boolean = False) As Boolean
Dim lRetVal As Long
Dim hKey As Long
Dim appPath As String
Dim appTitle As String
Dim commandString As String
Dim appKey As String

    On Error GoTo e_Trap
    
    If filePath = "" Then
        If Mid(App.Path, Len(App.Path) - 1, 1) = "\" Then
            appPath = App.Path & App.EXEName & ".exe"
        Else
            appPath = App.Path & "\" & App.EXEName & ".exe"
        End If
    Else
        appPath = filePath
    End If