VBA/Excel/Access/Word/Windows API/Registry

Материал из VB Эксперт
Перейти к: навигация, поиск

Reads a value from the Windows Registry

 
Private Declare Function RegOpenKeyA Lib "ADVAPI32.DLL" (ByVal hKey As Long, ByVal sSubKey As String, ByRef hkeyResult As Long) As Long
Private Declare Function RegCloseKey Lib "ADVAPI32.DLL" (ByVal hKey As Long) As Long
Private Declare Function RegSetValueExA Lib "ADVAPI32.DLL" (ByVal hKey As Long, ByVal sValueName As String, ByVal dwReserved As Long, ByVal dwType As Long, ByVal sValue As String, ByVal dwSize As Long) As Long
Private Declare Function RegCreateKeyA Lib "ADVAPI32.DLL" (ByVal hKey As Long, ByVal sSubKey As String, ByRef hkeyResult As Long) As Long
Private Declare Function RegQueryValueExA Lib "ADVAPI32.DLL" (ByVal hKey As Long, ByVal sValueName As String, ByVal dwReserved As Long, ByRef lValueType As Long, ByVal sValue As String, ByRef lResultLen As Long) As Long
Function GetRegistry(Key, Path, ByVal ValueName As String)
    Dim hKey As Long
    Dim lValueType As Long
    Dim sResult As String
    Dim lResultLen As Long
    Dim ResultLen As Long
    Dim x, TheKey As Long
    Select Case UCase(Key)
        Case "HKEY_CLASSES_ROOT": TheKey = &H80000000
        Case "HKEY_CURRENT_USER": TheKey = &H80000001
        Case "HKEY_LOCAL_MACHINE": TheKey = &H80000002
        Case "HKEY_USERS": TheKey = &H80000003
        Case "HKEY_CURRENT_CONFIG": TheKey = &H80000004
        Case "HKEY_DYN_DATA": TheKey = &H80000005
    End Select
    
    If RegOpenKeyA(TheKey, Path, hKey) <> 0 Then _
        x = RegCreateKeyA(TheKey, Path, hKey)
    
    sResult = Space(100)
    lResultLen = 100
    
    x = RegQueryValueExA(hKey, ValueName, 0, lValueType, _
    sResult, lResultLen)
        
    Select Case x
        Case 0: GetRegistry = Left(sResult, lResultLen - 1)
        Case Else: GetRegistry = "Not Found"
    End Select
    
    RegCloseKey hKey
End Function
Sub TestIt()
    RootKey = "hkey_current_user"
    Path = "software\microsoft\office\9.0\common\autocorrect"
    RegEntry = "path"
    MsgBox GetRegistry(RootKey, Path, RegEntry), vbInformation, _
        Path & "\RegEntry"
End Sub



Using RegQueryValueEx to Read Registry Information

 
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
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
Public Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Sub cmdRead()
    Dim strValue As String * 256
    Dim lngRetval As Long
    Dim lngLength As Long
    Dim lngKey As Long
    If RegOpenKeyEx(HKEY_CURRENT_USER, "Your_Key_Name", 0, KEY_QUERY_VALUE, lngKey) Then
    End If
    lngLength = 256
    "Retrieve the value of the key
    lngRetval = RegQueryValueEx( _
        lngKey, "YourValueName", 0, 0, ByVal strValue, lngLength)
    MsgBox Left(strValue, lngLength)
    "Close the key
    RegCloseKey (lngKey)
End Sub



Using RegSetValueEx to Write Information to the Registry

 
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
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
Public Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Sub cmdWrite_Click()
    Dim strValue As String
    Dim strKeyName As String
    Dim lngRetval As Long
    Dim lngLength As Long
    Dim lngKey As Long
    strKeyName = "KeyName" & vbNullString
    If RegOpenKeyEx(HKEY_CURRENT_USER, strKeyName, 0, KEY_WRITE, lngKey) Then
    End If
    strValue = "YourValue" & vbNullString
    lngLength = Len("YourValue") + 1
    lngRetval = RegSetValueEx( lngKey, "YourValue", 0, REG_SZ, ByVal strValue, lngLength)
    "Close the key
    RegCloseKey (lngKey)
End Sub



Working with the Registry Using the VBA Registry Functions

 
Sub ExperimentWithRegistry() 
    Dim vaKeys As Variant 
    " create new registry entries  
    SaveSetting "XLTest", "General", "App_Name", "XLTest" 
    SaveSetting "XLTest", "General", "App_Version", "1.0.0" 
    SaveSetting "XLTest", "General", "App_Date", "10/11/2003" 
    PrintRegistrySettings 
    SaveSetting "XLTest", "General", "App_Version", "1.0.1" 
    PrintRegistrySettings 
    vaKeys = GetAllSettings("XLTest", "General") 
    PrintAllSettings vaKeys 
    DeleteSetting "XLTest", "General", "App_Name" 
    DeleteSetting "XLTest", "General", "App_Version" 
    DeleteSetting "XLTest", "General", "App_Date" 
    PrintRegistrySettings 
End Sub 
Sub PrintRegistrySettings() 
    On Error Resume Next 
    Debug.Print "Application Name: " & GetSetting("XLTest", "General", "App_Name") 
    Debug.Print "Application Version: " & GetSetting("XLTest", "General", "App_Version") 
    Debug.Print "Application Date: " & GetSetting("XLTest", "General", "App_Date") 
End Sub 
Sub PrintAllSettings(vaSettings As Variant) 
    Dim nItem As Integer 
    If IsArray(vaSettings) Then 
        For nItem = 0 To UBound(vaSettings) 
            Debug.Print vaSettings(nItem, 0) & ": " & _ 
                vaSettings(nItem, 1) 
        Next 
    End If 
End Sub



Write a value from the Windows Registry

 
Private Declare Function RegOpenKeyA Lib "ADVAPI32.DLL" (ByVal hKey As Long, ByVal sSubKey As String, ByRef hkeyResult As Long) As Long
Private Declare Function RegCloseKey Lib "ADVAPI32.DLL" (ByVal hKey As Long) As Long
Private Declare Function RegSetValueExA Lib "ADVAPI32.DLL" (ByVal hKey As Long, ByVal sValueName As String, ByVal dwReserved As Long, ByVal dwType As Long, ByVal sValue As String, ByVal dwSize As Long) As Long
Private Declare Function RegCreateKeyA Lib "ADVAPI32.DLL" (ByVal hKey As Long, ByVal sSubKey As String, ByRef hkeyResult As Long) As Long
Private Declare Function RegQueryValueExA Lib "ADVAPI32.DLL" (ByVal hKey As Long, ByVal sValueName As String, ByVal dwReserved As Long, ByRef lValueType As Long, ByVal sValue As String, ByRef lResultLen As Long) As Long
Function GetRegistry(Key, Path, ByVal ValueName As String)
    Dim hKey As Long
    Dim lValueType As Long
    Dim sResult As String
    Dim lResultLen As Long
    Dim ResultLen As Long
    Dim x, TheKey As Long
    TheKey = -99
    Select Case UCase(Key)
        Case "HKEY_CLASSES_ROOT": TheKey = &H80000000
        Case "HKEY_CURRENT_USER": TheKey = &H80000001
        Case "HKEY_LOCAL_MACHINE": TheKey = &H80000002
        Case "HKEY_USERS": TheKey = &H80000003
        Case "HKEY_CURRENT_CONFIG": TheKey = &H80000004
        Case "HKEY_DYN_DATA": TheKey = &H80000005
    End Select
    
    If TheKey = -99 Then
        GetRegistry = "Not Found"
        Exit Function
    End If
    If RegOpenKeyA(TheKey, Path, hKey) <> 0 Then _
        x = RegCreateKeyA(TheKey, Path, hKey)
    
    sResult = Space(100)
    lResultLen = 100
    
    x = RegQueryValueExA(hKey, ValueName, 0, lValueType, _
    sResult, lResultLen)
        
    Select Case x
        Case 0: GetRegistry = Left(sResult, lResultLen - 1)
        Case Else: GetRegistry = "Not Found"
    End Select
    
    RegCloseKey hKey
End Function
Private Function WriteRegistry(ByVal Key As String, _
    ByVal Path As String, ByVal entry As String, _
    ByVal value As String)
    
    Dim hKey As Long
    Dim lValueType As Long
    Dim sResult As String
    Dim lResultLen As Long
   
    TheKey = -99
    Select Case UCase(Key)
        Case "HKEY_CLASSES_ROOT": TheKey = &H80000000
        Case "HKEY_CURRENT_USER": TheKey = &H80000001
        Case "HKEY_LOCAL_MACHINE": TheKey = &H80000002
        Case "HKEY_USERS": TheKey = &H80000003
        Case "HKEY_CURRENT_CONFIG": TheKey = &H80000004
        Case "HKEY_DYN_DATA": TheKey = &H80000005
    End Select
    
    If TheKey = -99 Then
        WriteRegistry = False
        Exit Function
    End If
    If RegOpenKeyA(TheKey, Path, hKey) <> 0 Then
        x = RegCreateKeyA(TheKey, Path, hKey)
    End If
    x = RegSetValueExA(hKey, entry, 0, 1, value, Len(value) + 1)
    If x = 0 Then WriteRegistry = True Else WriteRegistry = False
End Function

Sub UpdateRegistryWithTime()
    RootKey = "hkey_current_user"
    Path = "software\microsoft\office\9.0\excel\LastStarted"
    RegEntry = "DateTime"
    RegVal = Now()
    LastTime = GetRegistry(RootKey, Path, RegEntry)
    Debug.Print LastTime
    
    Call WriteRegistry(RootKey, Path, RegEntry, RegVal)
End Sub
Источник — «http://vbex.ru/index.php?title=VBA/Excel/Access/Word/Windows_API/Registry&oldid=1946»